X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=4be06cbe0e66f992a5386f214b0998da34b30fc7;hb=b4831dc945c0754b3ba77881e67c8ea4d0a3d905;hp=23d714eb689fa020f998c06e682a111bd02d3e3f;hpb=cb4f56b0581f77e20a7d8cb593891c7bd919c3e9;p=sbcl.git

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 23d714e..4be06cb 100644
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -511,7 +511,8 @@ code to be loaded.
       (setq constant-value (eval new-form)))
     (when (and constantp expected-type)
       (unless (sb!xc:typep constant-value expected-type)
-	(loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
+	(loop-warn "~@<The form ~S evaluated to ~S, which was not of ~
+                    the anticipated type ~S.~:@>"
 		   form constant-value expected-type)
 	(setq constantp nil constant-value nil)))
     (values new-form constantp constant-value)))
@@ -534,6 +535,11 @@ code to be loaded.
 	;; CLTL2, removed from ANSI standard) we could set these
 	;; values flexibly. Without DECLARATION-INFORMATION, we have
 	;; to set them to constants.
+	;;
+	;; except FIXME: we've lost all pretence of portability,
+	;; considering this instead an internal implementation, so
+	;; we're free to couple to our own representation of the
+	;; environment.
 	(speed 1)
 	(space 1))
     (+ 40 (* (- speed space) 10))))
@@ -709,12 +715,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)))
@@ -1296,10 +1300,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
@@ -1719,21 +1723,22 @@ code to be loaded.
 		((loop-tequal prep :below) (setq dir ':up)))
 	  (setq limit-given t)
 	  (multiple-value-setq (form limit-constantp limit-value)
-	    (loop-constant-fold-if-possible form indexv-type))
+	    (loop-constant-fold-if-possible form `(and ,indexv-type real)))
 	  (setq endform (if limit-constantp
 			    `',limit-value
 			    (loop-make-var
-			      (gensym "LOOP-LIMIT-") form indexv-type))))
+			     (gensym "LOOP-LIMIT-") form
+			      `(and ,indexv-type real)))))
 	 (:by
-	   (multiple-value-setq (form stepby-constantp stepby)
-	     (loop-constant-fold-if-possible form indexv-type))
-	   (unless stepby-constantp
-	     (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
-			    form
-			    indexv-type)))
+	  (multiple-value-setq (form stepby-constantp stepby)
+	    (loop-constant-fold-if-possible form `(and ,indexv-type (real (0)))))
+	  (unless stepby-constantp
+	    (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
+			   form
+			   `(and ,indexv-type (real (0))))))
 	 (t (loop-error
-	      "~S invalid preposition in sequencing or sequence path;~@
-	       maybe invalid prepositions were specified in iteration path descriptor?"
+	     "~S invalid preposition in sequencing or sequence path;~@
+	      maybe invalid prepositions were specified in iteration path descriptor?"
 	      prep)))
        (when (and odir dir (not (eq dir odir)))
 	 (loop-error "conflicting stepping directions in LOOP sequencing path"))
@@ -1741,12 +1746,27 @@ code to be loaded.
      (when (and sequence-variable (not sequencep))
        (loop-error "missing OF or IN phrase in sequence path"))
      ;; Now fill in the defaults.
-     (unless start-given
-       (loop-make-iteration-var
-	 indexv
-	 (setq start-constantp t
-	       start-value (or (loop-typed-init indexv-type) 0))
-	 indexv-type))
+     (if start-given
+	 (when limit-given
+	   ;; if both start and limit are given, they had better both
+	   ;; be REAL.  We already enforce the REALness of LIMIT,
+	   ;; above; here's the KLUDGE to enforce the type of START.
+	   (flet ((type-declaration-of (x)
+		    (and (eq (car x) 'type) (caddr x))))
+	     (let ((decl (find indexv *loop-declarations*
+			       :key #'type-declaration-of))
+		   (%decl (find indexv *loop-declarations*
+				:key #'type-declaration-of
+				:from-end t)))
+	       (sb!int:aver (eq decl %decl))
+	       (setf (cadr decl)
+		     `(and real ,(cadr decl))))))
+	 ;; default start
+	 (loop-make-iteration-var
+	  indexv
+	  (setq start-constantp t
+		start-value (or (loop-typed-init indexv-type) 0))
+	  `(and ,indexv-type real)))
      (cond ((member dir '(nil :up))
 	    (when (or limit-given default-top)
 	      (unless limit-given
@@ -1773,7 +1793,8 @@ code to be loaded.
        (setq step-hack
 	     `(,variable ,step-hack)))
      (let ((first-test test) (remaining-tests test))
-       (when (and stepby-constantp start-constantp limit-constantp)
+       (when (and stepby-constantp start-constantp limit-constantp
+		  (realp start-value) (realp limit-value))
 	 (when (setq first-test
 		     (funcall (symbol-function testfn)
 			      start-value
@@ -1786,7 +1807,7 @@ code to be loaded.
 
 (defun loop-for-arithmetic (var val data-type kwd)
   (loop-sequencer
-   var (loop-check-data-type data-type 'real)
+   var (loop-check-data-type data-type 'number)
    nil nil nil nil nil nil
    (loop-collect-prepositional-phrases
     '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
@@ -1852,22 +1873,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