0.7.10.1:

	Fix yet another LOOP bug
	... disallow aggregate booleans with anonymous collectors
	... and the converse :-)

diff --git a/NEWS b/NEWS
index 5a97db5..19c6806 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1431,6 +1431,12 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9:
   * incremented fasl file version number, because of the
     SXHASH-related changes in the layout of CLOS data structures
 
+changes in sbcl-0.7.11 relative to sbcl-0.7.10:
+  * fixed some bugs shown by Paul Dietz' test suite:
+    ** As required by ANSI, LOOP now disallows anonymous collection
+       clauses such as COLLECT I in conjunction with aggregate boolean
+       clauses such as THEREIS (= I 1);
+
 planned incompatible changes in 0.7.x:
   * (not done yet, but planned:) When the profiling interface settles
     down, maybe in 0.7.x, maybe later, it might impact TRACE. They both

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index a1cec36..18f08ac 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -901,17 +901,26 @@ code to be loaded.
   (setq *loop-emitted-body* t)
   (loop-pseudo-body form))
 
-(defun loop-emit-final-value (form)
-  (push (loop-construct-return form) *loop-after-epilogue*)
+(defun loop-emit-final-value (&optional (form nil form-supplied-p))
+  (when form-supplied-p
+    (push (loop-construct-return form) *loop-after-epilogue*))
   (when *loop-final-value-culprit*
-    (loop-warn "The LOOP clause is providing a value for the iteration,~@
-               however one was already established by a ~S clause."
+    (loop-warn "The LOOP clause is providing a value for the iteration;~@
+               however, one was already established by a ~S clause."
               *loop-final-value-culprit*))
   (setq *loop-final-value-culprit* (car *loop-source-context*)))
 
 (defun loop-disallow-conditional (&optional kwd)
   (when *loop-inside-conditional*
     (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
+
+(defun loop-disallow-anonymous-collectors ()
+  (when (find-if-not 'loop-collector-name *loop-collection-cruft*)
+    (loop-error "This LOOP clause is not permitted with anonymous collectors.")))
+
+(defun loop-disallow-aggregate-booleans ()
+  (when (loop-tmember *loop-final-value-culprit* '(always never thereis))
+    (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans.")))
 \f
 ;;;; loop types
 
@@ -1153,6 +1162,8 @@ code to be loaded.
                (loop-pop-source))))
     (when (not (symbolp name))
       (loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
+    (unless name
+      (loop-disallow-aggregate-booleans))
     (unless dtype
       (setq dtype (or (loop-optional-type) default-type)))
     (let ((cruft (find (the symbol name) *loop-collection-cruft*
@@ -1249,6 +1260,7 @@ code to be loaded.
 (defun loop-do-always (restrictive negate)
   (let ((form (loop-get-form)))
     (when restrictive (loop-disallow-conditional))
+    (loop-disallow-anonymous-collectors)
     (loop-emit-body `(,(if negate 'when 'unless) ,form
                      ,(loop-construct-return nil)))
     (loop-emit-final-value t)))
@@ -1258,8 +1270,10 @@ code to be loaded.
 ;;; Under ANSI this is not permitted to appear under conditionalization.
 (defun loop-do-thereis (restrictive)
   (when restrictive (loop-disallow-conditional))
+  (loop-disallow-anonymous-collectors)
+  (loop-emit-final-value)
   (loop-emit-body `(when (setq ,(loop-when-it-var) ,(loop-get-form))
-                    ,(loop-construct-return *loop-when-it-var*))))
+                   ,(loop-construct-return *loop-when-it-var*))))
 \f
 (defun loop-do-while (negate kwd &aux (form (loop-get-form)))
   (loop-disallow-conditional kwd)

diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp
index 067f7ef..7e6d4ce 100644 (file)
--- a/tests/loop.pure.lisp
+++ b/tests/loop.pure.lisp
@@ -115,3 +115,35 @@
 (assert (= (loop with (nil a) = '(1 2) return a) 2))
 (assert (= (loop with (a . nil) = '(1 2) return a) 1))
 (assert (equal (loop with (nil . a) = '(1 2) return a) '(2)))
+
+(multiple-value-bind (result error)
+    (ignore-errors
+      (loop for i in '(1 2 3) collect i always (< i 4)))
+  (assert (null result))
+  (assert (typep error 'program-error)))
+(assert (equal
+        (loop for i in '(1 2 3) collect i into foo always (< i 4)
+              finally (return foo))
+        '(1 2 3)))
+(assert (equal
+        (loop for i in '(1 2 3) collect i into foo always (= i 4)
+              finally (return foo))
+        nil))
+(multiple-value-bind (result error)
+    (ignore-errors
+      (loop for i in '(1 2 3) always (< i 4) collect i))
+  (assert (null result))
+  (assert (typep error 'program-error)))
+(assert (equal
+        (loop for i in '(1 2 3) always (< i 4) collect i into foo
+              finally (return foo))
+        '(1 2 3)))
+(assert (equal
+        (loop for i in '(1 2 3) always (= i 4) collect i into foo
+              finally (return foo))
+        nil))
+(multiple-value-bind (result error)
+    (ignore-errors
+      (loop for i in '(1 2 3) thereis (= i 3) collect i))
+  (assert (null result))
+  (assert (typep error 'program-error)))
\ No newline at end of file

diff --git a/version.lisp-expr b/version.lisp-expr
index 773ac9d..6f57564 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.10"
+"0.7.10.1"