- movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Mar '08

21 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19575 Modified Files: setf.lisp Log Message: Add a trivial run-time get-setf-expander. --- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/04/13 23:29:31 1.6 +++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2008/03/21 00:20:22 1.7 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Feb 8 20:43:20 2001 ;;;; -;;;; $Id: setf.lisp,v 1.6 2007/04/13 23:29:31 ffjeld Exp $ +;;;; $Id: setf.lisp,v 1.7 2008/03/21 00:20:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,6 +60,14 @@ `(funcall #'(setf ,(car place)) ,store-var ,@arglist) (list* (car place) arglist))))))))))) +(eval-when (:load-toplevel) + (defun get-setf-expansion (place &optional env) + (cond + ((symbolp place) + (let ((store-var (gensym "store-var-"))) + (values nil nil (list store-var) `(setq ,place ,store-var) place))) + (t (error "Place ~S not implemented."))))) + ;;;(defsetf subseq (sequence start &optional end) (new-sequence) ;;; `(progn (replace ,sequence ,new-sequence

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Mar '08

21 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16983 Modified Files: eval.lisp Log Message: Support macrolet in eval. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/20 22:49:28 1.25 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 00:06:07 1.26 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.25 2008/03/20 22:49:28 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.26 2008/03/21 00:06:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,24 +39,29 @@ ;; (warn "env: ~S in ~S" var env) (find var env :key #'car)) -(defun op-env-binding (type env var) +(defun op-env-binding (env var &rest types) + (declare (dynamic-extent types)) (dolist (binding env) - (when (and (eq type (car binding)) - (eq var (cadr binding))) - (return (cdr binding))))) + (when (and (consp (cdr binding)) + (eq var (cadr binding)) + (or (null types) + (member (car binding) types))) + (return binding)))) ;; These are integers because regular (lexical) bindings are never ;; named by integers. (defconstant +eval-binding-type-flet+ 0) (defconstant +eval-binding-type-go-tag+ 1) (defconstant +eval-binding-type-block+ 2) +(defconstant +eval-binding-type-macrolet+ 3) (defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" (if (symbol-constant-variable-p form) (symbol-value form) (let ((binding (env-binding env form))) - (or (and binding (cdr binding)) + (if binding + (cdr binding) (symbol-value form))))) ;;; block let* return-from @@ -91,8 +96,20 @@ (cadr form) form) env)))) + ((macrolet) + (dolist (macrolet (cadr form)) + (destructuring-bind (name lambda &body body) + macrolet + (check-type name symbol) + (check-type lambda list) + (push (list* +eval-binding-type-macrolet+ + name + (cdr macrolet)) + env))) + (eval-progn (cddr form) + env)) ((return-from) - (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) + (let ((b (cdr (op-env-binding env (cadr form) +eval-binding-type-block+)))) (unless b (error "Block ~S is not visible." (cadr form))) (throw (cdr b) (eval-form (caddr form) env)))) @@ -126,7 +143,7 @@ (unwind-protect (eval-form (second form) env) (eval-progn (cddr form) env))) - ((macrolet symbol-macrolet let*) + ((symbol-macrolet let*) (error "Special operator ~S not implemented in ~S." (car form) 'eval)) (t (eval-funcall form env)))) @@ -360,7 +377,7 @@ (defun eval-function (function-name env) (etypecase function-name (symbol - (let ((binding (op-env-binding +eval-binding-type-flet+ env function-name))) + (let ((binding (cdr (op-env-binding env function-name +eval-binding-type-flet+)))) (or (and binding (cdr binding)) (symbol-function function-name)))) (list @@ -420,7 +437,7 @@ (defun eval-go (form env) (declare (ignore)) (let* ((tag (cadr form)) - (b (op-env-binding +eval-binding-type-go-tag+ env tag))) + (b (cdr (op-env-binding env tag +eval-binding-type-go-tag+)))) (unless b (error "Go-tag ~S is not visible." tag)) (throw (cdr b) (values tag)))) @@ -482,13 +499,26 @@ (defun macroexpand-1 (form &optional env) (if (atom form) - (values form nil) - (let ((macro-function (macro-function (car form)))) - (if macro-function - (values (funcall *macroexpand-hook* macro-function form env) - t) - (values form - nil))))) + (values form nil) ; no symbol-macros yet + (let* ((operator (car form)) + (macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+))) + (if macrolet-binding + (destructuring-bind (lambda-list &body body) + (cddr macrolet-binding) + (let ((expander (lambda (form env) + (eval-form `(destructuring-bind (ignore-operator ,@lambda-list) + ',form + (declare (ignore ignore-operator)) + ,@body) + env)))) + (values (funcall *macroexpand-hook* expander form env) + t))) + (let ((macro-function (macro-function operator))) + (if macro-function + (values (funcall *macroexpand-hook* macro-function form env) + t) + (values form + nil))))))) (defun macroexpand (form &optional env) (do ((expanded-at-all-p nil)) (nil)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv1370 Modified Files: basic-macros.lisp Log Message: Add a runtime do* macro. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/17 23:24:44 1.74 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/20 22:50:01 1.75 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.74 2008/03/17 23:24:44 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.75 2008/03/20 22:50:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -275,14 +275,14 @@ (unless ,end-test-form (go ,loop-tag))) ,@result-forms)))))) -(defmacro/cross-compilation do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) +(defmacro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) (cond - ((symbolp var-spec) - var-spec) - ((cddr var-spec) - (subseq var-spec 0 2)) - (t var-spec))) + ((symbolp var-spec) + var-spec) + ((cddr var-spec) + (subseq var-spec 0 2)) + (t var-spec))) (var-spec-var (var-spec) (if (symbolp var-spec) var-spec (car var-spec))) (var-spec-step-form (var-spec) @@ -291,22 +291,24 @@ (or (third var-spec) '(quote nil))))) (multiple-value-bind (body declarations) - (movitz::parse-declarations-and-body declarations-and-body 'cl:declare) + (parse-declarations-and-body declarations-and-body) (let* ((loop-tag (gensym "do*-loop")) (start-tag (gensym "do*-start"))) `(block nil (let* ,(mapcar #'var-spec-let-spec var-specs) (declare ,@declarations) (tagbody - (go ,start-tag) - ,loop-tag - ,@body - (setq ,@(loop for var-spec in var-specs - as step-form = (var-spec-step-form var-spec) - when step-form - append (list (var-spec-var var-spec) step-form))) - ,start-tag - (unless ,end-test-form (go ,loop-tag))) + (go ,start-tag) + ,loop-tag + ,@body + (setq ,@(mapcan (lambda (var-spec) + (let ((step-form (var-spec-step-form var-spec))) + (when step-form + (list (var-spec-var var-spec) + step-form)))) + var-specs)) + ,start-tag + (unless ,end-test-form (go ,loop-tag))) ,@result-forms)))))) (define-compiler-macro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv1296 Modified Files: eval.lisp Log Message: Add special operator let* to eval. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 15:00:31 1.24 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/20 22:49:28 1.25 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.24 2008/03/19 15:00:31 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.25 2008/03/20 22:49:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -101,6 +101,9 @@ (setf (eval-setf form env)) ((defvar) (eval-defvar form env)) (let (eval-let (cadr form) (cddr form) env)) + (let* (multiple-value-bind (body declarations) + (parse-declarations-and-body (cddr form)) + (eval-let* (cadr form) declarations body env))) ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) ((lambda) (eval-function form env)) ; the lambda macro.. ((multiple-value-bind) @@ -321,6 +324,30 @@ (progv special-vars special-values (eval-progn body local-env)))))) +(defun eval-let* (var-specs declarations body env) + (if (null var-specs) + (eval-progn body env) + (multiple-value-bind (var init-form) + (let ((var-spec (pop var-specs))) + (if (atom var-spec) + (values var-spec nil) + (destructuring-bind (var init-form) + var-spec + (values var init-form)))) + (if (or (symbol-special-variable-p var) + (declared-special-p var declarations)) + (progv (list var) (list (eval-form init-form env)) + (eval-let* var-specs + declarations + body + env)) + (eval-let* var-specs + declarations + body + (cons (cons var + (eval-form init-form env)) + env)))))) + (defun eval-m-v-bind (form env) (destructuring-bind (variables values-form &body body) (cdr form)

1 0

[movitz-cvs] CVS movitz
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv28020 Modified Files: storage-types.lisp Log Message: Add update-movitz-object (movitz-std-instance). --- /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/15 20:57:06 1.60 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/20 22:24:27 1.61 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.60 2008/03/15 20:57:06 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.61 2008/03/20 22:24:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1218,6 +1218,9 @@ :stream stream)))) object) +(defmethod update-movitz-object ((object movitz-std-instance) lisp-object) + object) + ;;;; (define-binary-class movitz-bignum (movitz-heap-object-other)

1 0

[movitz-cvs] CVS movitz
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27966 Modified Files: image.lisp Log Message: Add package muerte.cl-user. Add reading of complexes and pathnames. --- /project/movitz/cvsroot/movitz/image.lisp 2008/03/15 20:45:21 1.117 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/03/20 22:24:06 1.118 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.117 2008/03/15 20:45:21 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.118 2008/03/20 22:24:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1201,6 +1201,8 @@ (find-package :muerte.common-lisp)))) (setf (gethash "NIL" (funcall 'muerte:package-object-external-symbols movitz-cl-package)) nil)) + (ensure-package (symbol-name :common-lisp-user) + (find-package :muerte.common-lisp-user)) (loop for symbol being the hash-key of (image-oblist *image*) as lisp-package = (symbol-package symbol) as package-name = (and lisp-package @@ -1668,6 +1670,17 @@ (movitz-read (cdr expr))))))) (hash-table (make-movitz-hash-table expr)) + (pathname + (make-instance 'movitz-struct + :class (muerte::movitz-find-class 'muerte::pathname) + :length 1 + :slot-values (list (movitz-read (namestring expr))))) + (complex + (make-instance 'movitz-struct + :class (muerte::movitz-find-class 'muerte::complex) + :length 2 + :slot-values (list (movitz-read (realpart expr)) + (movitz-read (imagpart expr))))) (ratio (make-instance 'movitz-ratio :value expr)) @@ -1687,7 +1700,10 @@ slot-descriptions)) movitz-object))) (float ; XXX - (movitz-read (rationalize expr)))))))) + (movitz-read (rationalize expr))) + (class + (muerte::movitz-find-class (translate-program (class-name expr) + :cl :muerte.cl)))))))) ;;;

