X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=3d9a363c6dee9d825b18ccc0f54083f93d43b690;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=9f8ca8a9f0df9e6545b27f856b56208772958b82;hpb=5d18b03968d5fc696790609ae0ac2669473fbfb7;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 9f8ca8a..3d9a363 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -326,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 @@ -345,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!int:defmacro-mundanely loop-really-desetq (&environment env - &rest var-val-pairs) + &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) @@ -365,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 @@ -399,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) @@ -432,37 +423,34 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defvar *loop-macro-environment*) ;;; This holds variable names specified with the USING clause. -;;; See LOOP-NAMED-VARIABLE. -(defvar *loop-named-variables*) +;;; See LOOP-NAMED-VAR. +(defvar *loop-named-vars*) -;;; LETlist-like list being accumulated for one group of parallel bindings. -(defvar *loop-variables*) +;;; LETlist-like list being accumulated for current group of bindings. +(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*) ;;; This is used by LOOP for destructuring binding, if it is doing -;;; that itself. See LOOP-MAKE-VARIABLE. +;;; 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 have as its value +;;; *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-VARIABLES* (This is -;;; why the wrappers go inside of the variable bindings). +;;; 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 +;;; 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 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 (defvar *loop-prologue*) @@ -488,8 +476,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defvar *loop-after-epilogue*) ;;; the "culprit" responsible for supplying a final value from the -;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple -;;; return values being supplied. +;;; loop. This is so LOOP-DISALLOW-AGGREGATE-BOOLEANS can moan about +;;; disallowed anonymous collections. (defvar *loop-final-value-culprit*) ;;; If this is true, we are in some branch of a conditional. Some @@ -499,14 +487,14 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;; 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*) +(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-variable*) +(defvar *loop-never-stepped-var*) ;;; list of all the value-accumulation descriptor structures in the ;;; loop. See LOOP-GET-COLLECTION-INFO. @@ -520,7 +508,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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))) @@ -533,7 +522,7 @@ 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) @@ -543,6 +532,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;; 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)))) @@ -581,26 +575,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) @@ -621,7 +616,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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))) @@ -639,9 +634,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* @@ -717,12 +712,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))) @@ -745,10 +738,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~}." @@ -769,14 +761,37 @@ 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-named-variables* nil) + (*loop-vars* nil) + (*loop-named-vars* nil) (*loop-declarations* nil) (*loop-desetq-crocks* nil) (*loop-bind-stack* nil) @@ -790,8 +805,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) @@ -803,9 +818,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)) @@ -817,20 +829,18 @@ 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 () - (do () ((null *loop-source-code*)) + (do () + ((null *loop-source-code*)) (let ((keyword (car *loop-source-code*)) (tem nil)) (cond ((not (symbolp keyword)) (loop-error "~S found where LOOP keyword expected" keyword)) @@ -861,17 +871,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)) @@ -884,43 +902,49 @@ 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*) - (when *loop-final-value-culprit* - (loop-warn "The LOOP clause is providing a value for the iteration,~@ - however one was already established by a ~S clause." - *loop-final-value-culprit*)) +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) (setq *loop-final-value-culprit* (car *loop-source-context*))) (defun loop-disallow-conditional (&optional kwd) (when *loop-inside-conditional* (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + +(defun loop-disallow-anonymous-collectors () + (when (find-if-not 'loop-collector-name *loop-collection-cruft*) + (loop-error "This LOOP clause is not permitted with anonymous collectors."))) + +(defun loop-disallow-aggregate-booleans () + (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) + (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) ;;;; loop types -(defun loop-typed-init (data-type) +(defun loop-typed-init (data-type &optional step-var-p) (when (and data-type (sb!xc:subtypep data-type 'number)) (if (or (sb!xc:subtypep data-type 'float) (sb!xc:subtypep data-type '(complex float))) - (coerce 0 data-type) - 0))) + (coerce (if step-var-p 1 0) data-type) + (if step-var-p 1 0)))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. (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*)) @@ -931,11 +955,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) @@ -974,83 +999,83 @@ 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 step-var-p) (cond ((null name) - (cond ((not (null initialization)) - (push (list (setq name (gensym "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*) - (loop-error "duplicated LOOP iteration variable ~S" name) - (push name *loop-iteration-variables*))) - ((assoc name *loop-variables*) - (loop-error "duplicated variable ~S in LOOP parallel binding" - name))) + (when (or (assoc name *loop-vars*) + (loop-var-p name)) + (loop-error "duplicated variable ~S in a LOOP 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 (gensym "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*)))))) + (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) + (loop-make-var (cdr name) nil tcdr)))) name) -(defun loop-make-iteration-variable (name initialization dtype) - (loop-make-variable 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 (sb!xc:subtypep t dtype) - (let ((dtype (let ((init (loop-typed-init dtype))) + (let ((dtype (let ((init (loop-typed-init dtype step-var-p))) (if (sb!xc:typep init dtype) dtype `(or (member ,init) ,dtype))))) (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 (gensym "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) @@ -1060,11 +1085,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*)))) @@ -1075,6 +1101,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) @@ -1112,10 +1139,10 @@ 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 @@ -1137,11 +1164,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)) @@ -1149,12 +1180,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (t (unless (eq (loop-collector-class cruft) class) (loop-error "incompatible kinds of LOOP value accumulation specified for collecting~@ - ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" name (car (loop-collector-history cruft)) collector)) (unless (equal dtype (loop-collector-dtype cruft)) (loop-warn "unequal datatypes specified in different LOOP value accumulations~@ - into ~S: ~S and ~S" + into ~S: ~S and ~S" name dtype (loop-collector-dtype cruft)) (when (eq (loop-collector-dtype cruft) t) (setf (loop-collector-dtype cruft) dtype))) @@ -1191,7 +1222,7 @@ 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) (gensym "LOOP-SUM-")) nil (loop-collector-dtype lc))))) @@ -1233,6 +1264,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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))) @@ -1242,23 +1274,44 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;; 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) + (do ((var) (val) (dtype)) + (nil) (setq var (loop-pop-source) dtype (loop-optional-type var) val (cond ((loop-tequal (car *loop-source-code*) :=) (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))))) @@ -1350,40 +1403,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) - '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-variable (gensym "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 (gensym "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-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) @@ -1393,23 +1426,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) + (loop-make-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 (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) @@ -1427,9 +1460,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 @@ -1444,9 +1477,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 (gensym "LOOP-FN-") - stepper - 'function) + `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) ,listvar))))) (defun loop-for-on (var val data-type) @@ -1454,9 +1485,10 @@ 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 (gensym)) list 'list) - (loop-make-iteration-variable var nil data-type))) + (loop-make-var var list data-type)) + (t + (loop-make-var (setq listvar (gensym)) list 't) + (loop-make-var var nil data-type))) (let ((list-step (loop-list-step listvar))) (let* ((first-endtest ;; mysterious comment from original CMU CL sources: @@ -1481,8 +1513,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar (gensym "LOOP-LIST-"))) - (loop-make-iteration-variable var nil data-type) - (loop-make-variable listvar list 'list) + (loop-make-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) @@ -1523,7 +1555,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 = @@ -1563,30 +1595,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-var x nil nil) + (loop-make-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 (gensym) nil)) - (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (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) @@ -1594,9 +1626,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)) @@ -1617,22 +1649,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." + 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)))) @@ -1640,12 +1666,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 @@ -1661,102 +1687,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 - (gensym "LOOP-LIMIT-") form indexv-type)))) - (:by - (multiple-value-setq (form stepby-constantp stepby) - (loop-constant-fold-if-possible form indexv-type)) - (unless stepby-constantp - (loop-make-variable (setq stepby (gensym "LOOP-STEP-BY-")) - form - indexv-type))) - (t (loop-error - "~S invalid preposition in sequencing or sequence path;~@ - maybe invalid prepositions were specified in iteration path descriptor?" - prep))) - (when (and odir dir (not (eq dir odir))) - (loop-error "conflicting stepping directions in LOOP sequencing path")) - (setq odir dir)) - (when (and sequence-variable (not sequencep)) - (loop-error "missing OF or IN phrase in sequence path")) - ;; Now fill in the defaults. - (unless start-given - (loop-make-iteration-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 - (gensym "LOOP-SEQ-LIMIT-")) - nil indexv-type) - (push `(setq ,endform ,default-top) *loop-prologue*)) - (setq testfn (if inclusive-iteration '> '>=))) - (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) - (t (unless start-given - (unless default-top - (loop-error "don't know where to start stepping")) - (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) - (when (and default-top (not endform)) - (setq endform (loop-typed-init indexv-type) - inclusive-iteration t)) - (when endform (setq testfn (if inclusive-iteration '< '<=))) - (setq step - (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) - (when testfn - (setq test - `(,testfn ,indexv ,endform))) - (when step-hack - (setq step-hack - `(,variable ,step-hack))) - (let ((first-test test) (remaining-tests test)) - (when (and stepby-constantp start-constantp limit-constantp) - (when (setq first-test - (funcall (symbol-function testfn) - start-value - limit-value)) - (setq remaining-tests t))) - `(() (,indexv ,step) - ,remaining-tests ,step-hack () () ,first-test ,step-hack)))) + (flet ((assert-index-for-arithmetic (index) + (unless (atom index) + (loop-error "Arithmetic index must be an atom.")))) + (when variable (loop-make-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-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))) + 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-var + indexv + (setq start-constantp t + start-value (or (loop-typed-init indexv-type) 0)) + `(and ,indexv-type real))))) + (cond ((member dir '(nil :up)) + (when (or limit-given default-top) + (unless limit-given + (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-")) + nil + indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "don't know where to start stepping")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) + inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step + (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when testfn + (setq test + `(,testfn ,indexv ,endform))) + (when step-hack + (setq step-hack + `(,variable ,step-hack))) + (let ((first-test test) (remaining-tests test)) + (when (and stepby-constantp start-constantp limit-constantp + (realp start-value) (realp limit-value)) + (when (setq first-test + (funcall (symbol-function testfn) + start-value + limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,step) + ,remaining-tests ,step-hack () () ,first-test ,step-hack))))) ;;;; interfaces to the master sequencer (defun loop-for-arithmetic (var val data-type kwd) (loop-sequencer - var (loop-check-data-type data-type 'real) 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 @@ -1764,16 +1821,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 @@ -1785,7 +1842,7 @@ 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 (required-argument))) + &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!")) @@ -1796,58 +1853,65 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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 (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 &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 (gensym "LOOP-PKGSYM-")) - (next-fn (gensym "LOOP-PKGSYM-NEXT-"))) + (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))) ()))) @@ -1888,7 +1952,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)) @@ -1897,12 +1962,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 @@ -1937,7 +2004,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* @@ -1945,9 +2013,9 @@ 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!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms) (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))