0.pre7.86.flaky7.22:

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

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index ff657b4..b3a79ae 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -328,12 +328,6 @@ code to be loaded.
 \f
 ;;;; SETQ hackery
 
 \f
 ;;;; SETQ hackery
 

-(defvar *loop-destructuring-hooks*
-       nil
-  #!+sb-doc
-  "If not NIL, this must be a list of two things:
-a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.")
-

 (defun loop-make-psetq (frobs)
   (and frobs
        (loop-make-desetq
 (defun loop-make-psetq (frobs)
   (and frobs
        (loop-make-desetq

@@ -345,10 +339,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 (defun loop-make-desetq (var-val-pairs)
   (if (null var-val-pairs)
       nil
 (defun loop-make-desetq (var-val-pairs)
   (if (null var-val-pairs)
       nil

-      (cons (if *loop-destructuring-hooks*
-               (cadr *loop-destructuring-hooks*)
-               'loop-really-desetq)
-           var-val-pairs)))
+      (cons 'loop-really-desetq var-val-pairs)))

 
 (defvar *loop-desetq-temporary*
        (make-symbol "LOOP-DESETQ-TEMP"))
 
 (defvar *loop-desetq-temporary*
        (make-symbol "LOOP-DESETQ-TEMP"))

@@ -824,11 +815,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
            (let ((forms (list answer)))
              ;;(when crocks (push crocks forms))
              (when dcls (push `(declare ,@dcls) forms))
            (let ((forms (list answer)))
              ;;(when crocks (push crocks forms))
              (when dcls (push `(declare ,@dcls) forms))

-             (setq answer `(,(cond ((not vars) 'locally)
-                                   (*loop-destructuring-hooks*
-                                    (first *loop-destructuring-hooks*))
-                                   (t
-                                    'let))
+             (setq answer `(,(if vars 'let 'locally)

                             ,vars
                             ,@(loop-build-destructuring-bindings crocks
                                                                  forms)))))))
                             ,vars
                             ,@(loop-build-destructuring-bindings crocks
                                                                  forms)))))))

@@ -866,17 +853,25 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
       (pop *loop-source-code*)
       (loop-error "LOOP source code ran out when another token was expected.")))
 
       (pop *loop-source-code*)
       (loop-error "LOOP source code ran out when another token was expected.")))
 

-(defun loop-get-progn ()
-  (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms))
-       (nextform (car *loop-source-code*) (car *loop-source-code*)))
-      ((atom nextform)
-       (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms))))))
-

 (defun loop-get-form ()
   (if *loop-source-code*
       (loop-pop-source)
       (loop-error "LOOP code ran out where a form was expected.")))
 
 (defun loop-get-form ()
   (if *loop-source-code*
       (loop-pop-source)
       (loop-error "LOOP code ran out where a form was expected.")))
 

+(defun loop-get-compound-form ()
+  (let ((form (loop-get-form)))
+    (unless (consp form)
+      (loop-error "A compound form was expected, but ~S found." form))
+    form))
+
+(defun loop-get-progn ()
+  (do ((forms (list (loop-get-compound-form))
+              (cons (loop-get-compound-form) forms))
+       (nextform (car *loop-source-code*)
+                 (car *loop-source-code*)))
+      ((atom nextform)
+       (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms))))))
+

 (defun loop-construct-return (form)
   `(return-from ,(car *loop-names*) ,form))
 
 (defun loop-construct-return (form)
   `(return-from ,(car *loop-names*) ,form))
 

@@ -1016,14 +1011,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
         (push (list name (or initialization (loop-typed-init dtype)))
               *loop-variables*))
        (initialization
         (push (list name (or initialization (loop-typed-init dtype)))
               *loop-variables*))
        (initialization

-        (cond (*loop-destructuring-hooks*
-               (loop-declare-variable name dtype)
-               (push (list name initialization) *loop-variables*))
-              (t (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
-                   (push (list newvar initialization) *loop-variables*)
-                   ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
-                   (setq *loop-desetq-crocks*
-                     (list* name newvar *loop-desetq-crocks*))))))
+        (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
+           (loop-declare-variable name dtype)
+           (push (list newvar initialization) *loop-variables*)
+           ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
+           (setq *loop-desetq-crocks*
+                 (list* name newvar *loop-desetq-crocks*))))

        (t (let ((tcar nil) (tcdr nil))
             (if (atom dtype) (setq tcar (setq tcdr dtype))
                 (setq tcar (car dtype) tcdr (cdr dtype)))
        (t (let ((tcar nil) (tcdr nil))
             (if (atom dtype) (setq tcar (setq tcdr dtype))
                 (setq tcar (car dtype) tcdr (cdr dtype)))

@@ -1792,7 +1785,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 ||#
 
 (defun loop-hash-table-iteration-path (variable data-type prep-phrases
 ||#
 
 (defun loop-hash-table-iteration-path (variable data-type prep-phrases

-                                      &key (which (required-argument)))
+                                      &key (which (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!"))
   (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!"))