X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=4be06cbe0e66f992a5386f214b0998da34b30fc7;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=43962bdbbdfd965cd325774d20437fe7f5fc84df;hpb=caf8bb05a82659e688c125b418783bc8a3bd2be8;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 43962bd..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 "~@" 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))