movitz-cvs March 2008

movitz-cvs@common-lisp.net

1 participants
76 discussions

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv425 Modified Files: load.lisp Log Message: Remove dead cruft. --- /project/movitz/cvsroot/movitz/load.lisp 2008/02/24 11:57:35 1.13 +++ /project/movitz/cvsroot/movitz/load.lisp 2008/03/15 20:46:17 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; -;;;; $Id: load.lisp,v 1.13 2008/02/24 11:57:35 ffjeld Exp $ +;;;; $Id: load.lisp,v 1.14 2008/03/15 20:46:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,65 +42,38 @@ (setf (ext:default-directory) pwd)))) #-(or cmu) (load "load")) -#+allegro (progn - (load (compile-file #p"../infunix/procfs")) - (load "packages.lisp") - (load "movitz.lisp") - (excl:compile-system :movitz) - (excl:load-system :movitz) - (setf excl:*tenured-bytes-limit* #x2000000) - (setf (system::gsgc-parameter :generation-spread) 12) - (sys:resize-areas :new (* 64 1024 1024))) - -#+clisp-older-than-2.33-or-so -(progn (load "packages") - (defconstant movitz::&all 'movitz::&all) ; CLisp has this wonderful bug.. - (defconstant movitz::&code 'movitz::&code) - (defconstant movitz::&form 'movitz::&form) - (defconstant movitz::&returns 'movitz::&returns) - (defconstant movitz::&functional-p 'movitz::&functional-p) - (defconstant movitz::&modifies 'movitz::&modifies) - (defconstant movitz::&type 'movitz::&type) - (defconstant movitz::&final-form 'movitz::&final-form) - (defconstant movitz::&funobj 'movitz::&funobj) - (defconstant movitz::&top-level-p 'movitz::&top-level-p) - (defconstant movitz::&result-mode 'movitz::&result-mode) - (defconstant movitz::&env 'movitz::&env) - (defconstant movitz::&producer 'movitz::&producer)) - - -#-allegro (do () (nil) - (with-simple-restart (retry "Retry loading Movitz") - (return - (with-compilation-unit () - #+cmu (setf bt::*ignore-hidden-slots-for-pcl* t) - (mapcar (lambda (path) - (do () (nil) - #+lispworks-personal-edition (hcl:mark-and-sweep 3) - (with-simple-restart (retry "Retry loading ~S" path) - (return - (handler-bind - (#+sbcl (sb-ext:defconstant-uneql #'continue)) - (load (or (compile-file path :print nil) - (error "Compile-file of ~S failed?" path)))))))) - '("packages" - "movitz" - "parse" - "eval" - "environment" - "compiler-types" - "compiler-protocol" - "storage-types" - "multiboot" - "bootblock" - "image" - "stream-image" - ;; "procfs-image" - "assembly-syntax" - "compiler-protocol" - "compiler" - "special-operators" - "special-operators-cl")))))) +(do () (nil) + (with-simple-restart (retry "Retry loading Movitz") + (return + (with-compilation-unit () + #+cmu (setf bt::*ignore-hidden-slots-for-pcl* t) + (mapcar (lambda (path) + (do () (nil) + #+lispworks-personal-edition (hcl:mark-and-sweep 3) + (with-simple-restart (retry "Retry loading ~S" path) + (return + (handler-bind + (#+sbcl (sb-ext:defconstant-uneql #'continue)) + (load (or (compile-file path :print nil) + (error "Compile-file of ~S failed?" path)))))))) + '("packages" + "movitz" + "parse" + "eval" + "environment" + "compiler-types" + "compiler-protocol" + "storage-types" + "multiboot" + "bootblock" + "image" + "stream-image" + ;; "procfs-image" + "assembly-syntax" + "compiler-protocol" + "compiler" + "special-operators" + "special-operators-cl")))))) #+(and cmu18 (not cmu19)) (setf movitz:*compiler-compile-eval-whens* nil

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32704 Modified Files: image.lisp Log Message: Minor tweaks. --- /project/movitz/cvsroot/movitz/image.lisp 2008/02/24 12:13:06 1.116 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/03/15 20:45:21 1.117 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.116 2008/02/24 12:13:06 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.117 2008/03/15 20:45:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -894,14 +894,13 @@ (unless (typep (movitz-env-named-function (car cf) nil) 'movitz-funobj) (warn "Function ~S is called (in ~S) but not defined." (car cf) (cdr cf)))) - (maphash #'(lambda (symbol function-value) - (let ((movitz-symbol (movitz-read symbol))) - (if (typep function-value 'movitz-object) - ;; (warn "SETTING ~A's funval to ~A" - ;; movitz-symbol function-value) - (setf (movitz-symbol-function-value movitz-symbol) - function-value) - #+ignore (warn "fv: ~W" (movitz-macro-expander-function function-value))))) + (maphash (lambda (symbol function-value) + (let ((movitz-symbol (movitz-read symbol))) + (etypecase function-value + (movitz-funobj + (setf (movitz-symbol-function-value movitz-symbol) function-value)) + (movitz-macro + #+ignore (warn "fv: ~S ~S ~S" symbol function-value (movitz-env-get symbol :macro-expansion)))))) (movitz-environment-function-cells (image-global-environment *image*))) (let ((run-time-context (image-run-time-context *image*))) ;; pull in functions in run-time-context @@ -1169,12 +1168,18 @@ name symbol) name))) (ensure-package (package-name lisp-package &optional context) - (assert (not (member (package-name lisp-package) - #+allegro '(excl common-lisp sys aclmop) - #-allegro '(common-lisp) - :test #'string=)) () - "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz." - lisp-package context) + (restart-case (assert (not (member (package-name lisp-package) + '(common-lisp movitz + #+allegro excl + #+allegro sys + #+allegro aclmop + #+sbcl sb-ext) + :test #'string=)) () + "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz." + lisp-package context) + (use-muerte () + :report "Substitute the muerte pacakge." + (return-from ensure-package (ensure-package :muerte (find-package :muerte))))) (setf (gethash lisp-package lisp-to-movitz-package) (or (gethash package-name packages-hash nil) (let* ((nicks (mapcar #'movitz-package-name (package-nicknames lisp-package))) @@ -1460,8 +1465,10 @@ (length (movitz-funobj-const-list funobj)) (movitz-funobj-const-list funobj) (loop with pc = 0 - for (data . instruction) in (asm:disassemble-proglist code :symtab (movitz-funobj-symtab funobj) - :collect-data t) + for (data . instruction) in (let ((asm-x86:*cpu-mode* :32-bit)) + (asm:disassemble-proglist code + :symtab (movitz-funobj-symtab funobj) + :collect-data t)) when (assoc pc entry-points) collect (list pc nil (format nil " => Entry-point for ~D arguments <=" (cdr (assoc pc entry-points)))

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32418 Modified Files: environment.lisp Log Message: Use hash-tables for macros in environments. --- /project/movitz/cvsroot/movitz/environment.lisp 2007/03/21 19:57:54 1.22 +++ /project/movitz/cvsroot/movitz/environment.lisp 2008/03/15 20:44:53 1.23 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.22 2007/03/21 19:57:54 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.23 2008/03/15 20:44:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,7 +54,10 @@ (setf (movitz-environment-extent-uplink instance) (movitz-environment-uplink instance)))) -(defmethod movitz-environment-compiler-macros ((env movitz-environment)) nil) +(defmethod movitz-environment-macros ((env movitz-environment)) + (load-time-value (make-hash-table :test #'eq))) +(defmethod movitz-environment-compiler-macros ((env movitz-environment)) + (load-time-value (make-hash-table :test #'eq))) (defmethod movitz-environment-function-cells ((env movitz-environment)) (load-time-value (make-hash-table :test #'eq))) (defmethod movitz-environment-modifies-stack ((env movitz-environment)) @@ -87,8 +90,11 @@ (bindings :initform nil :accessor movitz-environment-bindings) + (macros + :initform (make-hash-table :test #'eq :size 400) + :accessor movitz-environment-macros) (compiler-macros - :initform nil + :initform (make-hash-table :test #'eq :size 400) :accessor movitz-environment-compiler-macros))) (defclass with-things-on-stack-env (movitz-environment) @@ -305,7 +311,7 @@ (defparameter *movitz-macroexpand-hook* #'(lambda (macro-function form environment) -;;; (warn "Expanding form ~W" form) +;; (break "Expanding form ~W" form) ;;; (warn "..with body ~W" macro-function) (let ((expansion (funcall macro-function form environment))) (cond @@ -489,13 +495,13 @@ (environment nil) (recurse-p t)) (loop for env = (or environment *movitz-global-environment*) - then (when recurse-p (movitz-environment-uplink env)) - for plist = (and env (getf (movitz-environment-plists env) symbol)) - while env - do (let ((val (getf plist indicator '#0=#:not-found))) - (unless (eq val '#0#) - (return (values val env)))) - finally (return default))) + then (when recurse-p (movitz-environment-uplink env)) + for plist = (and env (getf (movitz-environment-plists env) symbol)) + while env + do (let ((val (getf plist indicator '#0=#:not-found))) + (unless (eq val '#0#) + (return (values val env)))) + finally (return default))) (defun (setf movitz-env-get) (val symbol indicator &optional default environment) @@ -551,41 +557,40 @@ (and (typep binding 'macro-binding) (macro-binding-expander binding))) (loop for env = (or environment *movitz-global-environment*) - then (movitz-environment-uplink env) - for val = (and env (gethash symbol (movitz-environment-function-cells env))) - while env - when val - do (return (and (typep val 'movitz-macro) - (movitz-macro-expander-function val)))))) + then (movitz-environment-uplink env) + for val = (when env + (gethash symbol (movitz-environment-macros env))) + while env + when val + do (return (movitz-macro-expander-function val))))) (defun (setf movitz-macro-function) (fun symbol &optional environment) - (let ((obj (or (gethash symbol (movitz-environment-function-cells (or environment - *movitz-global-environment*))) - (make-instance 'movitz-macro)))) - (setf (slot-value obj 'expander-function) fun) - (setf (gethash symbol (movitz-environment-function-cells (or environment - *movitz-global-environment*))) - obj)) - fun) + (let* ((env (or environment *movitz-global-environment*)) + (obj (or (gethash symbol (movitz-environment-macros env)) + (setf (gethash symbol (movitz-environment-macros env)) + (make-instance 'movitz-macro))))) + (setf (slot-value obj 'expander-function) fun))) ;;; Accessor: COMPILER-MACRO-FUNCTION (defun movitz-compiler-macro-function (name &optional environment) + (gethash name (movitz-environment-compiler-macros *movitz-global-environment*)) + #+ignore (loop for env = (or environment *movitz-global-environment*) - then (movitz-environment-uplink env) - for val = (and env (getf (movitz-environment-compiler-macros env) name)) - while env - when val do (return val))) + then (movitz-environment-uplink env) + for val = (when env + (gethash name (movitz-environment-compiler-macros env))) + while env + when val do (return val))) (defun (setf movitz-compiler-macro-function) (fun name &optional environment) - (setf (getf (movitz-environment-compiler-macros (or environment - *movitz-global-environment*)) - name) - fun)) + (setf (gethash name (movitz-environment-compiler-macros (or environment + *movitz-global-environment*))) + fun)) ;;; Special operators -(defparameter *persistent-movitz-environment* (make-global-movitz-environment)) +(defvar *persistent-movitz-environment* (make-global-movitz-environment)) (defun movitz-special-operator-p (symbol) (let ((val (gethash symbol (movitz-environment-function-cells *persistent-movitz-environment*))))

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4460 Modified Files: compiler.lisp Log Message: Smarten up make-compiled-two-forms-into-registers slightly, this speeds up the compiler. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/06 21:14:22 1.194 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/15 00:21:38 1.195 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.194 2008/03/06 21:14:22 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.195 2008/03/15 00:21:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5769,6 +5769,15 @@ (operands instruction) (values binding destination)))) +(defun program-is-load-constant (prg) + (and (not (cdr prg)) + (let ((i (car prg))) + (when (and (listp i) + (eq :load-constant (car i))) + (values (third i) + (second i)))))) + + (defun make-compiled-two-forms-into-registers (form0 reg0 form1 reg1 funobj env) "Returns first: code that does form0 into reg0, form1 into reg1. second: whether code is functional-p, @@ -5791,44 +5800,48 @@ :env env :result-mode reg1) (values (cond - ((and (typep final0 'binding) - (not (code-uses-binding-p code1 final0 :load nil :store t))) - (append (compiler-call #'compile-form-unprotected - :form form0 - :result-mode :ignore - :funobj funobj - :env env) - code1 - `((:load-lexical ,final0 ,reg0 :protect-registers (,reg1))))) - ((program-is-load-lexical-of-binding code1) - (destructuring-bind (src dst &key protect-registers shared-reference-p) - (cdar code1) - (assert (eq reg1 dst)) - (append code0 - `((:load-lexical ,src ,reg1 - :protect-registers ,(union protect-registers - (list reg0)) - :shared-reference-p ,shared-reference-p))))) - ;; XXX if we knew that code1 didn't mess up reg0, we could do more.. - (t #+ignore (when (and (not (tree-search code1 reg0)) - (not (tree-search code1 :call))) - (warn "got b: ~S ~S for ~S: ~{~&~A~}" form0 form1 reg0 code1)) - (let ((binding (make-instance 'temporary-name :name (gensym "tmp-"))) - (xenv (make-local-movitz-environment env funobj))) - (movitz-env-add-binding xenv binding) - (append (compiler-call #'compile-form - :form form0 - :funobj funobj - :env env - :result-mode reg0) - `((:init-lexvar ,binding :init-with-register ,reg0 - :init-with-type ,(type-specifier-primary type0))) - (compiler-call #'compile-form - :form form1 - :funobj funobj - :env xenv - :result-mode reg1) - `((:load-lexical ,binding ,reg0)))))) + ((and (typep final0 'binding) + (not (code-uses-binding-p code1 final0 :load nil :store t))) + (append (compiler-call #'compile-form-unprotected + :form form0 + :result-mode :ignore + :funobj funobj + :env env) + code1 + `((:load-lexical ,final0 ,reg0 :protect-registers (,reg1))))) + ((program-is-load-lexical-of-binding code1) + (destructuring-bind (src dst &key protect-registers shared-reference-p) + (cdar code1) + (assert (eq reg1 dst)) + (append code0 + `((:load-lexical ,src ,reg1 + :protect-registers ,(union protect-registers + (list reg0)) + :shared-reference-p ,shared-reference-p))))) + ((eq reg1 (program-is-load-constant code1)) + (append code0 + code1)) + ;; XXX if we knew that code1 didn't mess up reg0, we could do more.. + (t +;; (when (and (not (tree-search code1 reg0)) +;; (not (tree-search code1 :call))) +;; (warn "got b: ~S ~S for ~S: ~{~&~A~}" form0 form1 reg0 code1)) + (let ((binding (make-instance 'temporary-name :name (gensym "tmp-"))) + (xenv (make-local-movitz-environment env funobj))) + (movitz-env-add-binding xenv binding) + (append (compiler-call #'compile-form + :form form0 + :funobj funobj + :env env + :result-mode reg0) + `((:init-lexvar ,binding :init-with-register ,reg0 + :init-with-type ,(type-specifier-primary type0))) + (compiler-call #'compile-form + :form form1 + :funobj funobj + :env xenv + :result-mode reg1) + `((:load-lexical ,binding ,reg0)))))) (and functional0 functional1) t (compiler-values-list (all0))

1 0

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

14 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv26975 Modified Files: asm.lisp Log Message: Fix unused variable. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/03/06 19:18:51 1.17 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/03/14 11:07:47 1.18 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.17 2008/03/06 19:18:51 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.18 2008/03/14 11:07:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -289,7 +289,7 @@ symtab))))) `(quote ,(car entry))))))))))))) (values (loop for (pc data-instruction) on proglist0 by #'cddr - for (data . instruction) = data-instruction + for instruction = (cdr data-instruction) for label = (when collect-labels (rassoc pc symtab)) when label

1 0

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

08 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16390 Modified Files: more-macros.lisp Log Message: Don't forget &body also for d-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 13:59:48 1.38 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 14:03:35 1.39 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.38 2008/03/08 13:59:48 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.39 2008/03/08 14:03:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,7 +168,8 @@ bindings)) ((pop-match '&optional sub-lambda-list) (gen-optvars var sub-lambda-list)) - ((pop-match '&rest sub-lambda-list) + ((or (pop-match '&rest sub-lambda-list) + (pop-match '&body sub-lambda-list)) (gen-restvar var sub-lambda-list)) ((pop-match '&aux sub-lambda-list) (dolist (b sub-lambda-list) @@ -193,7 +194,8 @@ ((symbolp sub-lambda-list) ; dotted lambda-list? (push (list sub-lambda-list var) bindings)) - ((pop-match '&rest sub-lambda-list) + ((or (pop-match '&rest sub-lambda-list) + (pop-match '&body sub-lambda-list)) (gen-restvar var sub-lambda-list)) ((pop-match '&key sub-lambda-list) (gen-keyvars var sub-lambda-list))

1 0

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

08 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12745 Modified Files: more-macros.lisp Log Message: Add support for &aux in destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/07 23:38:21 1.37 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 13:59:48 1.38 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.37 2008/03/07 23:38:21 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.38 2008/03/08 13:59:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -170,6 +170,9 @@ (gen-optvars var sub-lambda-list)) ((pop-match '&rest sub-lambda-list) (gen-restvar var sub-lambda-list)) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))) ((consp (car sub-lambda-list)) ; recursive lambda-list? (let ((sub-var (gensym))) (push (list sub-var `(pop ,var)) @@ -194,6 +197,9 @@ (gen-restvar var sub-lambda-list)) ((pop-match '&key sub-lambda-list) (gen-keyvars var sub-lambda-list)) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))) (t (multiple-value-bind (opt-var init-form supplied-var) (let ((b (pop sub-lambda-list))) (if (atom b) @@ -212,8 +218,12 @@ (let ((rest-var (pop* sub-lambda-list))) (push (list rest-var var) bindings)) - (when (pop-match '&key sub-lambda-list) - (gen-keyvars var sub-lambda-list))) + (cond + ((pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list)) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))))) (gen-keyvars (var sub-lambda-list &optional keys) (cond ((endp sub-lambda-list) @@ -225,6 +235,9 @@ ((pop-match '&allow-other-keys sub-lambda-list) (when sub-lambda-list (error "Bad destructuring lambda-list; junk after ~S." '&allow-other-keys))) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))) (t (multiple-value-bind (key-var key-name init-form supplied-var) (let ((b (pop sub-lambda-list))) (cond

1 0

[movitz-cvs] CVS public_html
by ffjeld 07 Mar '08

07 Mar '08

Update of /project/movitz/cvsroot/public_html In directory clnet:/tmp/cvs-serv13870 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/movitz/cvsroot/public_html/ChangeLog 2008/02/25 20:19:23 1.12 +++ /project/movitz/cvsroot/public_html/ChangeLog 2008/03/07 23:39:33 1.13 @@ -1,3 +1,8 @@ +2008-03-08 Frode V. Fjeld <frodef(a)cs.uit.no> + + * movitz/losp/muerte/more-macros.lisp: Implemented macro + destructuring-bind. + 2008-02-25 Frode V. Fjeld <frodef(a)cs.uit.no> * movitz.asd: Created an ASDF system definition.

1 0

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

07 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13672 Modified Files: more-macros.lisp Log Message: Implement macro destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/06 20:31:23 1.36 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/07 23:38:21 1.37 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.36 2006/05/06 20:31:23 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.37 2008/03/07 23:38:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -130,6 +130,129 @@ (let ((,var (pop ,cons-var))) ,@declarations-and-body)))) + +(defmacro destructuring-bind (lambda-list expression &body declarations-and-body) + (let ((bindings (list (list (gensym) + expression))) + (ignores nil)) + (macrolet ((pop* (place) + "Like pop, but err if place is already NIL." + `(let ((x ,place)) + (assert x () "Syntax error in destructuring lambda-list: ~S" lambda-list) + (setf ,place (cdr x)) + (car x))) + (pop-match (item place) + "Pop place if (car place) is eq to item." + `(let ((item ,item) + (x ,place)) + (when (eq (car x) item) + (setf ,place (cdr x)) + (car x))))) + (labels + ((gen-end (var) + (let ((dummy-var (gensym))) + (push (list dummy-var (list 'when var '(error "Too many elements in expression for lambda-list."))) + bindings) + (push dummy-var ignores))) + (gen-lambda-list (var sub-lambda-list) + (when (pop-match '&whole sub-lambda-list) + (push (list (pop* sub-lambda-list) var) + bindings)) + (gen-reqvars var sub-lambda-list)) + (gen-reqvars (var sub-lambda-list) + (cond + ((null sub-lambda-list) + (gen-end var)) + ((symbolp sub-lambda-list) ; dotted lambda-list? + (push (list sub-lambda-list var) + bindings)) + ((pop-match '&optional sub-lambda-list) + (gen-optvars var sub-lambda-list)) + ((pop-match '&rest sub-lambda-list) + (gen-restvar var sub-lambda-list)) + ((consp (car sub-lambda-list)) ; recursive lambda-list? + (let ((sub-var (gensym))) + (push (list sub-var `(pop ,var)) + bindings) + (gen-lambda-list sub-var (pop sub-lambda-list))) + (gen-reqvars var sub-lambda-list)) + (t (push (let ((b (pop* sub-lambda-list))) + (list b + `(if (null ,var) + (error "Value for required argument ~S is missing." ',b) + (pop ,var)))) + bindings) + (gen-reqvars var sub-lambda-list)))) + (gen-optvars (var sub-lambda-list) + (cond + ((null sub-lambda-list) + (gen-end var)) + ((symbolp sub-lambda-list) ; dotted lambda-list? + (push (list sub-lambda-list var) + bindings)) + ((pop-match '&rest sub-lambda-list) + (gen-restvar var sub-lambda-list)) + ((pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list)) + (t (multiple-value-bind (opt-var init-form supplied-var) + (let ((b (pop sub-lambda-list))) + (if (atom b) + (values b nil nil) + (values (pop b) (pop b) (pop b)))) + (when supplied-var + (push (list supplied-var `(if ,var t nil)) + bindings)) + (push (list opt-var + (if (not init-form) + `(pop ,var) + `(if ,var (pop ,var) ,init-form))) + bindings)) + (gen-optvars var sub-lambda-list)))) + (gen-restvar (var sub-lambda-list) + (let ((rest-var (pop* sub-lambda-list))) + (push (list rest-var var) + bindings)) + (when (pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list))) + (gen-keyvars (var sub-lambda-list &optional keys) + (cond + ((endp sub-lambda-list) + (push (list (gensym) + `(d-bind-veryfy-keys ,var ',keys)) + bindings) + (push (caar bindings) + ignores)) + ((pop-match '&allow-other-keys sub-lambda-list) + (when sub-lambda-list + (error "Bad destructuring lambda-list; junk after ~S." '&allow-other-keys))) + (t (multiple-value-bind (key-var key-name init-form supplied-var) + (let ((b (pop sub-lambda-list))) + (cond + ((atom b) + (values b (intern (string b) :keyword) nil nil)) + ((atom (car b)) + (values (car b) (intern (string (car b)) :keyword) nil nil)) + (t (let ((bn (pop b))) + (values (cadr bn) (car bn) (pop b) (pop b)))))) + (when supplied-var + (push supplied-var bindings)) + (push (list key-var + `(let ((x (d-bind-lookup-key ',key-name ,var))) + ,@(when supplied-var + `((setf ,supplied-var (if x t nil)))) + ,(if (not init-form) + '(car x) + (if x + (car x) + ,init-form)))) + bindings) + (gen-keyvars var sub-lambda-list (cons key-name keys))))))) + (gen-lambda-list (caar bindings) + lambda-list) + `(let* ,(nreverse bindings) + (declare (ignore ,@ignores)) + ,@declarations-and-body))))) + (define-compiler-macro member (&whole form item list &key (key ''identity) (test ''eql) &environment env) (let* ((test (or (and (movitz:movitz-constantp test env)

1 0

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

07 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13658 Modified Files: basic-functions.lisp Log Message: Implement macro destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2007/02/19 20:24:51 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/03/07 23:38:19 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.22 2007/02/19 20:24:51 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.23 2008/03/07 23:38:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -48,6 +48,33 @@ (:movl :ecx :eax))) +(defun d-bind-veryfy-keys (args keys) + (do ((allow-allow-p t) + (mismatches nil)) + ((null args) + (when mismatches + (error "Unexpected destructuring keys ~{~S~^, ~}, expected ~{~S~^, ~}." + mismatches keys))) + (let ((a (pop args)) + (v (pop args))) + (cond + ((eq a :allow-other-keys) + (when (and v allow-allow-p) + (return)) + (setf allow-allow-p nil)) + ((not (member a keys)) + (pushnew a mismatches)))))) + +(defun d-bind-lookup-key (key list) + (do () + ((endp list) + nil) + (unless (cdr list) + (error "Odd number of keyword arguments.")) + (when (eq key (pop list)) + (return list)) + (setf list (cdr list)))) + (defmacro numargs () `(with-inline-assembly (:returns :ecx) (:movzxb :cl :ecx)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs March 2008