1 0

[movitz-cvs] CVS movitz
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27903 Modified Files: packages.lisp Log Message: Add package muerte.cl-user. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/02/25 23:34:46 1.57 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/03/20 22:23:28 1.58 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.57 2008/02/25 23:34:46 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.58 2008/03/20 22:23:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1084,6 +1084,11 @@ yes-or-no-p zerop)) +(defpackage muerte.common-lisp-user + (:nicknames muerte.cl-user) + (:use muerte.common-lisp)) + + (defpackage muerte (:use muerte.mop muerte.common-lisp) (:import-from common-lisp cl:nil) @@ -1101,6 +1106,8 @@ #:check-the #:index + #:defmacro/cross-compilation + #:*print-safely* #:*debugger-function*

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27833 Modified Files: typep.lisp Log Message: Add a silly deftype float. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/03/15 20:58:24 1.55 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/03/20 22:22:40 1.56 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.55 2008/03/15 20:58:24 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.56 2008/03/20 22:22:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -698,6 +698,9 @@ (deftype bit () '(integer 0 1)) +(deftype float () + 'real) + (defun type-of (x) (class-name (class-of x)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27759 Modified Files: lists.lisp Log Message: Add maplist. Tweak copy-list. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/18 16:24:49 1.24 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/20 22:21:31 1.25 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.24 2008/03/18 16:24:49 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.25 2008/03/20 22:21:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -200,10 +200,12 @@ (defun copy-list (list) (if (null list) nil - (let ((new-list (cons (pop list) list))) - (do ((new-tail new-list (cdr new-tail))) - ((atom list) new-list) - (setf (cdr new-tail) (cons (pop list) list)))))) + (let* ((new-list (cons (pop list) nil)) + (new-tail new-list)) + (do () ((atom list) new-list) + (setf new-tail + (setf (cdr new-tail) + (cons (pop list) nil))))))) (defun list (&rest objects) (numargs-case @@ -390,6 +392,33 @@ (setf (car p) x))))) first-list)))) +(defun maplist (function first-list &rest more-lists) + (numargs-case + (2 (function first-list) + (do ((result nil) + (p first-list (cdr p))) + ((endp p) + (nreverse result)) + (push (funcall function p) + result))) + (3 (function first-list second-list) + (do ((result nil) + (p1 first-list (cdr p1)) + (p2 second-list (cdr p2))) + ((or (endp p1) (endp p2)) + (nreverse result)) + (push (funcall function p1 p2) + result))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do ((result nil)) + ((or (endp first-list) + (some #'endp more-lists)) + (nreverse result)) + (push (apply function first-list more-lists) + result) + (setf first-list (cdr first-list) + more-lists (map-into more-lists #'cdr more-lists)))))) (defun nbutlast (list &optional (n 1)) (let ((start-right (nthcdr n list)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27638 Added Files: pathnames.lisp Log Message: Add trivial implementations of complexes and pathnames. --- /project/movitz/cvsroot/movitz/losp/muerte/pathnames.lisp 2008/03/20 22:21:06 NONE +++ /project/movitz/cvsroot/movitz/losp/muerte/pathnames.lisp 2008/03/20 22:21:06 1.1 ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2008, Frode V. Fjeld ;;;; ;;;; Description: Pathnames ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: pathnames.lisp,v 1.1 2008/03/20 22:21:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (require :muerte/basic-macros) (require :muerte/defstruct) (in-package muerte) (provide :muerte/pathnames) (defstruct (pathname (:constructor make-pathname-object)) name)

1 0