X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=490486905e4c1f78f028876cdbd10e12a09c627f;hb=bf27595fb567015495b7131707cc85af361567fe;hp=a1cec364536e36aa844afa811e8464a42489883c;hpb=731bc63e2e5c9bac2799c299e37d7654579b0716;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index a1cec36..4904869 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -479,8 +479,8 @@ code to be loaded. (defvar *loop-after-epilogue*) ;;; the "culprit" responsible for supplying a final value from the -;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple -;;; return values being supplied. +;;; loop. This is so LOOP-DISALLOW-AGGREGATE-BOOLEANS can moan about +;;; disallowed anonymous collections. (defvar *loop-final-value-culprit*) ;;; If this is true, we are in some branch of a conditional. Some @@ -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))) @@ -901,26 +905,31 @@ code to be loaded. (setq *loop-emitted-body* t) (loop-pseudo-body form)) -(defun loop-emit-final-value (form) - (push (loop-construct-return form) *loop-after-epilogue*) - (when *loop-final-value-culprit* - (loop-warn "The LOOP clause is providing a value for the iteration,~@ - however one was already established by a ~S clause." - *loop-final-value-culprit*)) +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) (setq *loop-final-value-culprit* (car *loop-source-context*))) (defun loop-disallow-conditional (&optional kwd) (when *loop-inside-conditional* (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + +(defun loop-disallow-anonymous-collectors () + (when (find-if-not 'loop-collector-name *loop-collection-cruft*) + (loop-error "This LOOP clause is not permitted with anonymous collectors."))) + +(defun loop-disallow-aggregate-booleans () + (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) + (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) ;;;; 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. @@ -1004,13 +1013,20 @@ code to be loaded. *loop-desetq-crocks* nil *loop-wrappers* nil))) -(defun loop-make-var (name initialization dtype &optional iteration-var-p) +(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 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*) @@ -1021,10 +1037,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-"))) @@ -1043,11 +1059,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))))) @@ -1066,7 +1082,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) @@ -1076,7 +1095,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 @@ -1091,6 +1111,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) @@ -1131,7 +1152,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 @@ -1153,11 +1174,15 @@ code to be loaded. (loop-pop-source)))) (when (not (symbolp name)) (loop-error "The value accumulation recipient name, ~S, is not a symbol." name)) + (unless name + (loop-disallow-aggregate-booleans)) (unless dtype (setq dtype (or (loop-optional-type) default-type))) (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)) @@ -1165,12 +1190,12 @@ code to be loaded. (t (unless (eq (loop-collector-class cruft) class) (loop-error "incompatible kinds of LOOP value accumulation specified for collecting~@ - ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" name (car (loop-collector-history cruft)) collector)) (unless (equal dtype (loop-collector-dtype cruft)) (loop-warn "unequal datatypes specified in different LOOP value accumulations~@ - into ~S: ~S and ~S" + into ~S: ~S and ~S" name dtype (loop-collector-dtype cruft)) (when (eq (loop-collector-dtype cruft) t) (setf (loop-collector-dtype cruft) dtype))) @@ -1249,6 +1274,7 @@ code to be loaded. (defun loop-do-always (restrictive negate) (let ((form (loop-get-form))) (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) (loop-emit-body `(,(if negate 'when 'unless) ,form ,(loop-construct-return nil))) (loop-emit-final-value t))) @@ -1258,8 +1284,10 @@ code to be loaded. ;;; Under ANSI this is not permitted to appear under conditionalization. (defun loop-do-thereis (restrictive) (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-final-value) (loop-emit-body `(when (setq ,(loop-when-it-var) ,(loop-get-form)) - ,(loop-construct-return *loop-when-it-var*)))) + ,(loop-construct-return *loop-when-it-var*)))) (defun loop-do-while (negate kwd &aux (form (loop-get-form))) (loop-disallow-conditional kwd) @@ -1268,10 +1296,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 @@ -1290,6 +1318,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) @@ -1465,7 +1495,7 @@ code to be loaded. (let ((listvar var)) (cond ((and var (symbolp var)) (loop-make-iteration-var var list data-type)) - (t (loop-make-var (setq listvar (gensym)) list 'list) + (t (loop-make-var (setq listvar (gensym)) list 't) (loop-make-iteration-var var nil data-type))) (let ((list-step (loop-list-step listvar))) (let* ((first-endtest @@ -1634,7 +1664,7 @@ code to be loaded. (if (setq tem (loop-tassoc (car z) *loop-named-vars*)) (loop-error "The variable substitution for ~S occurs twice in a USING phrase,~@ - with ~S and ~S." + with ~S and ~S." (car z) (cadr z) (cadr tem)) (push (cons (car z) (cadr z)) *loop-named-vars*))) (when (or (null *loop-source-code*) @@ -1665,98 +1695,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)) @@ -1822,22 +1883,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