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

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 23d714e..acabbf6 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)))
@@ -924,12 +928,12 @@ code to be loaded.
 
 ;;;; loop types
 
-(defun loop-typed-init (data-type)
+(defun loop-typed-init (data-type &optional step-var-p)
   (when (and data-type (sb!xc:subtypep data-type 'number))
     (if (or (sb!xc:subtypep data-type 'float)
 	    (sb!xc:subtypep data-type '(complex float)))
-	(coerce 0 data-type)
-	0)))
+	(coerce (if step-var-p 1 0) data-type)
+	(if step-var-p 1 0))))
 
 (defun loop-optional-type (&optional variable)
   ;; No variable specified implies that no destructuring is permissible.
@@ -1020,13 +1024,13 @@ code to be loaded.
       ((null entry) (return nil))
       ((assoc name (caar entry) :test #'eq) (return t)))))
 
-(defun loop-make-var (name initialization dtype &optional iteration-var-p)
+(defun loop-make-var (name initialization dtype &optional iteration-var-p step-var-p)
   (cond ((null name)
-	 (cond ((not (null initialization))
-		(push (list (setq name (gensym "LOOP-IGNORE-"))
-			    initialization)
-		      *loop-vars*)
-		(push `(ignore ,name) *loop-declarations*))))
+	 (setq name (gensym "LOOP-IGNORE-"))
+	 (push (list name initialization) *loop-vars*)
+	 (if (null initialization)
+	     (push `(ignore ,name) *loop-declarations*)
+	     (loop-declare-var name dtype)))
 	((atom name)
 	 (cond (iteration-var-p
 		(if (member name *loop-iteration-vars*)
@@ -1037,10 +1041,10 @@ code to be loaded.
 			    name)))
 	 (unless (symbolp name)
 	   (loop-error "bad variable ~S somewhere in LOOP" name))
-	 (loop-declare-var name dtype)
+	 (loop-declare-var name dtype step-var-p)
 	 ;; We use ASSOC on this list to check for duplications (above),
 	 ;; so don't optimize out this list:
-	 (push (list name (or initialization (loop-typed-init dtype)))
+	 (push (list name (or initialization (loop-typed-init dtype step-var-p)))
 	       *loop-vars*))
 	(initialization
 	 (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
@@ -1059,11 +1063,11 @@ code to be loaded.
 (defun loop-make-iteration-var (name initialization dtype)
   (loop-make-var name initialization dtype t))
 
-(defun loop-declare-var (name dtype)
+(defun loop-declare-var (name dtype &optional step-var-p)
   (cond ((or (null name) (null dtype) (eq dtype t)) nil)
 	((symbolp name)
 	 (unless (sb!xc:subtypep t dtype)
-	   (let ((dtype (let ((init (loop-typed-init dtype)))
+	   (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
 			  (if (sb!xc:typep init dtype)
 			      dtype
 			      `(or (member ,init) ,dtype)))))
@@ -1152,7 +1156,7 @@ code to be loaded.
     (setq *loop-names* (list name))))
 
 (defun loop-do-return ()
-  (loop-pseudo-body (loop-construct-return (loop-get-form))))
+  (loop-emit-body (loop-construct-return (loop-get-form))))
 
 ;;;; value accumulation: LIST
 
@@ -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
@@ -1695,98 +1699,129 @@ code to be loaded.
 	 (limit-constantp nil)
 	 (limit-value nil)
 	 )
-     (when variable (loop-make-iteration-var variable nil variable-type))
-     (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
-       (setq prep (caar l) form (cadar l))
-       (case prep
-	 ((:of :in)
-	  (setq sequencep t)
-	  (loop-make-var sequence-variable form sequence-type))
-	 ((:from :downfrom :upfrom)
-	  (setq start-given t)
-	  (cond ((eq prep :downfrom) (setq dir ':down))
-		((eq prep :upfrom) (setq dir ':up)))
-	  (multiple-value-setq (form start-constantp start-value)
-	    (loop-constant-fold-if-possible form indexv-type))
-	  (loop-make-iteration-var indexv form indexv-type))
-	 ((:upto :to :downto :above :below)
-	  (cond ((loop-tequal prep :upto) (setq inclusive-iteration
-						(setq dir ':up)))
-		((loop-tequal prep :to) (setq inclusive-iteration t))
-		((loop-tequal prep :downto) (setq inclusive-iteration
-						  (setq dir ':down)))
-		((loop-tequal prep :above) (setq dir ':down))
-		((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))
-	  (setq endform (if limit-constantp
-			    `',limit-value
-			    (loop-make-var
-			      (gensym "LOOP-LIMIT-") form indexv-type))))
-	 (: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)))
-	 (t (loop-error
-	      "~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"))
-       (setq odir dir))
-     (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))
-     (cond ((member dir '(nil :up))
-	    (when (or limit-given default-top)
-	      (unless limit-given
-		(loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-"))
-			       nil
-			       indexv-type)
-		(push `(setq ,endform ,default-top) *loop-prologue*))
-	      (setq testfn (if inclusive-iteration '> '>=)))
-	    (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
-	   (t (unless start-given
-		(unless default-top
-		  (loop-error "don't know where to start stepping"))
-		(push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
-	      (when (and default-top (not endform))
-		(setq endform (loop-typed-init indexv-type)
-		      inclusive-iteration t))
-	      (when endform (setq testfn (if inclusive-iteration  '< '<=)))
-	      (setq step
-		    (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
-     (when testfn
-       (setq test
-	     `(,testfn ,indexv ,endform)))
-     (when step-hack
-       (setq step-hack
-	     `(,variable ,step-hack)))
-     (let ((first-test test) (remaining-tests test))
-       (when (and stepby-constantp start-constantp limit-constantp)
-	 (when (setq first-test
-		     (funcall (symbol-function testfn)
-			      start-value
-			      limit-value))
-	   (setq remaining-tests t)))
-       `(() (,indexv ,step)
-	 ,remaining-tests ,step-hack () () ,first-test ,step-hack))))
+     (flet ((assert-index-for-arithmetic (index)
+	      (unless (atom index)
+		(loop-error "Arithmetic index must be an atom."))))
+       (when variable (loop-make-iteration-var variable nil variable-type))
+       (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
+	 (setq prep (caar l) form (cadar l))
+	 (case prep
+	   ((:of :in)
+	    (setq sequencep t)
+	    (loop-make-var sequence-variable form sequence-type))
+	   ((:from :downfrom :upfrom)
+	    (setq start-given t)
+	    (cond ((eq prep :downfrom) (setq dir ':down))
+		  ((eq prep :upfrom) (setq dir ':up)))
+	    (multiple-value-setq (form start-constantp start-value)
+	      (loop-constant-fold-if-possible form indexv-type))
+	    (assert-index-for-arithmetic indexv)
+	    ;; KLUDGE: loop-make-var generates a temporary symbol for
+	    ;; indexv if it is NIL. We have to use it to have the index
+	    ;; actually count
+	    (setq indexv (loop-make-iteration-var indexv form indexv-type)))
+	   ((:upto :to :downto :above :below)
+	    (cond ((loop-tequal prep :upto) (setq inclusive-iteration
+						  (setq dir ':up)))
+		  ((loop-tequal prep :to) (setq inclusive-iteration t))
+		  ((loop-tequal prep :downto) (setq inclusive-iteration
+						    (setq dir ':down)))
+		  ((loop-tequal prep :above) (setq dir ':down))
+		  ((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 `(and ,indexv-type real)))
+	    (setq endform (if limit-constantp
+			      `',limit-value
+			      (loop-make-var
+				 (gensym "LOOP-LIMIT-") form
+				 `(and ,indexv-type real)))))
+	   (:by
+	    (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)))
+		 nil t)))
+	   (t (loop-error
+		 "~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"))
+	 (setq odir dir))
+       (when (and sequence-variable (not sequencep))
+	 (loop-error "missing OF or IN phrase in sequence path"))
+       ;; Now fill in the defaults.
+       (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
+	   ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
+	   ;; symbol for indexv if it is NIL. See also the comment in
+	   ;; the (:from :downfrom :upfrom) case
+	   (progn
+	     (assert-index-for-arithmetic indexv)
+	     (setq indexv
+		   (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
+		  (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-"))
+		     nil
+		     indexv-type)
+		  (push `(setq ,endform ,default-top) *loop-prologue*))
+		(setq testfn (if inclusive-iteration '> '>=)))
+	      (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
+	     (t (unless start-given
+		  (unless default-top
+		    (loop-error "don't know where to start stepping"))
+		  (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
+		(when (and default-top (not endform))
+		  (setq endform (loop-typed-init indexv-type)
+			inclusive-iteration t))
+		(when endform (setq testfn (if inclusive-iteration  '< '<=)))
+		(setq step
+		      (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
+       (when testfn
+	 (setq test
+	       `(,testfn ,indexv ,endform)))
+       (when step-hack
+	 (setq step-hack
+	       `(,variable ,step-hack)))
+       (let ((first-test test) (remaining-tests test))
+	 (when (and stepby-constantp start-constantp limit-constantp
+		    (realp start-value) (realp limit-value))
+	   (when (setq first-test
+		       (funcall (symbol-function testfn)
+				start-value
+				limit-value))
+	     (setq remaining-tests t)))
+	 `(() (,indexv ,step)
+	   ,remaining-tests ,step-hack () () ,first-test ,step-hack)))))
 
 ;;;; interfaces to the master sequencer
 
 (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 +1887,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