0.7.9.52:

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

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index d003809..d6e83a9 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -326,7 +326,7 @@ code to be loaded.
                            (setf (gethash (car x) ht) (cadr x))))
                      ht))))
 \f
-;;;; SETQ hackery
+;;;; SETQ hackery, including destructuring ("DESETQ")
 
 (defun loop-make-psetq (frobs)
   (and frobs
@@ -345,10 +345,10 @@ code to be loaded.
        (make-symbol "LOOP-DESETQ-TEMP"))
 
 (sb!int:defmacro-mundanely loop-really-desetq (&environment env
-                                                 &rest var-val-pairs)
+                                              &rest var-val-pairs)
   (labels ((find-non-null (var)
-            ;; see whether there's any non-null thing here
-            ;; recurse if the list element is itself a list
+            ;; See whether there's any non-null thing here. Recurse
+            ;; if the list element is itself a list.
             (do ((tail var)) ((not (consp tail)) tail)
               (when (find-non-null (pop tail)) (return t))))
           (loop-desetq-internal (var val &optional temp)
@@ -356,10 +356,10 @@ code to be loaded.
             (typecase var
               (null
                 (when (consp val)
-                  ;; Don't lose possible side-effects.
+                  ;; Don't lose possible side effects.
                   (if (eq (car val) 'prog1)
-                      ;; These can come from psetq or desetq below.
-                      ;; Throw away the value, keep the side-effects.
+                      ;; These can come from PSETQ or DESETQ below.
+                      ;; Throw away the value, keep the side effects.
                       ;; Special case is for handling an expanded POP.
                       (mapcan (lambda (x)
                                 (and (consp x)
@@ -390,7 +390,7 @@ code to be loaded.
                                 ,@body)
                               `((let ((,temp ,val))
                                   ,@body))))
-                        ;; no cdring to do
+                        ;; no CDRing to do
                         (loop-desetq-internal car `(car ,val) temp)))))
               (otherwise
                 (unless (eq var val)
@@ -737,10 +737,9 @@ code to be loaded.
       ((eq l (cdr *loop-source-code*)) (nreverse new))))
 
 (defun loop-error (format-string &rest format-args)
-  (error "~?~%current LOOP context:~{ ~S~}."
-        format-string
-        format-args
-        (loop-context)))
+  (error 'sb!int:simple-program-error
+        :format-control "~?~%current LOOP context:~{ ~S~}."
+        :format-arguments (list format-string format-args (loop-context))))
 
 (defun loop-warn (format-string &rest format-args)
   (warn "~?~%current LOOP context:~{ ~S~}."
@@ -1615,12 +1614,6 @@ code to be loaded.
            ((and using-allowed (loop-tequal token 'using))
             (loop-pop-source)
             (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
-              (when (or (atom z)
-                        (atom (cdr z))
-                        (not (null (cddr z)))
-                        (not (symbolp (car z)))
-                        (and (cadr z) (not (symbolp (cadr z)))))
-                (loop-error "~S bad variable pair in path USING phrase" z))
               (when (cadr z)
                 (if (setq tem (loop-tassoc (car z) *loop-named-vars*))
                     (loop-error
@@ -1760,7 +1753,7 @@ code to be loaded.
                                    sequence-type
                                    element-type)
   (multiple-value-bind (indexv) (loop-named-var 'index)
-    (let ((sequencev (named-var 'sequence)))
+    (let ((sequencev (loop-named-var 'sequence)))
       (list* nil nil                           ; dummy bindings and prologue
             (loop-sequencer
              indexv 'fixnum 
@@ -1780,7 +1773,7 @@ code to be loaded.
 ||#
 
 (defun loop-hash-table-iteration-path (variable data-type prep-phrases
-                                      &key (which (missing-arg)))
+                                      &key (which (sb!int:missing-arg)))
   (declare (type (member :hash-key :hash-value) which))
   (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
         (loop-error "too many prepositions!"))
@@ -1801,11 +1794,12 @@ code to be loaded.
       ;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists.
       (setq other-p t
            dummy-predicate-var (loop-when-it-var))
-      (let ((key-var nil)
-           (val-var nil)
-           (bindings `((,variable nil ,data-type)
-                       (,ht-var ,(cadar prep-phrases))
-                       ,@(and other-p other-var `((,other-var nil))))))
+      (let* ((key-var nil)
+            (val-var nil)
+            (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-")))
+            (bindings `((,variable nil ,data-type)
+                        (,ht-var ,(cadar prep-phrases))
+                        ,@(and other-p other-var `((,other-var nil))))))
        (ecase which
          (:hash-key (setq key-var variable
                           val-var (and other-p other-var)))
@@ -1832,17 +1826,19 @@ code to be loaded.
 
 (defun loop-package-symbols-iteration-path (variable data-type prep-phrases
                                            &key symbol-types)
-  (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
+  (cond ((and prep-phrases (cdr prep-phrases))
         (loop-error "Too many prepositions!"))
-       ((null prep-phrases)
-        (loop-error "missing OF or IN in ~S iteration path")))
+        ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
+         (sb!int:bug "Unknown preposition ~S." (caar prep-phrases))))
   (unless (symbolp variable)
     (loop-error "Destructuring is not valid for package symbol iteration."))
   (let ((pkg-var (gensym "LOOP-PKGSYM-"))
-       (next-fn (gensym "LOOP-PKGSYM-NEXT-")))
+       (next-fn (gensym "LOOP-PKGSYM-NEXT-"))
+       (variable (or variable (gensym "LOOP-PKGSYM-VAR-")))
+        (package (or (cadar prep-phrases) '*package*)))
     (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types))
          *loop-wrappers*)
-    `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases)))
+    `(((,variable nil ,data-type) (,pkg-var ,package))
       ()
       ()
       ()
@@ -1896,8 +1892,10 @@ code to be loaded.
                             (downfrom (loop-for-arithmetic :downfrom))
                             (upfrom (loop-for-arithmetic :upfrom))
                             (below (loop-for-arithmetic :below))
+                             (above (loop-for-arithmetic :above))
                             (to (loop-for-arithmetic :to))
                             (upto (loop-for-arithmetic :upto))
+                            (downto (loop-for-arithmetic :downto))
                             (by (loop-for-arithmetic :by))
                             (being (loop-for-being)))
             :iteration-keywords '((for (loop-do-for))