X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=4be06cbe0e66f992a5386f214b0998da34b30fc7;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=d6e83a9903c3b106f713b6817a45edd69ee7eb99;hpb=c7dc5b2a1f56ed0583a0b3ea61b6ceb540c6f89e;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index d6e83a9..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))) @@ -760,9 +764,27 @@ code to be loaded. specified-type required-type))) specified-type))) +(defun subst-gensyms-for-nil (tree) + (declare (special *ignores*)) + (cond + ((null tree) (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*))) + ((atom tree) tree) + (t (cons (subst-gensyms-for-nil (car tree)) + (subst-gensyms-for-nil (cdr tree)))))) + +(sb!int:defmacro-mundanely loop-destructuring-bind + (lambda-list arg-list &rest body) + (let ((*ignores* nil)) + (declare (special *ignores*)) + (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list))) + `(destructuring-bind ,d-var-lambda-list + ,arg-list + (declare (ignore ,@*ignores*)) + ,@body)))) + (defun loop-build-destructuring-bindings (crocks forms) (if crocks - `((destructuring-bind ,(car crocks) ,(cadr crocks) + `((loop-destructuring-bind ,(car crocks) ,(cadr crocks) ,@(loop-build-destructuring-bindings (cddr crocks) forms))) forms)) @@ -800,9 +822,6 @@ code to be loaded. ,(nreverse *loop-after-body*) ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) - (do () (nil) - (setq answer `(block ,(pop *loop-names*) ,answer)) - (unless *loop-names* (return nil))) (dolist (entry *loop-bind-stack*) (let ((vars (first entry)) (dcls (second entry)) @@ -818,6 +837,9 @@ code to be loaded. ,vars ,@(loop-build-destructuring-bindings crocks forms))))))) + (do () (nil) + (setq answer `(block ,(pop *loop-names*) ,answer)) + (unless *loop-names* (return nil))) answer))) (defun loop-iteration-driver () @@ -883,17 +905,26 @@ 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*) +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (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-warn "The LOOP clause is providing a value for the iteration;~@ + however, one was already established by a ~S clause." *loop-final-value-culprit*)) (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 @@ -986,6 +1017,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)) @@ -1048,7 +1086,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) @@ -1058,7 +1099,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 @@ -1073,6 +1115,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) @@ -1110,7 +1153,7 @@ code to be loaded. (when *loop-names* (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." (car *loop-names*) name)) - (setq *loop-names* (list name nil)))) + (setq *loop-names* (list name)))) (defun loop-do-return () (loop-pseudo-body (loop-construct-return (loop-get-form)))) @@ -1135,11 +1178,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)) @@ -1231,6 +1278,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))) @@ -1240,13 +1288,31 @@ 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) (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) +(defun loop-do-repeat () + (loop-disallow-conditional :repeat) + (let ((form (loop-get-form)) + (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 + ;; count t into b + ;; finally (return (list a b))) + ;; return: (3 3) or (4 3)? PUSHes above are for the former + ;; variant, L-P-B below for the latter. + #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop)))))) + (defun loop-do-with () (loop-disallow-conditional :with) (do ((var) (val) (dtype)) (nil) @@ -1256,6 +1322,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) @@ -1348,24 +1416,6 @@ code to be loaded. keyword)) (apply (car tem) var first-arg data-type (cdr tem)))) -(defun loop-do-repeat () - (let ((form (loop-get-form)) - (type (loop-check-data-type (loop-optional-type) - 'real))) - (when (and (consp form) - (eq (car form) 'the) - (sb!xc:subtypep (second form) type)) - (setq type (second form))) - (multiple-value-bind (number constantp value) - (loop-constant-fold-if-possible form type) - (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ())) - (t (let ((var (loop-make-var (gensym "LOOP-REPEAT-") number type))) - (if constantp - `((not (plusp (setq ,var (1- ,var)))) - () () () () () () ()) - `((minusp (setq ,var (1- ,var))) - () () ())))))))) - (defun loop-when-it-var () (or *loop-when-it-var* (setq *loop-when-it-var* @@ -1673,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")) @@ -1695,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 @@ -1727,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 @@ -1740,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)) @@ -1806,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 @@ -1883,7 +1950,8 @@ code to be loaded. (when (loop-do-if when nil)) ; Normal, do when (if (loop-do-if if nil)) ; synonymous (unless (loop-do-if unless t)) ; Negate test on when - (with (loop-do-with))) + (with (loop-do-with)) + (repeat (loop-do-repeat))) :for-keywords '((= (loop-ansi-for-equals)) (across (loop-for-across)) (in (loop-for-in)) @@ -1899,8 +1967,7 @@ code to be loaded. (by (loop-for-arithmetic :by)) (being (loop-for-being))) :iteration-keywords '((for (loop-do-for)) - (as (loop-do-for)) - (repeat (loop-do-repeat))) + (as (loop-do-for))) :type-symbols '(array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum float function hash-table integer @@ -1944,9 +2011,9 @@ code to be loaded. (defun loop-standard-expansion (keywords-and-forms environment universe) (if (and keywords-and-forms (symbolp (car keywords-and-forms))) - (loop-translate keywords-and-forms environment universe) - (let ((tag (gensym))) - `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) + (loop-translate keywords-and-forms environment universe) + (let ((tag (gensym))) + `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) (sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms) (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))