X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=acabbf6fb625e3b99725f2573d5eab89c7d83e37;hb=b3f188843330c56bd4d17a3c930e73f573b1c71f;hp=b1ef79ac88d87fa9d748138aea8b0a5d3bbeed29;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index b1ef79a..acabbf6 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -6,12 +6,13 @@ ;;;; This code was modified by William Harold Newman beginning ;;;; 19981106, originally to conform to the new SBCL bootstrap package ;;;; system and then subsequently to address other cross-compiling -;;;; bootstrap issues. Whether or not it then supported all the -;;;; environments implied by the reader conditionals in the source -;;;; code (e.g. #!+CLOE-RUNTIME) before that modification, it sure -;;;; doesn't now: it might be appropriate for CMU-CL-derived systems -;;;; in general but only claims to be appropriate for the particular -;;;; branch I was working on. +;;;; bootstrap issues, SBCLification (e.g. DECLARE used to check +;;;; argument types), and other maintenance. Whether or not it then +;;;; supported all the environments implied by the reader conditionals +;;;; in the source code (e.g. #!+CLOE-RUNTIME) before that +;;;; modification, it sure doesn't now. It might perhaps, by blind +;;;; luck, be appropriate for some other CMU-CL-derived system, but +;;;; really it only attempts to be appropriate for SBCL. ;;;; This software is derived from software originally released by the ;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and @@ -92,76 +93,15 @@ ;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been ;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too. -;;;; miscellaneous environment things - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *loop-real-data-type* 'real)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *loop-gentemp* nil) - (defun loop-gentemp (&optional (pref 'loopvar-)) - (if *loop-gentemp* - (gentemp (string pref)) - (gensym)))) - -;;; @@@@ The following form takes a list of variables and a form which -;;; presumably references those variables, and wraps it somehow so that the -;;; compiler does not consider those variables have been referenced. The intent -;;; of this is that iteration variables can be flagged as unused by the -;;; compiler, e.g. I in (loop for i from 1 to 10 do (print t)), since we will -;;; tell it when a usage of it is "invisible" or "not to be considered". -;;; -;;; We implicitly assume that a setq does not count as a reference. That is, -;;; the kind of form generated for the above loop construct to step I, -;;; simplified, is -;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). -;;; -;;; FIXME: This is a no-op except for Genera, now obsolete, so it -;;; can be removed. -(defun hide-variable-references (variable-list form) - (declare (ignore variable-list)) - form) - -;;; @@@@ The following function takes a flag, a variable, and a form which -;;; presumably references that variable, and wraps it somehow so that the -;;; compiler does not consider that variable to have been referenced. The -;;; intent of this is that iteration variables can be flagged as unused by the -;;; compiler, e.g. I in (loop for i from 1 to 10 do (print t)), since we will -;;; tell it when a usage of it is "invisible" or "not to be considered". -;;; -;;; We implicitly assume that a setq does not count as a reference. That is, -;;; the kind of form generated for the above loop construct to step I, -;;; simplified, is -;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). -;;; -;;; Certain cases require that the "invisibility" of the reference be -;;; conditional upon something. This occurs in cases of "named" variables (the -;;; USING clause). For instance, we want IDX in (LOOP FOR E BEING THE -;;; VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) to be "invisible" when it is -;;; stepped, so that the user gets informed if IDX is not referenced. However, -;;; if no USING clause is present, we definitely do not want to be informed -;;; that some gensym or other is not used. -;;; -;;; It is easier for the caller to do this conditionally by passing a flag -;;; (which happens to be the second value of NAMED-VARIABLE, q.v.) to this -;;; function than for all callers to contain the conditional invisibility -;;; construction. -;;; -;;; FIXME: This is a no-op except for Genera, now obsolete, so it -;;; can be removed. -(defun hide-variable-reference (really-hide variable form) - (declare (ignore really-hide variable)) - form) - ;;;; list collection macrology -(sb!kernel:defmacro-mundanely with-loop-list-collection-head +(sb!int:defmacro-mundanely with-loop-list-collection-head ((head-var tail-var &optional user-head-var) &body body) (let ((l (and user-head-var (list (list user-head-var nil))))) `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) ,@body))) -(sb!kernel:defmacro-mundanely loop-collect-rplacd +(sb!int:defmacro-mundanely loop-collect-rplacd (&environment env (head-var tail-var &optional user-head-var) form) (setq form (sb!xc:macroexpand form env)) (flet ((cdr-wrap (form n) @@ -207,7 +147,7 @@ (setq ,user-head-var (cdr ,head-var))))) answer)))) -(sb!kernel:defmacro-mundanely loop-collect-answer (head-var +(sb!int:defmacro-mundanely loop-collect-answer (head-var &optional user-head-var) (or user-head-var `(cdr ,head-var))) @@ -240,23 +180,20 @@ constructed. infinity-data) (defvar *loop-minimax-type-infinities-alist* - ;; Note: In the portable loop.lisp, this had various - ;; conditional-on-*FEATURES* cases to support machines which had true - ;; floating infinity. Now that we're limited to CMU CL, this is irrelevant. - ;; FIXME: Or is it? What if we ever support infinity? Perhaps we should - ;; put in something conditional on SB-INFINITY or something? + ;; FIXME: Now that SBCL supports floating point infinities again, we + ;; should have floating point infinities here, as cmucl-2.4.8 did. '((fixnum most-positive-fixnum most-negative-fixnum))) (defun make-loop-minimax (answer-variable type) (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* - :test #'subtypep)))) + :test #'sb!xc:subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable :type type - :temp-variable (loop-gentemp 'loop-maxmin-temp-) + :temp-variable (gensym "LOOP-MAXMIN-TEMP-") :flag-variable (and (not infinity-data) - (loop-gentemp 'loop-maxmin-flag-)) + (gensym "LOOP-MAXMIN-FLAG-")) :operations nil :infinity-data infinity-data))) @@ -265,10 +202,10 @@ constructed. (when (and (cdr (loop-minimax-operations minimax)) (not (loop-minimax-flag-variable minimax))) (setf (loop-minimax-flag-variable minimax) - (loop-gentemp 'loop-maxmin-flag-))) + (gensym "LOOP-MAXMIN-FLAG-"))) operation) -(sb!kernel:defmacro-mundanely with-minimax-value (lm &body body) +(sb!int:defmacro-mundanely with-minimax-value (lm &body body) (let ((init (loop-typed-init (loop-minimax-type lm))) (which (car (loop-minimax-operations lm))) (infinity-data (loop-minimax-infinity-data lm)) @@ -287,19 +224,14 @@ constructed. (declare (type ,type ,answer-var ,temp-var)) ,@body)))) -(sb!kernel:defmacro-mundanely loop-accumulate-minimax-value (lm - operation - form) +(sb!int:defmacro-mundanely loop-accumulate-minimax-value (lm operation form) (let* ((answer-var (loop-minimax-answer-variable lm)) (temp-var (loop-minimax-temp-variable lm)) (flag-var (loop-minimax-flag-variable lm)) - (test - (hide-variable-reference - t (loop-minimax-answer-variable lm) - `(,(ecase operation - (min '<) - (max '>)) - ,temp-var ,answer-var)))) + (test `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var))) `(progn (setq ,temp-var ,form) (when ,(if flag-var `(or (not ,flag-var) ,test) test) @@ -337,27 +269,27 @@ code to be loaded. (and (symbolp loop-token) (values (gethash (symbol-name loop-token) table)))) -(sb!kernel:defmacro-mundanely loop-store-table-data (symbol table datum) +(sb!int:defmacro-mundanely loop-store-table-data (symbol table datum) `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) (defstruct (loop-universe (:copier nil) (:predicate nil)) - keywords ; hash table, value = (fn-name . extra-data) - iteration-keywords ; hash table, value = (fn-name . extra-data) - for-keywords ; hash table, value = (fn-name . extra-data) - path-keywords ; hash table, value = (fn-name . extra-data) - type-symbols ; hash table of type SYMBOLS, test EQ, - ; value = CL type specifier - type-keywords ; hash table of type STRINGS, test EQUAL, - ; value = CL type spec - ansi ; NIL, T, or :EXTENDED + keywords ; hash table, value = (fn-name . extra-data) + iteration-keywords ; hash table, value = (fn-name . extra-data) + for-keywords ; hash table, value = (fn-name . extra-data) + path-keywords ; hash table, value = (fn-name . extra-data) + type-symbols ; hash table of type SYMBOLS, test EQ, + ; value = CL type specifier + type-keywords ; hash table of type STRINGS, test EQUAL, + ; value = CL type spec + ansi ; NIL, T, or :EXTENDED implicit-for-required) ; see loop-hack-iteration (sb!int:def!method print-object ((u loop-universe) stream) (let ((string (case (loop-universe-ansi u) - ((nil) "Non-ANSI") + ((nil) "non-ANSI") ((t) "ANSI") - (:extended "Extended-ANSI") + (:extended "extended-ANSI") (t (loop-universe-ansi u))))) (print-unreadable-object (u stream :type t) (write-string string stream)))) @@ -369,7 +301,7 @@ code to be loaded. (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords type-keywords type-symbols ansi) - (check-type ansi (member nil t :extended)) + (declare (type (member nil t :extended) ansi)) (flet ((maketable (entries) (let* ((size (length entries)) (ht (make-hash-table :size (if (< size 10) 10 size) @@ -394,13 +326,7 @@ code to be loaded. (setf (gethash (car x) ht) (cadr x)))) ht)))) -;;;; SETQ hackery - -(defvar *loop-destructuring-hooks* - nil - #!+sb-doc - "If not NIL, this must be a list of two things: -a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") +;;;; SETQ hackery, including destructuring ("DESETQ") (defun loop-make-psetq (frobs) (and frobs @@ -413,19 +339,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-make-desetq (var-val-pairs) (if (null var-val-pairs) nil - (cons (if *loop-destructuring-hooks* - (cadr *loop-destructuring-hooks*) - 'loop-really-desetq) - var-val-pairs))) + (cons 'loop-really-desetq var-val-pairs))) (defvar *loop-desetq-temporary* (make-symbol "LOOP-DESETQ-TEMP")) -(sb!kernel:defmacro-mundanely loop-really-desetq (&environment env - &rest var-val-pairs) +(sb!int:defmacro-mundanely loop-really-desetq (&environment env + &rest var-val-pairs) (labels ((find-non-null (var) - ;; see whether there's any non-null thing here - ;; recurse if the list element is itself a list + ;; See whether there's any non-null thing here. Recurse + ;; if the list element is itself a list. (do ((tail var)) ((not (consp tail)) tail) (when (find-non-null (pop tail)) (return t)))) (loop-desetq-internal (var val &optional temp) @@ -433,17 +356,17 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (typecase var (null (when (consp val) - ;; don't lose possible side-effects + ;; Don't lose possible side effects. (if (eq (car val) 'prog1) - ;; these can come from psetq or desetq below. - ;; throw away the value, keep the side-effects. - ;;Special case is for handling an expanded POP. - (mapcan #'(lambda (x) - (and (consp x) - (or (not (eq (car x) 'car)) - (not (symbolp (cadr x))) - (not (symbolp (setq x (sb!xc:macroexpand x env))))) - (cons x nil))) + ;; These can come from PSETQ or DESETQ below. + ;; Throw away the value, keep the side effects. + ;; Special case is for handling an expanded POP. + (mapcan (lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (sb!xc:macroexpand x env))))) + (cons x nil))) (cdr val)) `(,val)))) (cons @@ -467,7 +390,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ,@body) `((let ((,temp ,val)) ,@body)))) - ;; no cdring to do + ;; no CDRing to do (loop-desetq-internal car `(car ,val) temp))))) (otherwise (unless (eq var val) @@ -482,109 +405,103 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; LOOP-local variables -;;;This is the "current" pointer into the LOOP source code. +;;; This is the "current" pointer into the LOOP source code. (defvar *loop-source-code*) -;;;This is the pointer to the original, for things like NAMED that -;;;insist on being in a particular position +;;; This is the pointer to the original, for things like NAMED that +;;; insist on being in a particular position (defvar *loop-original-source-code*) -;;;This is *loop-source-code* as of the "last" clause. It is used -;;;primarily for generating error messages (see loop-error, loop-warn). +;;; This is *loop-source-code* as of the "last" clause. It is used +;;; primarily for generating error messages (see loop-error, loop-warn). (defvar *loop-source-context*) -;;;List of names for the LOOP, supplied by the NAMED clause. +;;; list of names for the LOOP, supplied by the NAMED clause (defvar *loop-names*) -;;;The macroexpansion environment given to the macro. +;;; The macroexpansion environment given to the macro. (defvar *loop-macro-environment*) -;;;This holds variable names specified with the USING clause. -;;; See LOOP-NAMED-VARIABLE. -(defvar *loop-named-variables*) +;;; This holds variable names specified with the USING clause. +;;; See LOOP-NAMED-VAR. +(defvar *loop-named-vars*) ;;; LETlist-like list being accumulated for one group of parallel bindings. -(defvar *loop-variables*) +(defvar *loop-vars*) -;;;List of declarations being accumulated in parallel with -;;;*loop-variables*. +;;; list of declarations being accumulated in parallel with *LOOP-VARS* (defvar *loop-declarations*) -;;;Used by LOOP for destructuring binding, if it is doing that itself. -;;; See loop-make-variable. +;;; This is used by LOOP for destructuring binding, if it is doing +;;; that itself. See LOOP-MAKE-VAR. (defvar *loop-desetq-crocks*) -;;; List of wrapping forms, innermost first, which go immediately inside -;;; the current set of parallel bindings being accumulated in -;;; *loop-variables*. The wrappers are appended onto a body. E.g., -;;; this list could conceivably has as its value ((with-open-file (g0001 -;;; g0002 ...))), with g0002 being one of the bindings in -;;; *loop-variables* (this is why the wrappers go inside of the variable -;;; bindings). +;;; list of wrapping forms, innermost first, which go immediately +;;; inside the current set of parallel bindings being accumulated in +;;; *LOOP-VARS*. The wrappers are appended onto a body. E.g., +;;; this list could conceivably have as its value +;;; ((WITH-OPEN-FILE (G0001 G0002 ...))), +;;; with G0002 being one of the bindings in *LOOP-VARS* (This is +;;; why the wrappers go inside of the variable bindings). (defvar *loop-wrappers*) -;;;This accumulates lists of previous values of *loop-variables* and the -;;;other lists above, for each new nesting of bindings. See -;;;loop-bind-block. +;;; This accumulates lists of previous values of *LOOP-VARS* and +;;; the other lists above, for each new nesting of bindings. See +;;; LOOP-BIND-BLOCK. (defvar *loop-bind-stack*) -;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause -;;;which inhibits LOOP from actually outputting a type declaration for -;;;an iteration (or any) variable. -(defvar *loop-nodeclare*) +;;; This is simply a list of LOOP iteration variables, used for +;;; checking for duplications. +(defvar *loop-iteration-vars*) -;;;This is simply a list of LOOP iteration variables, used for checking -;;;for duplications. -(defvar *loop-iteration-variables*) - -;;;List of prologue forms of the loop, accumulated in reverse order. +;;; list of prologue forms of the loop, accumulated in reverse order (defvar *loop-prologue*) (defvar *loop-before-loop*) (defvar *loop-body*) (defvar *loop-after-body*) -;;;This is T if we have emitted any body code, so that iteration driving -;;;clauses can be disallowed. This is not strictly the same as -;;;checking *loop-body*, because we permit some clauses such as RETURN -;;;to not be considered "real" body (so as to permit the user to "code" -;;;an abnormal return value "in loop"). +;;; This is T if we have emitted any body code, so that iteration +;;; driving clauses can be disallowed. This is not strictly the same +;;; as checking *LOOP-BODY*, because we permit some clauses such as +;;; RETURN to not be considered "real" body (so as to permit the user +;;; to "code" an abnormal return value "in loop"). (defvar *loop-emitted-body*) -;;;List of epilogue forms (supplied by FINALLY generally), accumulated -;;; in reverse order. +;;; list of epilogue forms (supplied by FINALLY generally), accumulated +;;; in reverse order (defvar *loop-epilogue*) -;;;List of epilogue forms which are supplied after the above "user" -;;;epilogue. "normal" termination return values are provide by putting -;;;the return form in here. Normally this is done using -;;;loop-emit-final-value, q.v. +;;; list of epilogue forms which are supplied after the above "user" +;;; epilogue. "Normal" termination return values are provide by +;;; putting the return form in here. Normally this is done using +;;; LOOP-EMIT-FINAL-VALUE, q.v. (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. +;;; 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. (defvar *loop-final-value-culprit*) -;;;If not NIL, we are in some branch of a conditional. Some clauses may -;;;be disallowed. +;;; If this is true, we are in some branch of a conditional. Some +;;; clauses may be disallowed. (defvar *loop-inside-conditional*) -;;;If not NIL, this is a temporary bound around the loop for holding the -;;;temporary value for "it" in things like "when (f) collect it". It -;;;may be used as a supertemporary by some other things. -(defvar *loop-when-it-variable*) - -;;;Sometimes we decide we need to fold together parts of the loop, but -;;;some part of the generated iteration code is different for the first -;;;and remaining iterations. This variable will be the temporary which -;;;is the flag used in the loop to tell whether we are in the first or -;;;remaining iterations. -(defvar *loop-never-stepped-variable*) - -;;;List of all the value-accumulation descriptor structures in the loop. -;;; See loop-get-collection-info. -(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) +;;; If not NIL, this is a temporary bound around the loop for holding +;;; the temporary value for "it" in things like "when (f) collect it". +;;; It may be used as a supertemporary by some other things. +(defvar *loop-when-it-var*) + +;;; Sometimes we decide we need to fold together parts of the loop, +;;; but some part of the generated iteration code is different for the +;;; first and remaining iterations. This variable will be the +;;; temporary which is the flag used in the loop to tell whether we +;;; are in the first or remaining iterations. +(defvar *loop-never-stepped-var*) + +;;; list of all the value-accumulation descriptor structures in the +;;; loop. See LOOP-GET-COLLECTION-INFO. +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc.) ;;;; code analysis stuff @@ -593,8 +510,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (when (setq constantp (constantp new-form)) (setq constant-value (eval new-form))) (when (and constantp expected-type) - (unless (typep constant-value expected-type) - (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." + (unless (sb!xc:typep constant-value expected-type) + (loop-warn "~@" form constant-value expected-type) (setq constantp nil constant-value nil))) (values new-form constantp constant-value))) @@ -607,20 +525,26 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defvar *loop-duplicate-code* nil) -(defvar *loop-iteration-flag-variable* +(defvar *loop-iteration-flag-var* (make-symbol "LOOP-NOT-FIRST-TIME")) (defun loop-code-duplication-threshold (env) (declare (ignore env)) - (let (;; If we could read optimization declaration information (as with - ;; the DECLARATION-INFORMATION function (present in CLTL2, removed - ;; from ANSI standard) we could set these values flexibly. Without - ;; DECLARATION-INFORMATION, we have to set them to constants. + (let (;; If we could read optimization declaration information (as + ;; with the DECLARATION-INFORMATION function (present in + ;; 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)))) -(sb!kernel:defmacro-mundanely loop-body (&environment env +(sb!int:defmacro-mundanely loop-body (&environment env prologue before-loop main-body @@ -654,26 +578,27 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) ;; This outer loop iterates once for each not-first-time flag test - ;; generated plus once more for the forms that don't need a flag test + ;; generated plus once more for the forms that don't need a flag test. (do ((threshold (loop-code-duplication-threshold env))) (nil) (declare (fixnum threshold)) - ;; Go backwards from the ends of before-loop and after-loop merging all - ;; the equivalent forms into the body. + ;; Go backwards from the ends of before-loop and after-loop + ;; merging all the equivalent forms into the body. (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) (push (pop rbefore) main-body) (pop rafter)) (unless rbefore (return (makebody))) - ;; The first forms in rbefore & rafter (which are the chronologically - ;; last forms in the list) differ, therefore they cannot be moved - ;; into the main body. If everything that chronologically precedes - ;; them either differs or is equal but is okay to duplicate, we can - ;; just put all of rbefore in the prologue and all of rafter after - ;; the body. Otherwise, there is something that is not okay to - ;; duplicate, so it and everything chronologically after it in - ;; rbefore and rafter must go into the body, with a flag test to - ;; distinguish the first time around the loop from later times. - ;; What chronologically precedes the non-duplicatable form will - ;; be handled the next time around the outer loop. + ;; The first forms in RBEFORE & RAFTER (which are the + ;; chronologically last forms in the list) differ, therefore + ;; they cannot be moved into the main body. If everything that + ;; chronologically precedes them either differs or is equal but + ;; is okay to duplicate, we can just put all of rbefore in the + ;; prologue and all of rafter after the body. Otherwise, there + ;; is something that is not okay to duplicate, so it and + ;; everything chronologically after it in rbefore and rafter + ;; must go into the body, with a flag test to distinguish the + ;; first time around the loop from later times. What + ;; chronologically precedes the non-duplicatable form will be + ;; handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) @@ -684,23 +609,24 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ((or (not (setq inc (estimate-code-size (car bb) env))) (> (incf count inc) threshold)) ;; Ok, we have found a non-duplicatable piece of code. - ;; Everything chronologically after it must be in the central - ;; body. Everything chronologically at and after lastdiff goes - ;; into the central body under a flag test. + ;; Everything chronologically after it must be in the + ;; central body. Everything chronologically at and + ;; after LASTDIFF goes into the central body under a + ;; flag test. (let ((then nil) (else nil)) (do () (nil) (push (pop rbefore) else) (push (pop rafter) then) (when (eq rbefore (cdr lastdiff)) (return))) (unless flagvar - (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) + (push `(setq ,(setq flagvar *loop-iteration-flag-var*) t) else)) (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) main-body)) ;; Everything chronologically before lastdiff until the - ;; non-duplicatable form (car bb) is the same in rbefore and - ;; rafter so just copy it into the body + ;; non-duplicatable form (CAR BB) is the same in + ;; RBEFORE and RAFTER, so just copy it into the body. (do () (nil) (pop rafter) (push (pop rbefore) main-body) @@ -711,9 +637,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (if (null expr) 0 (let ((ans (estimate-code-size expr env))) (declare (fixnum ans)) - ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an - ;; alist of optimize quantities back to help quantify how much code we - ;; are willing to duplicate. + ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to + ;; get an alist of optimize quantities back to help quantify + ;; how much code we are willing to duplicate. ans))) (defvar *special-code-sizes* @@ -789,12 +715,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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))) @@ -817,10 +741,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ((eq l (cdr *loop-source-code*)) (nreverse new)))) (defun loop-error (format-string &rest format-args) - (error "~?~%current LOOP context:~{ ~S~}." - format-string - format-args - (loop-context))) + (error 'sb!int:simple-program-error + :format-control "~?~%current LOOP context:~{ ~S~}." + :format-arguments (list format-string format-args (loop-context)))) (defun loop-warn (format-string &rest format-args) (warn "~?~%current LOOP context:~{ ~S~}." @@ -832,7 +755,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. &optional (default-type required-type)) (if (null specified-type) default-type - (multiple-value-bind (a b) (subtypep specified-type required-type) + (multiple-value-bind (a b) (sb!xc:subtypep specified-type required-type) (cond ((not b) (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." specified-type required-type)) @@ -841,15 +764,38 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. 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 + `((loop-destructuring-bind ,(car crocks) ,(cadr crocks) + ,@(loop-build-destructuring-bindings (cddr crocks) forms))) + forms)) + (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) (let ((*loop-original-source-code* *loop-source-code*) (*loop-source-context* nil) - (*loop-iteration-variables* nil) - (*loop-variables* nil) - (*loop-nodeclare* nil) - (*loop-named-variables* nil) + (*loop-iteration-vars* nil) + (*loop-vars* nil) + (*loop-named-vars* nil) (*loop-declarations* nil) (*loop-desetq-crocks* nil) (*loop-bind-stack* nil) @@ -863,8 +809,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (*loop-after-epilogue* nil) (*loop-final-value-culprit* nil) (*loop-inside-conditional* nil) - (*loop-when-it-variable* nil) - (*loop-never-stepped-variable* nil) + (*loop-when-it-var* nil) + (*loop-never-stepped-var* nil) (*loop-names* nil) (*loop-collection-cruft* nil)) (loop-iteration-driver) @@ -876,9 +822,6 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ,(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)) @@ -890,16 +833,13 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (let ((forms (list answer))) ;;(when crocks (push crocks forms)) (when dcls (push `(declare ,@dcls) forms)) - (setq answer `(,(cond ((not vars) 'locally) - (*loop-destructuring-hooks* - (first *loop-destructuring-hooks*)) - (t - 'let)) + (setq answer `(,(if vars 'let 'locally) ,vars - ,@(if crocks - `((destructuring-bind ,@crocks - ,@forms)) - forms))))))) + ,@(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 () @@ -913,16 +853,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) - ;; It's a "miscellaneous" toplevel LOOP keyword (do, - ;; collect, named, etc.) + ;; It's a "miscellaneous" toplevel LOOP keyword (DO, + ;; COLLECT, NAMED, etc.) (apply (symbol-function (first tem)) (rest tem))) ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) (loop-hack-iteration tem)) ((loop-tmember keyword '(and else)) - ;; Alternative is to ignore it, ie let it go around to - ;; the next keyword... + ;; The alternative is to ignore it, i.e. let it go + ;; around to the next keyword... (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." keyword (car *loop-source-code*) @@ -934,17 +874,25 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (pop *loop-source-code*) (loop-error "LOOP source code ran out when another token was expected."))) -(defun loop-get-progn () - (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms)) - (nextform (car *loop-source-code*) (car *loop-source-code*))) - ((atom nextform) - (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) - (defun loop-get-form () (if *loop-source-code* (loop-pop-source) (loop-error "LOOP code ran out where a form was expected."))) +(defun loop-get-compound-form () + (let ((form (loop-get-form))) + (unless (consp form) + (loop-error "A compound form was expected, but ~S found." form)) + form)) + +(defun loop-get-progn () + (do ((forms (list (loop-get-compound-form)) + (cons (loop-get-compound-form) forms)) + (nextform (car *loop-source-code*) + (car *loop-source-code*))) + ((atom nextform) + (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) + (defun loop-construct-return (form) `(return-from ,(car *loop-names*) ,form)) @@ -957,42 +905,53 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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 -(defun loop-typed-init (data-type) - (when (and data-type (subtypep data-type 'number)) - (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) - (coerce 0 data-type) - 0))) +(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 (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. (and *loop-source-code* ; Don't get confused by NILs.. (let ((z (car *loop-source-code*))) (cond ((loop-tequal z 'of-type) - ;; This is the syntactically unambigous form in that the form - ;; of the type specifier does not matter. Also, it is assumed - ;; that the type specifier is unambiguously, and without need - ;; of translation, a common lisp type specifier or pattern - ;; (matching the variable) thereof. + ;; This is the syntactically unambigous form in that + ;; the form of the type specifier does not matter. + ;; Also, it is assumed that the type specifier is + ;; unambiguously, and without need of translation, a + ;; common lisp type specifier or pattern (matching the + ;; variable) thereof. (loop-pop-source) (loop-pop-source)) ((symbolp z) - ;; This is the (sort of) "old" syntax, even though we didn't - ;; used to support all of these type symbols. + ;; This is the (sort of) "old" syntax, even though we + ;; didn't used to support all of these type symbols. (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) @@ -1003,11 +962,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (loop-pop-source) type-spec))) (t - ;; This is our sort-of old syntax. But this is only valid for - ;; when we are destructuring, so we will be compulsive (should - ;; we really be?) and require that we in fact be doing variable - ;; destructuring here. We must translate the old keyword - ;; pattern typespec into a fully-specified pattern of real type + ;; This is our sort-of old syntax. But this is only + ;; valid for when we are destructuring, so we will be + ;; compulsive (should we really be?) and require that + ;; we in fact be doing variable destructuring here. We + ;; must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type ;; specifiers here. (if (consp variable) (unless (consp z) @@ -1046,89 +1006,90 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; loop variables (defun loop-bind-block () - (when (or *loop-variables* *loop-declarations* *loop-wrappers*) - (push (list (nreverse *loop-variables*) + (when (or *loop-vars* *loop-declarations* *loop-wrappers*) + (push (list (nreverse *loop-vars*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) *loop-bind-stack*) - (setq *loop-variables* nil + (setq *loop-vars* nil *loop-declarations* nil *loop-desetq-crocks* nil *loop-wrappers* nil))) -(defun loop-make-variable (name initialization dtype - &optional iteration-variable-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 (loop-gentemp 'loop-ignore-)) - initialization) - *loop-variables*) - (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-variable-p - (if (member name *loop-iteration-variables*) + (cond (iteration-var-p + (if (member name *loop-iteration-vars*) (loop-error "duplicated LOOP iteration variable ~S" name) - (push name *loop-iteration-variables*))) - ((assoc name *loop-variables*) + (push name *loop-iteration-vars*))) + ((assoc name *loop-vars*) (loop-error "duplicated variable ~S in LOOP parallel binding" name))) (unless (symbolp name) (loop-error "bad variable ~S somewhere in LOOP" name)) - (loop-declare-variable 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))) - *loop-variables*)) + (push (list name (or initialization (loop-typed-init dtype step-var-p))) + *loop-vars*)) (initialization - (cond (*loop-destructuring-hooks* - (loop-declare-variable name dtype) - (push (list name initialization) *loop-variables*)) - (t (let ((newvar (loop-gentemp 'loop-destructure-))) - (push (list newvar initialization) *loop-variables*) - ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. - (setq *loop-desetq-crocks* - (list* name newvar *loop-desetq-crocks*)) - ;; FIXME: We can delete this, right? - #+ignore - (loop-make-variable name - nil - dtype - iteration-variable-p))))) + (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) + (loop-declare-var name dtype) + (push (list newvar initialization) *loop-vars*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)))) (t (let ((tcar nil) (tcdr nil)) (if (atom dtype) (setq tcar (setq tcdr dtype)) (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-variable (car name) nil tcar iteration-variable-p) - (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) + (loop-make-var (car name) nil tcar iteration-var-p) + (loop-make-var (cdr name) nil tcdr iteration-var-p)))) name) -(defun loop-make-iteration-variable (name initialization dtype) - (loop-make-variable name initialization dtype t)) +(defun loop-make-iteration-var (name initialization dtype) + (loop-make-var name initialization dtype t)) -(defun loop-declare-variable (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 (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) - (let ((dtype (let ((init (loop-typed-init dtype))) - (if (typep init dtype) - dtype - `(or (member ,init) ,dtype))))) + (unless (sb!xc:subtypep t dtype) + (let ((dtype (let ((init (loop-typed-init dtype step-var-p))) + (if (sb!xc:typep init dtype) + dtype + `(or (member ,init) ,dtype))))) (push `(type ,dtype ,name) *loop-declarations*)))) ((consp name) (cond ((consp dtype) - (loop-declare-variable (car name) (car dtype)) - (loop-declare-variable (cdr name) (cdr dtype))) - (t (loop-declare-variable (car name) dtype) - (loop-declare-variable (cdr name) dtype)))) + (loop-declare-var (car name) (car dtype)) + (loop-declare-var (cdr name) (cdr dtype))) + (t (loop-declare-var (car name) dtype) + (loop-declare-var (cdr name) dtype)))) (t (error "invalid LOOP variable passed in: ~S" name)))) (defun loop-maybe-bind-form (form data-type) (if (loop-constantp form) form - (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) + (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) @@ -1138,11 +1099,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. 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 - (loop-when-it-variable))) + (loop-when-it-var))) (cdr *loop-source-code*)))) (cond ((or (not (setq data (loop-lookup-keyword key (loop-universe-keywords *loop-universe*)))) @@ -1153,6 +1115,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. "~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) @@ -1190,16 +1153,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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)))) + (loop-emit-body (loop-construct-return (loop-get-form)))) ;;;; value accumulation: LIST (defstruct (loop-collector - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) name class (history nil) @@ -1215,11 +1178,15 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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)) @@ -1245,8 +1212,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars (setf (loop-collector-tempvars lc) - (setq tempvars (list* (loop-gentemp 'loop-list-head-) - (loop-gentemp 'loop-list-tail-) + (setq tempvars (list* (gensym "LOOP-LIST-HEAD-") + (gensym "LOOP-LIST-TAIL-") (and (loop-collector-name lc) (list (loop-collector-name lc)))))) (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) @@ -1269,9 +1236,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars (setf (loop-collector-tempvars lc) - (setq tempvars (list (loop-make-variable + (setq tempvars (list (loop-make-var (or (loop-collector-name lc) - (loop-gentemp 'loop-sum-)) + (gensym "LOOP-SUM-")) nil (loop-collector-dtype lc))))) (unless (loop-collector-name lc) (loop-emit-final-value (car (loop-collector-tempvars lc))))) @@ -1279,25 +1246,21 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (if (eq specifically 'count) `(when ,form (setq ,(car tempvars) - ,(hide-variable-reference t - (car tempvars) - `(1+ ,(car tempvars))))) + (1+ ,(car tempvars)))) `(setq ,(car tempvars) - (+ ,(hide-variable-reference t - (car tempvars) - (car tempvars)) + (+ ,(car tempvars) ,form))))))) (defun loop-maxmin-collection (specifically) (multiple-value-bind (lc form) - (loop-get-collection-info specifically 'maxmin *loop-real-data-type*) - (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) + (loop-get-collection-info specifically 'maxmin 'real) + (loop-check-data-type (loop-collector-dtype lc) 'real) (let ((data (loop-collector-data lc))) (unless data (setf (loop-collector-data lc) (setq data (make-loop-minimax (or (loop-collector-name lc) - (loop-gentemp 'loop-maxmin-)) + (gensym "LOOP-MAXMIN-")) (loop-collector-dtype lc)))) (unless (loop-collector-name lc) (loop-emit-final-value (loop-minimax-answer-variable data)))) @@ -1307,30 +1270,49 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ,specifically ,form))))) -;;;; value accumulation: aggregate booleans +;;;; value accumulation: aggregate booleans -;;; ALWAYS and NEVER +;;; handling the ALWAYS and NEVER loop keywords ;;; ;;; Under ANSI these are not permitted to appear under conditionalization. (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))) -;;; THEREIS +;;; handling the THEREIS loop keyword ;;; ;;; Under ANSI this is not permitted to appear under conditionalization. (defun loop-do-thereis (restrictive) (when restrictive (loop-disallow-conditional)) - (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) - ,(loop-construct-return *loop-when-it-variable*)))) + (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*)))) (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) @@ -1340,7 +1322,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (loop-pop-source) (loop-get-form)) (t nil))) - (loop-make-variable var val dtype) + (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) (return (loop-bind-block))))) @@ -1432,38 +1416,20 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. 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) - *loop-real-data-type*))) - (when (and (consp form) (eq (car form) 'the) (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-variable (loop-gentemp 'loop-repeat-) - number - type))) - (if constantp - `((not (plusp (setq ,var (1- ,var)))) - () () () () () () ()) - `((minusp (setq ,var (1- ,var))) - () () ())))))))) - -(defun loop-when-it-variable () - (or *loop-when-it-variable* - (setq *loop-when-it-variable* - (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) +(defun loop-when-it-var () + (or *loop-when-it-var* + (setq *loop-when-it-var* + (loop-make-var (gensym "LOOP-IT-") nil nil)))) ;;;; various FOR/AS subdispatches -;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN -;;; is omitted (other than being more stringent in its placement), and like the -;;; old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first -;;; initialization occurs in the loop body (first-step), not in the variable -;;; binding phase. +;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when +;;; the THEN is omitted (other than being more stringent in its +;;; placement), and like the old "FOR x FIRST y THEN z" when the THEN +;;; is present. I.e., the first initialization occurs in the loop body +;;; (first-step), not in the variable binding phase. (defun loop-ansi-for-equals (var val data-type) - (loop-make-iteration-variable var nil data-type) + (loop-make-iteration-var var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) ;; Then we are the same as "FOR x FIRST y THEN z". (loop-pop-source) @@ -1473,23 +1439,23 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. `(() (,var ,val) () ())))) (defun loop-for-across (var val data-type) - (loop-make-iteration-variable var nil data-type) - (let ((vector-var (loop-gentemp 'loop-across-vector-)) - (index-var (loop-gentemp 'loop-across-index-))) + (loop-make-iteration-var var nil data-type) + (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-")) + (index-var (gensym "LOOP-ACROSS-INDEX-"))) (multiple-value-bind (vector-form constantp vector-value) (loop-constant-fold-if-possible val 'vector) - (loop-make-variable + (loop-make-var vector-var vector-form (if (and (consp vector-form) (eq (car vector-form) 'the)) (cadr vector-form) 'vector)) - (loop-make-variable index-var 0 'fixnum) + (loop-make-var index-var 0 'fixnum) (let* ((length 0) (length-form (cond ((not constantp) - (let ((v (loop-gentemp 'loop-across-limit-))) + (let ((v (gensym "LOOP-ACROSS-LIMIT-"))) (push `(setq ,v (length ,vector-var)) *loop-prologue*) - (loop-make-variable v 0 'fixnum))) + (loop-make-var v 0 'fixnum))) (t (setq length (length vector-value))))) (first-test `(>= ,index-var ,length-form)) (other-test first-test) @@ -1507,9 +1473,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; list iteration (defun loop-list-step (listvar) - ;; We are not equipped to analyze whether 'FOO is the same as #'FOO here in - ;; any sensible fashion, so let's give an obnoxious warning whenever 'FOO is - ;; used as the stepping function. + ;; We are not equipped to analyze whether 'FOO is the same as #'FOO + ;; here in any sensible fashion, so let's give an obnoxious warning + ;; whenever 'FOO is used as the stepping function. ;; ;; While a Discerning Compiler may deal intelligently with ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP @@ -1524,9 +1490,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ((and (consp stepper) (eq (car stepper) 'function)) (list (cadr stepper) listvar)) (t - `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) - stepper - 'function) + `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) ,listvar))))) (defun loop-for-on (var val data-type) @@ -1534,24 +1498,22 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) - (loop-make-iteration-variable var list data-type)) - (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list) - (loop-make-iteration-variable var nil data-type))) + (loop-make-iteration-var var list data-type)) + (t (loop-make-var (setq listvar (gensym)) list 'list) + (loop-make-iteration-var var nil data-type))) (let ((list-step (loop-list-step listvar))) (let* ((first-endtest - (hide-variable-reference - (eq var listvar) - listvar - ;; the following should use `atom' instead of `endp', per - ;; [bug2428] - `(atom ,listvar))) + ;; mysterious comment from original CMU CL sources: + ;; the following should use `atom' instead of `endp', + ;; per [bug2428] + `(atom ,listvar)) (other-endtest first-endtest)) (when (and constantp (listp list-value)) (setq first-endtest (null list-value))) (cond ((eq var listvar) - ;; Contour of the loop is different because we use the user's - ;; variable... - `(() (,listvar ,(hide-variable-reference t listvar list-step)) + ;; The contour of the loop is different because we + ;; use the user's variable... + `(() (,listvar ,list-step) ,other-endtest () () () ,first-endtest ())) (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) @@ -1562,9 +1524,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-for-in (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) - (let ((listvar (loop-gentemp 'loop-list-))) - (loop-make-iteration-variable var nil data-type) - (loop-make-variable listvar list 'list) + (let ((listvar (gensym "LOOP-LIST-"))) + (loop-make-iteration-var var nil data-type) + (loop-make-var listvar list 'list) (let ((list-step (loop-list-step listvar))) (let* ((first-endtest `(endp ,listvar)) (other-endtest first-endtest) @@ -1579,8 +1541,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; iteration paths (defstruct (loop-path - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) names preposition-groups inclusive-permitted @@ -1589,8 +1551,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) - (unless (listp names) (setq names (list names))) - (check-type universe loop-universe) + (declare (type loop-universe universe)) + (unless (listp names) + (setq names (list names))) (let ((ht (loop-universe-path-keywords universe)) (lp (make-loop-path :names (mapcar #'symbol-name names) @@ -1604,7 +1567,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (setf (gethash (symbol-name name) ht) lp)) lp)) -;;; Note: path functions are allowed to use loop-make-variable, hack +;;; Note: Path functions are allowed to use LOOP-MAKE-VAR, hack ;;; the prologue, etc. (defun loop-for-being (var val data-type) ;; FOR var BEING each/the pathname prep-phrases using-stuff... each/the = @@ -1644,30 +1607,30 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (setq stuff (if inclusive (apply fun var data-type preps :inclusive t user-data) (apply fun var data-type preps user-data)))) - (when *loop-named-variables* - (loop-error "Unused USING variables: ~S." *loop-named-variables*)) - ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the - ;; system from the user and the user from himself. + (when *loop-named-vars* + (loop-error "Unused USING vars: ~S." *loop-named-vars*)) + ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). + ;; Protect the system from the user and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." path)) (do ((l (car stuff) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) - (loop-make-iteration-variable x nil nil) - (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (loop-make-iteration-var x nil nil) + (loop-make-iteration-var (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) -(defun named-variable (name) - (let ((tem (loop-tassoc name *loop-named-variables*))) +(defun loop-named-var (name) + (let ((tem (loop-tassoc name *loop-named-vars*))) (declare (list tem)) - (cond ((null tem) (values (loop-gentemp) nil)) - (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (cond ((null tem) (values (gensym) nil)) + (t (setq *loop-named-vars* (delete tem *loop-named-vars*)) (values (cdr tem) t))))) (defun loop-collect-prepositional-phrases (preposition-groups &optional - USING-allowed + using-allowed initial-phrases) (flet ((in-group-p (x group) (car (loop-tmember x group)))) (do ((token nil) @@ -1675,9 +1638,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (this-group nil nil) (this-prep nil nil) (disallowed-prepositions - (mapcan #'(lambda (x) - (copy-list - (find (car x) preposition-groups :test #'in-group-p))) + (mapcan (lambda (x) + (copy-list + (find (car x) preposition-groups :test #'in-group-p))) initial-phrases)) (used-prepositions (mapcar #'car initial-phrases))) ((null *loop-source-code*) (nreverse prepositional-phrases)) @@ -1698,22 +1661,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (cons this-group used-prepositions))) (loop-pop-source) (push (list this-prep (loop-get-form)) prepositional-phrases)) - ((and USING-allowed (loop-tequal token 'using)) + ((and using-allowed (loop-tequal token 'using)) (loop-pop-source) (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) - (when (or (atom z) - (atom (cdr z)) - (not (null (cddr z))) - (not (symbolp (car z))) - (and (cadr z) (not (symbolp (cadr z))))) - (loop-error "~S bad variable pair in path USING phrase" z)) (when (cadr z) - (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) + (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." (car z) (cadr z) (cadr tem)) - (push (cons (car z) (cadr z)) *loop-named-variables*))) + (push (cons (car z) (cadr z)) *loop-named-vars*))) (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) (return nil)))) @@ -1721,12 +1678,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; master sequencer function -(defun loop-sequencer (indexv indexv-type indexv-user-specified-p - variable variable-type - sequence-variable sequence-type - step-hack default-top - prep-phrases) - (let ((endform nil) ; Form (constant or variable) with limit value +(defun loop-sequencer (indexv indexv-type + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) + (let ((endform nil) ; form (constant or variable) with limit value (sequencep nil) ; T if sequence arg has been provided (testfn nil) ; endtest function (test nil) ; endtest form @@ -1742,104 +1699,133 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (limit-constantp nil) (limit-value nil) ) - (when variable (loop-make-iteration-variable 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-variable 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-variable 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-variable - (loop-gentemp '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-variable (setq stepby (loop-gentemp '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-variable - 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-variable (setq endform - (loop-gentemp '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 - (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) - (when step-hack - (setq step-hack - `(,variable ,(hide-variable-reference indexv-user-specified-p - indexv - 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 ,(hide-variable-reference 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 *loop-real-data-type*) t - nil nil nil nil nil nil - (loop-collect-prepositional-phrases - '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) - nil (list (list kwd val))))) + 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)) + nil (list (list kwd val))))) (defun loop-sequence-elements-path (variable data-type prep-phrases &key @@ -1847,16 +1833,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. size-function sequence-type element-type) - (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) - (let ((sequencev (named-variable 'sequence))) + (multiple-value-bind (indexv) (loop-named-var 'index) + (let ((sequencev (loop-named-var 'sequence))) (list* nil nil ; dummy bindings and prologue (loop-sequencer - indexv 'fixnum indexv-user-specified-p - variable (or data-type element-type) - sequencev sequence-type - `(,fetch-function ,sequencev ,indexv) - `(,size-function ,sequencev) - prep-phrases))))) + indexv 'fixnum + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) + `(,size-function ,sequencev) + prep-phrases))))) ;;;; builtin LOOP iteration paths @@ -1868,69 +1854,76 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ||# (defun loop-hash-table-iteration-path (variable data-type prep-phrases - &key which) - (check-type which (member hash-key hash-value)) + &key (which (sb!int:missing-arg))) + (declare (type (member :hash-key :hash-value) which)) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) - (loop-error "Too many prepositions!")) + (loop-error "too many prepositions!")) ((null prep-phrases) (loop-error "missing OF or IN in ~S iteration path"))) - (let ((ht-var (loop-gentemp 'loop-hashtab-)) - (next-fn (loop-gentemp 'loop-hashtab-next-)) + (let ((ht-var (gensym "LOOP-HASHTAB-")) + (next-fn (gensym "LOOP-HASHTAB-NEXT-")) (dummy-predicate-var nil) (post-steps nil)) (multiple-value-bind (other-var other-p) - (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) - ;; @@@@ named-variable returns a second value of T if the name was - ;; actually specified, so clever code can throw away the gensym'ed up - ;; variable if it isn't really needed. The following is for those - ;; implementations in which we cannot put dummy NILs into - ;; multiple-value-setq variable lists. + (loop-named-var (ecase which + (:hash-key 'hash-value) + (:hash-value 'hash-key))) + ;; @@@@ LOOP-NAMED-VAR returns a second value of T if the name + ;; was actually specified, so clever code can throw away the + ;; GENSYM'ed-up variable if it isn't really needed. The + ;; following is for those implementations in which we cannot put + ;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists. (setq other-p t - dummy-predicate-var (loop-when-it-variable)) - (let ((key-var nil) - (val-var nil) - (bindings `((,variable nil ,data-type) - (,ht-var ,(cadar prep-phrases)) - ,@(and other-p other-var `((,other-var nil)))))) - (if (eq which 'hash-key) - (setq key-var variable val-var (and other-p other-var)) - (setq key-var (and other-p other-var) val-var variable)) + dummy-predicate-var (loop-when-it-var)) + (let* ((key-var nil) + (val-var nil) + (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-"))) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (ecase which + (:hash-key (setq key-var variable + val-var (and other-p other-var))) + (: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 (loop-gentemp 'loop-hash-key-temp-)) - ,@post-steps)) - (push `(,key-var nil) bindings)) - (when (consp val-var) - (setq post-steps - `(,val-var ,(setq val-var (loop-gentemp '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 &key symbol-types) - (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (cond ((and prep-phrases (cdr prep-phrases)) (loop-error "Too many prepositions!")) - ((null prep-phrases) - (loop-error "missing OF or IN in ~S iteration path"))) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (sb!int:bug "Unknown preposition ~S." (caar prep-phrases)))) (unless (symbolp variable) (loop-error "Destructuring is not valid for package symbol iteration.")) - (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) - (next-fn (loop-gentemp 'loop-pkgsym-next-))) + (let ((pkg-var (gensym "LOOP-PKGSYM-")) + (next-fn (gensym "LOOP-PKGSYM-NEXT-")) + (variable (or variable (gensym "LOOP-PKGSYM-VAR-"))) + (package (or (cadar prep-phrases) '*package*))) (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) - `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases))) + `(((,variable nil ,data-type) (,pkg-var ,package)) () () () - (not (multiple-value-setq (,(loop-when-it-variable) + (not (multiple-value-setq (,(loop-when-it-var) ,variable) (,next-fn))) ()))) @@ -1939,7 +1932,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun make-ansi-loop-universe (extended-p) (let ((w (make-standard-loop-universe - :keywords `((named (loop-do-named)) + :keywords '((named (loop-do-named)) (initially (loop-do-initially)) (finally (loop-do-finally)) (do (loop-do-do)) @@ -1952,10 +1945,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (nconc (loop-list-collection nconc)) (nconcing (loop-list-collection nconc)) (count (loop-sum-collection count - ,*loop-real-data-type* + real fixnum)) (counting (loop-sum-collection count - ,*loop-real-data-type* + real fixnum)) (sum (loop-sum-collection sum number number)) (summing (loop-sum-collection sum number number)) @@ -1971,7 +1964,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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)) @@ -1980,12 +1974,14 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (downfrom (loop-for-arithmetic :downfrom)) (upfrom (loop-for-arithmetic :upfrom)) (below (loop-for-arithmetic :below)) + (above (loop-for-arithmetic :above)) (to (loop-for-arithmetic :to)) (upto (loop-for-arithmetic :upto)) + (downto (loop-for-arithmetic :downto)) + (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 @@ -2000,11 +1996,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil - :user-data '(:which hash-key)) + :user-data '(:which :hash-key)) (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil - :user-data '(:which hash-value)) + :user-data '(:which :hash-value)) (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil @@ -2020,7 +2016,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil - :user-data '(:symbol-types (:internal))) + :user-data '(:symbol-types (:internal + :external))) w)) (defparameter *loop-ansi-universe* @@ -2028,16 +2025,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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!kernel:defmacro-mundanely loop (&environment env &rest keywords-and-forms) +(sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms) (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) -(sb!kernel:defmacro-mundanely loop-finish () +(sb!int:defmacro-mundanely loop-finish () #!+sb-doc - "Causes the iteration to terminate \"normally\", the same as implicit + "Cause the iteration to terminate \"normally\", the same as implicit termination by an iteration driving clause, or by use of WHILE or UNTIL -- the epilogue code (if any) will be run, and any implicitly collected result will be returned as the value of the LOOP."