X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=4be06cbe0e66f992a5386f214b0998da34b30fc7;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=1df85e1ecad60a789e10a1c246017a850dbe71b5;hpb=f4f18b9dcdaf1948947b1747f5bfa766a1a0ee4c;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 1df85e1..4be06cb 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,36 +423,36 @@ 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*) +(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., +;;; *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 +;;; 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 +;;; 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*) +(defvar *loop-iteration-vars*) ;;; list of prologue forms of the loop, accumulated in reverse order (defvar *loop-prologue*) @@ -499,14 +490,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 +511,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 +525,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 +535,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)))) @@ -622,7 +619,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))) @@ -718,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))) @@ -746,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~}." @@ -770,14 +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-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) @@ -791,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) @@ -804,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)) @@ -818,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 () @@ -862,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)) @@ -885,17 +905,26 @@ 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 @@ -977,60 +1006,64 @@ 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) (cond ((null name) (cond ((not (null initialization)) (push (list (setq name (gensym "LOOP-IGNORE-")) initialization) - *loop-variables*) + *loop-vars*) (push `(ignore ,name) *loop-declarations*)))) ((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) ;; 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*)) + *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 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) (cond ((or (null name) (null dtype) (eq dtype t)) nil) ((symbolp name) (unless (sb!xc:subtypep t dtype) @@ -1041,19 +1074,22 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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) @@ -1063,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*)))) @@ -1078,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) @@ -1115,7 +1153,7 @@ 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)))) @@ -1140,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)) @@ -1194,7 +1236,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))))) @@ -1236,6 +1278,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))) @@ -1245,13 +1288,31 @@ 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) @@ -1261,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))))) @@ -1353,30 +1416,10 @@ 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 @@ -1386,7 +1429,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;; 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) @@ -1396,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) + (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 (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) @@ -1447,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 (gensym "LOOP-FN-") - stepper - 'function) + `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) ,listvar))))) (defun loop-for-on (var val data-type) @@ -1457,9 +1498,9 @@ 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-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 ;; mysterious comment from original CMU CL sources: @@ -1484,8 +1525,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-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) @@ -1526,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 = @@ -1566,8 +1607,8 @@ 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*)) + (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)) @@ -1575,21 +1616,21 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. 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 (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) @@ -1597,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)) @@ -1620,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)))) @@ -1648,7 +1683,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. sequence-variable sequence-type step-hack default-top prep-phrases) - (let ((endform nil) ; Form (constant or variable) with limit value + (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 @@ -1664,20 +1699,20 @@ 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)) + (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-variable sequence-variable form sequence-type)) + (loop-make-var sequence-variable form sequence-type)) ((:from :downfrom :upfrom) (setq start-given t) (cond ((eq prep :downfrom) (setq dir ':down)) ((eq prep :upfrom) (setq dir ':up))) (multiple-value-setq (form start-constantp start-value) (loop-constant-fold-if-possible form indexv-type)) - (loop-make-iteration-variable indexv form indexv-type)) + (loop-make-iteration-var indexv form indexv-type)) ((:upto :to :downto :above :below) (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) @@ -1688,21 +1723,22 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ((loop-tequal prep :below) (setq dir ':up))) (setq limit-given t) (multiple-value-setq (form limit-constantp limit-value) - (loop-constant-fold-if-possible form indexv-type)) + (loop-constant-fold-if-possible form `(and ,indexv-type real))) (setq endform (if limit-constantp `',limit-value - (loop-make-variable - (gensym "LOOP-LIMIT-") form indexv-type)))) + (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 indexv-type)) - (unless stepby-constantp - (loop-make-variable (setq stepby (gensym "LOOP-STEP-BY-")) - form - indexv-type))) + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form `(and ,indexv-type (real (0))))) + (unless stepby-constantp + (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) + form + `(and ,indexv-type (real (0)))))) (t (loop-error - "~S invalid preposition in sequencing or sequence path;~@ - maybe invalid prepositions were specified in iteration path descriptor?" + "~S invalid preposition in sequencing or sequence path;~@ + maybe invalid prepositions were specified in iteration path descriptor?" prep))) (when (and odir dir (not (eq dir odir))) (loop-error "conflicting stepping directions in LOOP sequencing path")) @@ -1710,18 +1746,33 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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)) + (if start-given + (when limit-given + ;; if both start and limit are given, they had better both + ;; be REAL. We already enforce the REALness of LIMIT, + ;; above; here's the KLUDGE to enforce the type of START. + (flet ((type-declaration-of (x) + (and (eq (car x) 'type) (caddr x)))) + (let ((decl (find indexv *loop-declarations* + :key #'type-declaration-of)) + (%decl (find indexv *loop-declarations* + :key #'type-declaration-of + :from-end t))) + (sb!int:aver (eq decl %decl)) + (setf (cadr decl) + `(and real ,(cadr decl)))))) + ;; default start + (loop-make-iteration-var + indexv + (setq start-constantp t + start-value (or (loop-typed-init indexv-type) 0)) + `(and ,indexv-type real))) (cond ((member dir '(nil :up)) (when (or limit-given default-top) (unless limit-given - (loop-make-variable (setq endform - (gensym "LOOP-SEQ-LIMIT-")) - nil indexv-type) + (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)))) @@ -1742,7 +1793,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (setq step-hack `(,variable ,step-hack))) (let ((first-test test) (remaining-tests test)) - (when (and stepby-constantp start-constantp limit-constantp) + (when (and stepby-constantp start-constantp limit-constantp + (realp start-value) (realp limit-value)) (when (setq first-test (funcall (symbol-function testfn) start-value @@ -1755,7 +1807,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-for-arithmetic (var val data-type kwd) (loop-sequencer - var (loop-check-data-type data-type 'real) + var (loop-check-data-type data-type 'number) nil nil nil nil nil nil (loop-collect-prepositional-phrases '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) @@ -1767,8 +1819,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. size-function sequence-type element-type) - (multiple-value-bind (indexv) (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 @@ -1788,7 +1840,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!")) @@ -1799,62 +1851,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 (ecase which + (loop-named-var (ecase which (:hash-key 'hash-value) (:hash-value 'hash-key))) - ;; @@@@ NAMED-VARIABLE returns a second value of T if the name + ;; @@@@ 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)))))) + 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))) ()))) @@ -1895,7 +1950,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)) @@ -1904,12 +1960,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 @@ -1944,7 +2002,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* @@ -1952,9 +2011,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*))