X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=b3a79aeae850fb2930adb4a4e1cfdcf2515cb4e1;hb=b6aa15328871678a3475e82c150b251dffb49ba1;hp=1df85e1ecad60a789e10a1c246017a850dbe71b5;hpb=f4f18b9dcdaf1948947b1747f5bfa766a1a0ee4c;p=sbcl.git

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 1df85e1..b3a79ae 100644
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -328,12 +328,6 @@ code to be loaded.
 
 ;;;; 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
@@ -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
-      (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"))
@@ -770,6 +761,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 			   specified-type required-type)))
 	specified-type)))
 
+(defun loop-build-destructuring-bindings (crocks forms)
+  (if crocks
+      `((destructuring-bind ,(car crocks) ,(cadr crocks)
+        ,@(loop-build-destructuring-bindings (cddr crocks) forms)))
+      forms))
+
 (defun loop-translate (*loop-source-code*
 		       *loop-macro-environment*
 		       *loop-universe*)
@@ -818,16 +815,10 @@ 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))
-	      (setq answer `(,(cond ((not vars) 'locally)
-				    (*loop-destructuring-hooks*
-				     (first *loop-destructuring-hooks*))
-				    (t
-				     'let))
+	      (setq answer `(,(if vars 'let 'locally)
 			     ,vars
-			     ,@(if crocks
-				   `((destructuring-bind ,@crocks
-					 ,@forms))
-				 forms)))))))
+			     ,@(loop-build-destructuring-bindings crocks
+								  forms)))))))
       answer)))
 
 (defun loop-iteration-driver ()
@@ -862,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.")))
 
-(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-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))
 
@@ -1012,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
-	 (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)))
@@ -1788,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
-				       &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!"))
@@ -1906,6 +1903,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 			     (below (loop-for-arithmetic :below))
 			     (to (loop-for-arithmetic :to))
 			     (upto (loop-for-arithmetic :upto))
+			     (by (loop-for-arithmetic :by))
 			     (being (loop-for-being)))
 	     :iteration-keywords '((for (loop-do-for))
 				   (as (loop-do-for))
@@ -1944,7 +1942,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 		   'loop-package-symbols-iteration-path w
 		   :preposition-groups '((:of :in))
 		   :inclusive-permitted nil
-		   :user-data '(:symbol-types (:internal)))
+		   :user-data '(:symbol-types (:internal
+					       :external)))
     w))
 
 (defparameter *loop-ansi-universe*