0.7.10.15:

[sbcl.git] / src / code / loop.lisp

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index a1cec36..23d714e 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
 
@@ -1004,6 +1013,13 @@ code to be loaded.
          *loop-desetq-crocks* nil
          *loop-wrappers* nil)))
 
+(defun loop-var-p (name)
+  (do ((entry *loop-bind-stack* (cdr entry)))
+      (nil)
+    (cond
+      ((null entry) (return nil))
+      ((assoc name (caar entry) :test #'eq) (return t)))))
+
 (defun loop-make-var (name initialization dtype &optional iteration-var-p)
   (cond ((null name)
         (cond ((not (null initialization))
@@ -1066,7 +1082,10 @@ code to be loaded.
       (loop-make-var (gensym "LOOP-BIND-") form data-type)))
 \f
 (defun loop-do-if (for negatep)
-  (let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil))
+  (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)
@@ -1076,7 +1095,8 @@ code to be loaded.
                          key for))
                       (t (setq *loop-source-context* *loop-source-code*)
                          (loop-pop-source)
-                         (when (loop-tequal (car *loop-source-code*) 'it)
+                         (when (and (loop-tequal (car *loop-source-code*) 'it)
+                                    first-clause-p)
                            (setq *loop-source-code*
                                  (cons (or it-p
                                            (setq it-p
@@ -1091,6 +1111,7 @@ code to be loaded.
                                   "~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)
@@ -1153,11 +1174,15 @@ 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*
                       :key #'loop-collector-name)))
       (cond ((not cruft)
+            (when (and name (loop-var-p name))
+              (loop-error "Variable ~S in INTO clause is a duplicate" name))
             (push (setq cruft (make-loop-collector
                                 :name name :class class
                                 :history (list collector) :dtype dtype))
@@ -1249,6 +1274,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 +1284,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)
@@ -1290,6 +1318,8 @@ code to be loaded.
                     (loop-pop-source)
                     (loop-get-form))
                    (t nil)))
+    (when (and var (loop-var-p var))
+      (loop-error "Variable ~S has already been used" var))
     (loop-make-var var val dtype)
     (if (loop-tequal (car *loop-source-code*) :and)
        (loop-pop-source)