0.7.9.65:

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

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 59504a9..a1cec36 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -760,9 +760,27 @@ code to be loaded.
                           specified-type required-type)))
        specified-type)))
 \f
+(defun subst-gensyms-for-nil (tree)
+  (declare (special *ignores*))
+  (cond
+    ((null tree) (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*)))
+    ((atom tree) tree)
+    (t (cons (subst-gensyms-for-nil (car tree))
+            (subst-gensyms-for-nil (cdr tree))))))
+    
+(sb!int:defmacro-mundanely loop-destructuring-bind
+    (lambda-list arg-list &rest body)
+  (let ((*ignores* nil))
+    (declare (special *ignores*))
+    (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list)))
+      `(destructuring-bind ,d-var-lambda-list
+          ,arg-list
+        (declare (ignore ,@*ignores*))
+         ,@body))))
+
 (defun loop-build-destructuring-bindings (crocks forms)
   (if crocks
-      `((destructuring-bind ,(car crocks) ,(cadr crocks)
+      `((loop-destructuring-bind ,(car crocks) ,(cadr crocks)
         ,@(loop-build-destructuring-bindings (cddr crocks) forms)))
       forms))
 
@@ -1110,7 +1128,7 @@ code to be loaded.
     (when *loop-names*
       (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
                  (car *loop-names*) name))
-    (setq *loop-names* (list name nil))))
+    (setq *loop-names* (list name))))
 
 (defun loop-do-return ()
   (loop-pseudo-body (loop-construct-return (loop-get-form))))
@@ -1247,6 +1265,22 @@ code to be loaded.
   (loop-disallow-conditional kwd)
   (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
 
+(defun loop-do-repeat ()
+  (loop-disallow-conditional :repeat)
+  (let ((form (loop-get-form))
+       (type 'real))
+    (let ((var (loop-make-var (gensym "LOOP-REPEAT-") form type)))
+      (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*)
+      (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*)
+      ;; FIXME: What should
+      ;;   (loop count t into a
+      ;;         repeat 3
+      ;;         count t into b
+      ;;         finally (return (list a b)))
+      ;; return: (3 3) or (4 3)? PUSHes above are for the former
+      ;; variant, L-P-B below for the latter.
+      #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop))))))
+
 (defun loop-do-with ()
   (loop-disallow-conditional :with)
   (do ((var) (val) (dtype)) (nil)
@@ -1348,24 +1382,6 @@ code to be loaded.
                  keyword))
     (apply (car tem) var first-arg data-type (cdr tem))))
 
-(defun loop-do-repeat ()
-  (let ((form (loop-get-form))
-       (type (loop-check-data-type (loop-optional-type)
-                                   'real)))
-    (when (and (consp form)
-              (eq (car form) 'the)
-              (sb!xc:subtypep (second form) type))
-      (setq type (second form)))
-    (multiple-value-bind (number constantp value)
-       (loop-constant-fold-if-possible form type)
-      (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
-           (t (let ((var (loop-make-var (gensym "LOOP-REPEAT-") number type)))
-                (if constantp
-                    `((not (plusp (setq ,var (1- ,var))))
-                      () () () () () () ())
-                    `((minusp (setq ,var (1- ,var)))
-                      () () ()))))))))
-
 (defun loop-when-it-var ()
   (or *loop-when-it-var*
       (setq *loop-when-it-var*
@@ -1883,7 +1899,8 @@ code to be loaded.
                         (when (loop-do-if when nil))   ; Normal, do when
                         (if (loop-do-if if nil))       ; synonymous
                         (unless (loop-do-if unless t)) ; Negate test on when
-                        (with (loop-do-with)))
+                        (with (loop-do-with))
+                         (repeat (loop-do-repeat)))
             :for-keywords '((= (loop-ansi-for-equals))
                             (across (loop-for-across))
                             (in (loop-for-in))
@@ -1899,8 +1916,7 @@ code to be loaded.
                             (by (loop-for-arithmetic :by))
                             (being (loop-for-being)))
             :iteration-keywords '((for (loop-do-for))
-                                  (as (loop-do-for))
-                                  (repeat (loop-do-repeat)))
+                                  (as (loop-do-for)))
             :type-symbols '(array atom bignum bit bit-vector character
                             compiled-function complex cons double-float
                             fixnum float function hash-table integer
@@ -1944,9 +1960,9 @@ code to be loaded.
 
 (defun loop-standard-expansion (keywords-and-forms environment universe)
   (if (and keywords-and-forms (symbolp (car keywords-and-forms)))
-    (loop-translate keywords-and-forms environment universe)
-    (let ((tag (gensym)))
-      `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
+      (loop-translate keywords-and-forms environment universe)
+      (let ((tag (gensym)))
+       `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
 
 (sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
   (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))