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@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)