X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=1f86e9fc441683178a8279fdcfa432523834619e;hb=4ff8421d6f4590024f82ea6f6851e25b4ca3df99;hp=18f08ac8c0cf55c1d8f8e118292c3bc7290c4be7;hpb=763c7b3ba0358ae9f92a06f17815b44422d53308;p=sbcl.git

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 18f08ac..1f86e9f 100644
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -709,12 +709,10 @@ code to be loaded.
 			(setq n (+ n (estimate-code-size-1 (cadr l) env) 1))))
 		     ((eq fn 'go) 1)
 		     ((eq fn 'function)
-		      ;; This skirts the issue of implementationally-defined
-		      ;; lambda macros by recognizing CL function names and
-		      ;; nothing else.
-		      (if (or (symbolp (cadr x))
-			      (and (consp (cadr x)) (eq (caadr x) 'setf)))
+		      (if (sb!int:legal-fun-name-p (cadr x))
 			  1
+			  ;; FIXME: This tag appears not to be present
+			  ;; anywhere.
 			  (throw 'duplicatable-code-p nil)))
 		     ((eq fn 'multiple-value-setq)
 		      (f (length (second x)) (cddr x)))
@@ -1013,6 +1011,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))
@@ -1075,7 +1080,10 @@ code to be loaded.
       (loop-make-var (gensym "LOOP-BIND-") form data-type)))
 
 (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)
@@ -1085,7 +1093,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
@@ -1100,6 +1109,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)
@@ -1169,6 +1179,8 @@ code to be loaded.
     (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))
@@ -1282,10 +1294,10 @@ code to be loaded.
 (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*)
+	(type 'integer))
+    (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type)))
+      (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*)
+      (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-after-body*)
       ;; FIXME: What should
       ;;   (loop count t into a
       ;;         repeat 3
@@ -1304,6 +1316,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)
@@ -1836,22 +1850,22 @@ code to be loaded.
 	  (:hash-value (setq key-var (and other-p other-var)
 			     val-var variable)))
 	(push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
-	(when (consp key-var)
-	  (setq post-steps
-		`(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-"))
-			   ,@post-steps))
-	  (push `(,key-var nil) bindings))
-	(when (consp val-var)
-	  (setq post-steps
-		`(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-"))
-			   ,@post-steps))
-	  (push `(,val-var nil) bindings))
-	`(,bindings				;bindings
-	  ()					;prologue
-	  ()					;pre-test
-	  ()					;parallel steps
+        (when (or (consp key-var) data-type)
+          (setq post-steps
+                `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-"))
+                           ,@post-steps))
+          (push `(,key-var nil) bindings))
+        (when (or (consp val-var) data-type)
+          (setq post-steps
+                `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-"))
+                           ,@post-steps))
+          (push `(,val-var nil) bindings))
+	`(,bindings                     ;bindings
+	  ()                            ;prologue
+	  ()                            ;pre-test
+	  ()                            ;parallel steps
 	  (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var)
-		 (,next-fn)))	;post-test
+		 (,next-fn)))           ;post-test
 	  ,post-steps)))))
 
 (defun loop-package-symbols-iteration-path (variable data-type prep-phrases