[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

Modified Files:
	loop.lisp 
Log Message:
Get loop working in run-time.


--- /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp	2008/04/17 19:30:43	1.9
+++ /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp	2008/04/27 19:41:42	1.10
@@ -66,17 +66,17 @@
 
 (provide :muerte/loop :load-priority 1)
 
-#+movitz
-(progn
-  (defmacro movitz-macroexpand (&rest args)
-    `(macroexpand , at args))
-  (defmacro movitz-macroexpand-1 (&rest args)
-    `(macroexpand-1 , at args))
-  (eval-when (:compile-toplevel)
-    (defmacro movitz-macroexpand (&rest args)
-      `(movitz::movitz-macroexpand , at args))
-    (defmacro movitz-macroexpand-1 (&rest args)
-      `(movitz::movitz-macroexpand-1 , at args))))
+;; #+movitz
+;; (progn
+;;   (defmacro movitz-macroexpand (&rest args)
+;;     `(macroexpand , at args))
+;;   (defmacro movitz-macroexpand-1 (&rest args)
+;;     `(macroexpand-1 , at args))
+;;   (eval-when (:compile-toplevel)
+;;     (defmacro movitz-macroexpand (&rest args)
+;;       `(movitz::movitz-macroexpand , at args))
+;;     (defmacro movitz-macroexpand-1 (&rest args)
+;;       `(movitz::movitz-macroexpand-1 , at args))))
 
 ;;;This is the "current" loop context in use when we are expanding a
 ;;;loop.  It gets bound on each invocation of LOOP.
@@ -271,48 +271,48 @@
 			       (head-var tail-var &optional user-head-var) form)
   (declare
     #+LISPM (ignore head-var user-head-var))	;use locatives, unconditionally update through the tail.
-  (setq form (movitz-macroexpand form env))
-  (flet ((cdr-wrap (form n)
-	   (declare (fixnum n))
-	   (do () ((<= n 4) (setq form `(,(case n
-					    (1 'cdr)
-					    (2 'cddr)
-					    (3 'cdddr)
-					    (4 'cddddr))
-					 ,form)))
-	     (setq form `(cddddr ,form) n (- n 4)))))
-    (let ((tail-form form) (ncdrs nil))
-      ;;Determine if the form being constructed is a list of known length.
-      (when (consp form)
-	(cond ((eq (car form) 'list)
-	       (setq ncdrs (1- (length (cdr form))))
-	       ;;@@@@ Because the last element is going to be RPLACDed,
-	       ;; we don't want the cdr-coded implementations to use
-	       ;; cdr-nil at the end (which would just force copying
-	       ;; the whole list again).
-	       #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
-	      ((member (car form) '(list* cons))
-	       (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
-		 (setq ncdrs (- (length (cdr form)) 2))))))
-      (let ((answer
-	      (cond ((null ncdrs)
-		     `(when (setf (cdr ,tail-var) ,tail-form)
-			(setq ,tail-var (last (cdr ,tail-var)))))
-		    ((< ncdrs 0) (return-from loop-collect-rplacd nil))
-		    ((= ncdrs 0)
-		     ;;@@@@ Here we have a choice of two idioms:
-		     ;; (rplacd tail (setq tail tail-form))
-		     ;; (setq tail (setf (cdr tail) tail-form)).
-		     ;;Genera and most others I have seen do better with the former.
-		     `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
-		    (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
-						   ncdrs))))))
-	;;If not using locatives or something similar to update the user's
-	;; head variable, we've got to set it...  It's harmless to repeatedly set it
-	;; unconditionally, and probably faster than checking.
-	#-LISPM (when user-head-var
-		  (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
-	answer))))
+  (let ((form (movitz-macroexpand form env)))
+    (flet ((cdr-wrap (form n)
+	     (declare (fixnum n))
+	     (do () ((<= n 4) (setq form `(,(case n
+						  (1 'cdr)
+						  (2 'cddr)
+						  (3 'cdddr)
+						  (4 'cddddr))
+					    ,form)))
+	       (setq form `(cddddr ,form) n (- n 4)))))
+      (let ((tail-form form) (ncdrs nil))
+	;;Determine if the form being constructed is a list of known length.
+	(when (consp form)
+	  (cond ((eq (car form) 'list)
+		 (setq ncdrs (1- (length (cdr form))))
+		 ;;@@@@ Because the last element is going to be RPLACDed,
+		 ;; we don't want the cdr-coded implementations to use
+		 ;; cdr-nil at the end (which would just force copying
+		 ;; the whole list again).
+		 #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
+		((member (car form) '(list* cons))
+		 (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
+		   (setq ncdrs (- (length (cdr form)) 2))))))
+	(let ((answer
+	       (cond ((null ncdrs)
+		      `(when (setf (cdr ,tail-var) ,tail-form)
+			 (setq ,tail-var (last (cdr ,tail-var)))))
+		     ((< ncdrs 0) (return-from loop-collect-rplacd nil))
+		     ((= ncdrs 0)
+		      ;;@@@@ Here we have a choice of two idioms:
+		      ;; (rplacd tail (setq tail tail-form))
+		      ;; (setq tail (setf (cdr tail) tail-form)).
+		      ;;Genera and most others I have seen do better with the former.
+		      `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
+		     (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
+						    ncdrs))))))
+	  ;;If not using locatives or something similar to update the user's
+	  ;; head variable, we've got to set it...  It's harmless to repeatedly set it
+	  ;; unconditionally, and probably faster than checking.
+	  #-LISPM (when user-head-var
+		    (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
+	  answer)))))
 
 
 (defmacro loop-collect-answer (head-var &optional user-head-var)