[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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 at 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)))
 	 , at 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 , at ignores))
+	   , at 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)