[movitz-cvs] CVS movitz/losp/muerte

Sat Mar 15 20:58:07 UTC 2008

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv3408

Modified Files:
	more-macros.lisp 
Log Message:
Have macros in the run-time.

--- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2008/03/08 14:03:35	1.39
+++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2008/03/15 20:58:06	1.40
@@ -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.39 2008/03/08 14:03:35 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.40 2008/03/15 20:58:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -171,6 +171,8 @@
 	       ((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))
 	       ((pop-match '&aux sub-lambda-list)
 		(dolist (b sub-lambda-list)
 		  (push b bindings)))
@@ -294,47 +296,6 @@
 	   (return p))))
      (t form))))
 
-(defmacro letf* (bindings &body body &environment env)
-  "Does what one might expect, saving the old values and setting the generalized
-  variables to the new values in sequence.  Unwind-protects and get-setf-method
-  are used to preserve the semantics one might expect in analogy to let*,
-  and the once-only evaluation of subforms."
-  (labels ((do-bindings
-            (bindings)
-            (cond ((null bindings) body)
-                  (t (multiple-value-bind (dummies vals newval setter getter)
-			 (get-setf-expansion (caar bindings) env)
-                       (let ((save (gensym)))
-                         `((let* (,@(mapcar #'list dummies vals)
-                                  (,(car newval) ,(cadar bindings))
-                                  (,save ,getter))
-                             (unwind-protect
-                               (progn ,setter
-                                      ,@(do-bindings (cdr bindings)))
-                               (setq ,(car newval) ,save)
-                               ,setter)))))))))
-    (car (do-bindings bindings))))
-
-(defmacro with-letf (clauses &body body)
-  "Each clause is (<place> &optional <value-form> <prev-var>).
-Execute <body> with alternative values for each <place>.
-Note that this scheme does not work well with respect to multiple threads.
-XXX This should actually be using get-setf-expansion etc. to deal with
-proper evaluation of the places' subforms."
-  (let ((place-value-save (loop for (place . value-save) in clauses
-			      if value-save
-			      collect (list place `(progn ,(first value-save))
-					    (or (second value-save) (gensym)))
-			      else collect (list place nil (gensym)))))
-    `(let (,@(loop for (place nil save-var) in place-value-save
-		 collect `(,save-var ,place)))
-       (unwind-protect
-	   (progn (setf ,@(loop for (place value) in place-value-save
-			      append `(,place ,value)))
-		  , at body)
-	 (setf ,@(loop for (place nil save) in place-value-save
-		     append `(,place ,save)))))))
-
 (defmacro with-alternative-fdefinitions (clauses &body body)
   "Each clause is (<name> <definition>). Execute <body> with alternative
 fdefinitions for each <name>. Note that this scheme does not work well with


