From dba261e1d6284d1ccd0aa9cf42d52ba5ba5994e4 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Thu, 28 Aug 2003 14:14:57 +0000
Subject: [PATCH] 	(loop for i in '(4 8 9 a 13) 	      when (eq i 'a)
 return :good 	      while (< i 12) collect i)

	signaling a type-error because the while is done before the when.
	Found by Paul Dietz.

	* src/code/loop.lisp (loop-do-if): Move the call to loop-pseudo-body
	outside of the binding of *loop-inside-conditional*.
---
 code/loop.lisp | 81 +++++++++++++++++++++++++-------------------------
 1 file changed, 41 insertions(+), 40 deletions(-)

diff --git a/code/loop.lisp b/code/loop.lisp
index 71797fd84..2d9a399ff 100644
--- a/code/loop.lisp
+++ b/code/loop.lisp
@@ -49,7 +49,7 @@
 
 #+cmu
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/loop.lisp,v 1.22 2003/05/28 09:22:41 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/loop.lisp,v 1.23 2003/08/28 14:14:57 gerd Exp $")
 
 ;;;; LOOP Iteration Macro
 
@@ -1287,46 +1287,47 @@ collected result will be returned as the value of the LOOP."
 
 (defun loop-do-if (for negatep)
   (let ((form (loop-get-form))
-	(*loop-inside-conditional* t)
 	(it-p nil)
-	(first-clause-p t))
-    (flet ((get-clause (for)
-	     (do ((body nil)) (nil)
-	       (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
-		 (cond ((not (symbolp key))
-			(loop-error
-			  "~S found where keyword expected getting LOOP clause after ~S."
-			  key for))
-		       (t (setq *loop-source-context* *loop-source-code*)
-			  (loop-pop-source)
-			  (when (and (loop-tequal (car *loop-source-code*) 'it)
-				     first-clause-p)
-			    (setq *loop-source-code*
-				  (cons (or it-p (setq it-p (loop-when-it-variable)))
-					(cdr *loop-source-code*))))
-			  (cond ((or (not (setq data (loop-lookup-keyword
-						       key (loop-universe-keywords *loop-universe*))))
-				     (progn (apply (symbol-function (car data)) (cdr data))
-					    (null *loop-body*)))
-				 (loop-error
-				   "~S does not introduce a LOOP clause that can follow ~S."
-				   key for))
-				(t (setq body (nreconc *loop-body* body)))))))
-	       (setq first-clause-p nil)
-	       (if (loop-tequal (car *loop-source-code*) :and)
-		   (loop-pop-source)
-		   (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
-      (let ((then (get-clause for))
-	    (else (when (loop-tequal (car *loop-source-code*) :else)
-		    (loop-pop-source)
-		    (list (get-clause :else)))))
-	(when (loop-tequal (car *loop-source-code*) :end)
-	  (loop-pop-source))
-	(when it-p (setq form `(setq ,it-p ,form)))
-	(loop-pseudo-body
-	  `(if ,(if negatep `(not ,form) form)
-	       ,then
-	       ,@else))))))
+	(first-clause-p t) then else)
+    (let ((*loop-inside-conditional* t))
+      (flet ((get-clause (for)
+	       (do ((body nil)) (nil)
+		 (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
+		   (cond ((not (symbolp key))
+			  (loop-error
+			     "~S found where keyword expected getting LOOP clause after ~S."
+			     key for))
+			 (t (setq *loop-source-context* *loop-source-code*)
+			    (loop-pop-source)
+			    (when (and (loop-tequal (car *loop-source-code*) 'it)
+				       first-clause-p)
+			      (setq *loop-source-code*
+				    (cons (or it-p (setq it-p (loop-when-it-variable)))
+					  (cdr *loop-source-code*))))
+			    (cond ((or (not (setq data (loop-lookup-keyword
+							     key (loop-universe-keywords *loop-universe*))))
+				       (progn (apply (symbol-function (car data)) (cdr data))
+					      (null *loop-body*)))
+				   (loop-error
+				      "~S does not introduce a LOOP clause that can follow ~S."
+				      key for))
+				  (t (setq body (nreconc *loop-body* body)))))))
+		 (setq first-clause-p nil)
+		 (if (loop-tequal (car *loop-source-code*) :and)
+		     (loop-pop-source)
+		     (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
+	(setq then (get-clause for))
+	(setq else (when (loop-tequal (car *loop-source-code*) :else)
+		     (loop-pop-source)
+		     (list (get-clause :else)))))
+      (when (loop-tequal (car *loop-source-code*) :end)
+	(loop-pop-source))
+      (when it-p
+	(setq form `(setq ,it-p ,form))))
+    (loop-pseudo-body
+       `(if ,(if negatep `(not ,form) form)
+	    ,then
+	    ,@else))))
 
 
 (defun loop-do-initially ()
-- 
GitLab