;;;; This code was modified by William Harold Newman beginning
;;;; 19981106, originally to conform to the new SBCL bootstrap package
;;;; system and then subsequently to address other cross-compiling
-;;;; bootstrap issues. Whether or not it then supported all the
-;;;; environments implied by the reader conditionals in the source
-;;;; code (e.g. #!+CLOE-RUNTIME) before that modification, it sure
-;;;; doesn't now: it might be appropriate for CMU-CL-derived systems
-;;;; in general but only claims to be appropriate for the particular
-;;;; branch I was working on.
+;;;; bootstrap issues, SBCLification (e.g. DECLARE used to check
+;;;; argument types), and other maintenance. Whether or not it then
+;;;; supported all the environments implied by the reader conditionals
+;;;; in the source code (e.g. #!+CLOE-RUNTIME) before that
+;;;; modification, it sure doesn't now. It might perhaps, by blind
+;;;; luck, be appropriate for some other CMU-CL-derived system, but
+;;;; really it only attempts to be appropriate for SBCL.
;;;; This software is derived from software originally released by the
;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and
;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been
;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too.
\f
-;;;; miscellaneous environment things
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *loop-real-data-type* 'real))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *loop-gentemp* nil)
- (defun loop-gentemp (&optional (pref 'loopvar-))
- (if *loop-gentemp*
- (gentemp (string pref))
- (gensym))))
-
-;;; @@@@ The following form takes a list of variables and a form which
-;;; presumably references those variables, and wraps it somehow so that the
-;;; compiler does not consider those variables have been referenced. The intent
-;;; of this is that iteration variables can be flagged as unused by the
-;;; compiler, e.g. I in (loop for i from 1 to 10 do (print t)), since we will
-;;; tell it when a usage of it is "invisible" or "not to be considered".
-;;;
-;;; We implicitly assume that a setq does not count as a reference. That is,
-;;; the kind of form generated for the above loop construct to step I,
-;;; simplified, is
-;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))).
-;;;
-;;; FIXME: This is a no-op except for Genera, now obsolete, so it
-;;; can be removed.
-(defun hide-variable-references (variable-list form)
- (declare (ignore variable-list))
- form)
-
-;;; @@@@ The following function takes a flag, a variable, and a form which
-;;; presumably references that variable, and wraps it somehow so that the
-;;; compiler does not consider that variable to have been referenced. The
-;;; intent of this is that iteration variables can be flagged as unused by the
-;;; compiler, e.g. I in (loop for i from 1 to 10 do (print t)), since we will
-;;; tell it when a usage of it is "invisible" or "not to be considered".
-;;;
-;;; We implicitly assume that a setq does not count as a reference. That is,
-;;; the kind of form generated for the above loop construct to step I,
-;;; simplified, is
-;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))).
-;;;
-;;; Certain cases require that the "invisibility" of the reference be
-;;; conditional upon something. This occurs in cases of "named" variables (the
-;;; USING clause). For instance, we want IDX in (LOOP FOR E BEING THE
-;;; VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) to be "invisible" when it is
-;;; stepped, so that the user gets informed if IDX is not referenced. However,
-;;; if no USING clause is present, we definitely do not want to be informed
-;;; that some gensym or other is not used.
-;;;
-;;; It is easier for the caller to do this conditionally by passing a flag
-;;; (which happens to be the second value of NAMED-VARIABLE, q.v.) to this
-;;; function than for all callers to contain the conditional invisibility
-;;; construction.
-;;;
-;;; FIXME: This is a no-op except for Genera, now obsolete, so it
-;;; can be removed.
-(defun hide-variable-reference (really-hide variable form)
- (declare (ignore really-hide variable))
- form)
-\f
;;;; list collection macrology
-(sb!kernel:defmacro-mundanely with-loop-list-collection-head
+(sb!int:defmacro-mundanely with-loop-list-collection-head
((head-var tail-var &optional user-head-var) &body body)
(let ((l (and user-head-var (list (list user-head-var nil)))))
`(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
,@body)))
-(sb!kernel:defmacro-mundanely loop-collect-rplacd
+(sb!int:defmacro-mundanely loop-collect-rplacd
(&environment env (head-var tail-var &optional user-head-var) form)
(setq form (sb!xc:macroexpand form env))
(flet ((cdr-wrap (form n)
(setq ,user-head-var (cdr ,head-var)))))
answer))))
-(sb!kernel:defmacro-mundanely loop-collect-answer (head-var
+(sb!int:defmacro-mundanely loop-collect-answer (head-var
&optional user-head-var)
(or user-head-var
`(cdr ,head-var)))
infinity-data)
(defvar *loop-minimax-type-infinities-alist*
- ;; Note: In the portable loop.lisp, this had various
- ;; conditional-on-*FEATURES* cases to support machines which had true
- ;; floating infinity. Now that we're limited to CMU CL, this is irrelevant.
- ;; FIXME: Or is it? What if we ever support infinity? Perhaps we should
- ;; put in something conditional on SB-INFINITY or something?
+ ;; FIXME: Now that SBCL supports floating point infinities again, we
+ ;; should have floating point infinities here, as cmucl-2.4.8 did.
'((fixnum most-positive-fixnum most-negative-fixnum)))
(defun make-loop-minimax (answer-variable type)
(let ((infinity-data (cdr (assoc type
*loop-minimax-type-infinities-alist*
- :test #'subtypep))))
+ :test #'sb!xc:subtypep))))
(make-loop-minimax-internal
:answer-variable answer-variable
:type type
- :temp-variable (loop-gentemp 'loop-maxmin-temp-)
+ :temp-variable (gensym "LOOP-MAXMIN-TEMP-")
:flag-variable (and (not infinity-data)
- (loop-gentemp 'loop-maxmin-flag-))
+ (gensym "LOOP-MAXMIN-FLAG-"))
:operations nil
:infinity-data infinity-data)))
(when (and (cdr (loop-minimax-operations minimax))
(not (loop-minimax-flag-variable minimax)))
(setf (loop-minimax-flag-variable minimax)
- (loop-gentemp 'loop-maxmin-flag-)))
+ (gensym "LOOP-MAXMIN-FLAG-")))
operation)
-(sb!kernel:defmacro-mundanely with-minimax-value (lm &body body)
+(sb!int:defmacro-mundanely with-minimax-value (lm &body body)
(let ((init (loop-typed-init (loop-minimax-type lm)))
(which (car (loop-minimax-operations lm)))
(infinity-data (loop-minimax-infinity-data lm))
(declare (type ,type ,answer-var ,temp-var))
,@body))))
-(sb!kernel:defmacro-mundanely loop-accumulate-minimax-value (lm
- operation
- form)
+(sb!int:defmacro-mundanely loop-accumulate-minimax-value (lm operation form)
(let* ((answer-var (loop-minimax-answer-variable lm))
(temp-var (loop-minimax-temp-variable lm))
(flag-var (loop-minimax-flag-variable lm))
- (test
- (hide-variable-reference
- t (loop-minimax-answer-variable lm)
- `(,(ecase operation
- (min '<)
- (max '>))
- ,temp-var ,answer-var))))
+ (test `(,(ecase operation
+ (min '<)
+ (max '>))
+ ,temp-var ,answer-var)))
`(progn
(setq ,temp-var ,form)
(when ,(if flag-var `(or (not ,flag-var) ,test) test)
(and (symbolp loop-token)
(values (gethash (symbol-name loop-token) table))))
-(sb!kernel:defmacro-mundanely loop-store-table-data (symbol table datum)
+(sb!int:defmacro-mundanely loop-store-table-data (symbol table datum)
`(setf (gethash (symbol-name ,symbol) ,table) ,datum))
(defstruct (loop-universe
(:copier nil)
(:predicate nil))
- keywords ; hash table, value = (fn-name . extra-data)
- iteration-keywords ; hash table, value = (fn-name . extra-data)
- for-keywords ; hash table, value = (fn-name . extra-data)
- path-keywords ; hash table, value = (fn-name . extra-data)
- type-symbols ; hash table of type SYMBOLS, test EQ,
- ; value = CL type specifier
- type-keywords ; hash table of type STRINGS, test EQUAL,
- ; value = CL type spec
- ansi ; NIL, T, or :EXTENDED
+ keywords ; hash table, value = (fn-name . extra-data)
+ iteration-keywords ; hash table, value = (fn-name . extra-data)
+ for-keywords ; hash table, value = (fn-name . extra-data)
+ path-keywords ; hash table, value = (fn-name . extra-data)
+ type-symbols ; hash table of type SYMBOLS, test EQ,
+ ; value = CL type specifier
+ type-keywords ; hash table of type STRINGS, test EQUAL,
+ ; value = CL type spec
+ ansi ; NIL, T, or :EXTENDED
implicit-for-required) ; see loop-hack-iteration
(sb!int:def!method print-object ((u loop-universe) stream)
(let ((string (case (loop-universe-ansi u)
- ((nil) "Non-ANSI")
+ ((nil) "non-ANSI")
((t) "ANSI")
- (:extended "Extended-ANSI")
+ (:extended "extended-ANSI")
(t (loop-universe-ansi u)))))
(print-unreadable-object (u stream :type t)
(write-string string stream))))
(defun make-standard-loop-universe (&key keywords for-keywords
iteration-keywords path-keywords
type-keywords type-symbols ansi)
- (check-type ansi (member nil t :extended))
+ (declare (type (member nil t :extended) ansi))
(flet ((maketable (entries)
(let* ((size (length entries))
(ht (make-hash-table :size (if (< size 10) 10 size)
(setf (gethash (car x) ht) (cadr x))))
ht))))
\f
-;;;; 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
(defun loop-make-desetq (var-val-pairs)
(if (null var-val-pairs)
nil
- (cons (if *loop-destructuring-hooks*
- (cadr *loop-destructuring-hooks*)
- 'loop-really-desetq)
- var-val-pairs)))
+ (cons 'loop-really-desetq var-val-pairs)))
(defvar *loop-desetq-temporary*
(make-symbol "LOOP-DESETQ-TEMP"))
-(sb!kernel:defmacro-mundanely loop-really-desetq (&environment env
- &rest var-val-pairs)
+(sb!int:defmacro-mundanely loop-really-desetq (&environment env
+ &rest var-val-pairs)
(labels ((find-non-null (var)
- ;; see whether there's any non-null thing here
- ;; recurse if the list element is itself a list
+ ;; See whether there's any non-null thing here. Recurse
+ ;; if the list element is itself a list.
(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
(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
,@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)
\f
;;;; LOOP-local variables
-;;;This is the "current" pointer into the LOOP source code.
+;;; This is the "current" pointer into the LOOP source code.
(defvar *loop-source-code*)
-;;;This is the pointer to the original, for things like NAMED that
-;;;insist on being in a particular position
+;;; This is the pointer to the original, for things like NAMED that
+;;; insist on being in a particular position
(defvar *loop-original-source-code*)
-;;;This is *loop-source-code* as of the "last" clause. It is used
-;;;primarily for generating error messages (see loop-error, loop-warn).
+;;; This is *loop-source-code* as of the "last" clause. It is used
+;;; primarily for generating error messages (see loop-error, loop-warn).
(defvar *loop-source-context*)
-;;;List of names for the LOOP, supplied by the NAMED clause.
+;;; list of names for the LOOP, supplied by the NAMED clause
(defvar *loop-names*)
-;;;The macroexpansion environment given to the macro.
+;;; The macroexpansion environment given to the macro.
(defvar *loop-macro-environment*)
-;;;This holds variable names specified with the USING clause.
-;;; See LOOP-NAMED-VARIABLE.
-(defvar *loop-named-variables*)
+;;; This holds variable names specified with the USING clause.
+;;; See LOOP-NAMED-VAR.
+(defvar *loop-named-vars*)
;;; LETlist-like list being accumulated for one group of parallel bindings.
-(defvar *loop-variables*)
+(defvar *loop-vars*)
-;;;List of declarations being accumulated in parallel with
-;;;*loop-variables*.
+;;; list of declarations being accumulated in parallel with *LOOP-VARS*
(defvar *loop-declarations*)
-;;;Used by LOOP for destructuring binding, if it is doing that itself.
-;;; See loop-make-variable.
+;;; This is used by LOOP for destructuring binding, if it is doing
+;;; that itself. See LOOP-MAKE-VAR.
(defvar *loop-desetq-crocks*)
-;;; List of wrapping forms, innermost first, which go immediately inside
-;;; the current set of parallel bindings being accumulated in
-;;; *loop-variables*. The wrappers are appended onto a body. E.g.,
-;;; this list could conceivably has as its value ((with-open-file (g0001
-;;; g0002 ...))), with g0002 being one of the bindings in
-;;; *loop-variables* (this is why the wrappers go inside of the variable
-;;; bindings).
+;;; list of wrapping forms, innermost first, which go immediately
+;;; inside the current set of parallel bindings being accumulated in
+;;; *LOOP-VARS*. The wrappers are appended onto a body. E.g.,
+;;; this list could conceivably have as its value
+;;; ((WITH-OPEN-FILE (G0001 G0002 ...))),
+;;; with G0002 being one of the bindings in *LOOP-VARS* (This is
+;;; why the wrappers go inside of the variable bindings).
(defvar *loop-wrappers*)
-;;;This accumulates lists of previous values of *loop-variables* and the
-;;;other lists above, for each new nesting of bindings. See
-;;;loop-bind-block.
+;;; This accumulates lists of previous values of *LOOP-VARS* and
+;;; the other lists above, for each new nesting of bindings. See
+;;; LOOP-BIND-BLOCK.
(defvar *loop-bind-stack*)
-;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause
-;;;which inhibits LOOP from actually outputting a type declaration for
-;;;an iteration (or any) variable.
-(defvar *loop-nodeclare*)
+;;; This is simply a list of LOOP iteration variables, used for
+;;; checking for duplications.
+(defvar *loop-iteration-vars*)
-;;;This is simply a list of LOOP iteration variables, used for checking
-;;;for duplications.
-(defvar *loop-iteration-variables*)
-
-;;;List of prologue forms of the loop, accumulated in reverse order.
+;;; list of prologue forms of the loop, accumulated in reverse order
(defvar *loop-prologue*)
(defvar *loop-before-loop*)
(defvar *loop-body*)
(defvar *loop-after-body*)
-;;;This is T if we have emitted any body code, so that iteration driving
-;;;clauses can be disallowed. This is not strictly the same as
-;;;checking *loop-body*, because we permit some clauses such as RETURN
-;;;to not be considered "real" body (so as to permit the user to "code"
-;;;an abnormal return value "in loop").
+;;; This is T if we have emitted any body code, so that iteration
+;;; driving clauses can be disallowed. This is not strictly the same
+;;; as checking *LOOP-BODY*, because we permit some clauses such as
+;;; RETURN to not be considered "real" body (so as to permit the user
+;;; to "code" an abnormal return value "in loop").
(defvar *loop-emitted-body*)
-;;;List of epilogue forms (supplied by FINALLY generally), accumulated
-;;; in reverse order.
+;;; list of epilogue forms (supplied by FINALLY generally), accumulated
+;;; in reverse order
(defvar *loop-epilogue*)
-;;;List of epilogue forms which are supplied after the above "user"
-;;;epilogue. "normal" termination return values are provide by putting
-;;;the return form in here. Normally this is done using
-;;;loop-emit-final-value, q.v.
+;;; list of epilogue forms which are supplied after the above "user"
+;;; epilogue. "Normal" termination return values are provide by
+;;; putting the return form in here. Normally this is done using
+;;; LOOP-EMIT-FINAL-VALUE, q.v.
(defvar *loop-after-epilogue*)
-;;;The "culprit" responsible for supplying a final value from the loop.
-;;;This is so loop-emit-final-value can moan about multiple return
-;;;values being supplied.
+;;; the "culprit" responsible for supplying a final value from the
+;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple
+;;; return values being supplied.
(defvar *loop-final-value-culprit*)
-;;;If not NIL, we are in some branch of a conditional. Some clauses may
-;;;be disallowed.
+;;; If this is true, we are in some branch of a conditional. Some
+;;; clauses may be disallowed.
(defvar *loop-inside-conditional*)
-;;;If not NIL, this is a temporary bound around the loop for holding the
-;;;temporary value for "it" in things like "when (f) collect it". It
-;;;may be used as a supertemporary by some other things.
-(defvar *loop-when-it-variable*)
-
-;;;Sometimes we decide we need to fold together parts of the loop, but
-;;;some part of the generated iteration code is different for the first
-;;;and remaining iterations. This variable will be the temporary which
-;;;is the flag used in the loop to tell whether we are in the first or
-;;;remaining iterations.
-(defvar *loop-never-stepped-variable*)
-
-;;;List of all the value-accumulation descriptor structures in the loop.
-;;; See loop-get-collection-info.
-(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc)
+;;; If not NIL, this is a temporary bound around the loop for holding
+;;; the temporary value for "it" in things like "when (f) collect it".
+;;; It may be used as a supertemporary by some other things.
+(defvar *loop-when-it-var*)
+
+;;; Sometimes we decide we need to fold together parts of the loop,
+;;; but some part of the generated iteration code is different for the
+;;; first and remaining iterations. This variable will be the
+;;; temporary which is the flag used in the loop to tell whether we
+;;; are in the first or remaining iterations.
+(defvar *loop-never-stepped-var*)
+
+;;; list of all the value-accumulation descriptor structures in the
+;;; loop. See LOOP-GET-COLLECTION-INFO.
+(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc.)
\f
;;;; code analysis stuff
(when (setq constantp (constantp new-form))
(setq constant-value (eval new-form)))
(when (and constantp expected-type)
- (unless (typep constant-value expected-type)
- (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
+ (unless (sb!xc:typep constant-value expected-type)
+ (loop-warn "~@<The form ~S evaluated to ~S, which was not of ~
+ the anticipated type ~S.~:@>"
form constant-value expected-type)
(setq constantp nil constant-value nil)))
(values new-form constantp constant-value)))
(defvar *loop-duplicate-code*
nil)
-(defvar *loop-iteration-flag-variable*
+(defvar *loop-iteration-flag-var*
(make-symbol "LOOP-NOT-FIRST-TIME"))
(defun loop-code-duplication-threshold (env)
(declare (ignore env))
- (let (;; If we could read optimization declaration information (as with
- ;; the DECLARATION-INFORMATION function (present in CLTL2, removed
- ;; from ANSI standard) we could set these values flexibly. Without
- ;; DECLARATION-INFORMATION, we have to set them to constants.
+ (let (;; If we could read optimization declaration information (as
+ ;; with the DECLARATION-INFORMATION function (present in
+ ;; CLTL2, removed from ANSI standard) we could set these
+ ;; values flexibly. Without DECLARATION-INFORMATION, we have
+ ;; to set them to constants.
+ ;;
+ ;; except FIXME: we've lost all pretence of portability,
+ ;; considering this instead an internal implementation, so
+ ;; we're free to couple to our own representation of the
+ ;; environment.
(speed 1)
(space 1))
(+ 40 (* (- speed space) 10))))
-(sb!kernel:defmacro-mundanely loop-body (&environment env
+(sb!int:defmacro-mundanely loop-body (&environment env
prologue
before-loop
main-body
(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)
((or (not (setq inc (estimate-code-size (car bb) env)))
(> (incf count inc) threshold))
;; Ok, we have found a non-duplicatable piece of code.
- ;; Everything chronologically after it must be in the central
- ;; body. Everything chronologically at and after lastdiff goes
- ;; into the central body under a flag test.
+ ;; Everything chronologically after it must be in the
+ ;; central body. Everything chronologically at and
+ ;; after LASTDIFF goes into the central body under a
+ ;; flag test.
(let ((then nil) (else nil))
(do () (nil)
(push (pop rbefore) else)
(push (pop rafter) then)
(when (eq rbefore (cdr lastdiff)) (return)))
(unless flagvar
- (push `(setq ,(setq flagvar *loop-iteration-flag-variable*)
+ (push `(setq ,(setq flagvar *loop-iteration-flag-var*)
t)
else))
(push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
main-body))
;; Everything chronologically before lastdiff until the
- ;; non-duplicatable form (car bb) is the same in rbefore and
- ;; rafter so just copy it into the body
+ ;; non-duplicatable form (CAR BB) is the same in
+ ;; RBEFORE and RAFTER, so just copy it into the body.
(do () (nil)
(pop rafter)
(push (pop rbefore) main-body)
(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*
(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)))
((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~}."
&optional (default-type required-type))
(if (null specified-type)
default-type
- (multiple-value-bind (a b) (subtypep specified-type required-type)
+ (multiple-value-bind (a b) (sb!xc:subtypep specified-type required-type)
(cond ((not b)
(loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
specified-type required-type))
specified-type required-type)))
specified-type)))
\f
+(defun subst-gensyms-for-nil (tree)
+ (declare (special *ignores*))
+ (cond
+ ((null tree) (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*)))
+ ((atom tree) tree)
+ (t (cons (subst-gensyms-for-nil (car tree))
+ (subst-gensyms-for-nil (cdr tree))))))
+
+(sb!int:defmacro-mundanely loop-destructuring-bind
+ (lambda-list arg-list &rest body)
+ (let ((*ignores* nil))
+ (declare (special *ignores*))
+ (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list)))
+ `(destructuring-bind ,d-var-lambda-list
+ ,arg-list
+ (declare (ignore ,@*ignores*))
+ ,@body))))
+
+(defun loop-build-destructuring-bindings (crocks forms)
+ (if crocks
+ `((loop-destructuring-bind ,(car crocks) ,(cadr crocks)
+ ,@(loop-build-destructuring-bindings (cddr crocks) forms)))
+ forms))
+
(defun loop-translate (*loop-source-code*
*loop-macro-environment*
*loop-universe*)
(let ((*loop-original-source-code* *loop-source-code*)
(*loop-source-context* nil)
- (*loop-iteration-variables* nil)
- (*loop-variables* nil)
- (*loop-nodeclare* nil)
- (*loop-named-variables* nil)
+ (*loop-iteration-vars* nil)
+ (*loop-vars* nil)
+ (*loop-named-vars* nil)
(*loop-declarations* nil)
(*loop-desetq-crocks* nil)
(*loop-bind-stack* nil)
(*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)
,(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))
(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 ()
(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))
(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.")))
\f
;;;; loop types
(defun loop-typed-init (data-type)
- (when (and data-type (subtypep data-type 'number))
- (if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
+ (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)))
(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*))
(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)
;;;; 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 (loop-gentemp 'loop-ignore-))
+ (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 (loop-gentemp 'loop-destructure-)))
- (push (list newvar initialization) *loop-variables*)
- ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
- (setq *loop-desetq-crocks*
- (list* name newvar *loop-desetq-crocks*))
- ;; FIXME: We can delete this, right?
- #+ignore
- (loop-make-variable name
- nil
- dtype
- iteration-variable-p)))))
+ (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
+ (loop-declare-var name dtype)
+ (push (list newvar initialization) *loop-vars*)
+ ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
+ (setq *loop-desetq-crocks*
+ (list* name newvar *loop-desetq-crocks*))))
(t (let ((tcar nil) (tcdr nil))
(if (atom dtype) (setq tcar (setq tcdr dtype))
(setq tcar (car dtype) tcdr (cdr dtype)))
- (loop-make-variable (car name) nil tcar iteration-variable-p)
- (loop-make-variable (cdr name) nil tcdr iteration-variable-p))))
+ (loop-make-var (car name) nil tcar iteration-var-p)
+ (loop-make-var (cdr name) nil tcdr iteration-var-p))))
name)
-(defun loop-make-iteration-variable (name initialization dtype)
- (loop-make-variable name initialization dtype t))
+(defun loop-make-iteration-var (name initialization dtype)
+ (loop-make-var name initialization dtype t))
-(defun loop-declare-variable (name dtype)
+(defun loop-declare-var (name dtype)
(cond ((or (null name) (null dtype) (eq dtype t)) nil)
((symbolp name)
- (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
+ (unless (sb!xc:subtypep t dtype)
(let ((dtype (let ((init (loop-typed-init dtype)))
- (if (typep init dtype)
- dtype
- `(or (member ,init) ,dtype)))))
+ (if (sb!xc:typep init dtype)
+ dtype
+ `(or (member ,init) ,dtype)))))
(push `(type ,dtype ,name) *loop-declarations*))))
((consp name)
(cond ((consp dtype)
- (loop-declare-variable (car name) (car dtype))
- (loop-declare-variable (cdr name) (cdr dtype)))
- (t (loop-declare-variable (car name) dtype)
- (loop-declare-variable (cdr name) dtype))))
+ (loop-declare-var (car name) (car dtype))
+ (loop-declare-var (cdr name) (cdr dtype)))
+ (t (loop-declare-var (car name) dtype)
+ (loop-declare-var (cdr name) dtype))))
(t (error "invalid LOOP variable passed in: ~S" name))))
(defun loop-maybe-bind-form (form data-type)
(if (loop-constantp form)
form
- (loop-make-variable (loop-gentemp 'loop-bind-) form data-type)))
+ (loop-make-var (gensym "LOOP-BIND-") form data-type)))
\f
(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)
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*))))
"~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)
(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))))
\f
;;;; value accumulation: LIST
(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))
(let ((tempvars (loop-collector-tempvars lc)))
(unless tempvars
(setf (loop-collector-tempvars lc)
- (setq tempvars (list* (loop-gentemp 'loop-list-head-)
- (loop-gentemp 'loop-list-tail-)
+ (setq tempvars (list* (gensym "LOOP-LIST-HEAD-")
+ (gensym "LOOP-LIST-TAIL-")
(and (loop-collector-name lc)
(list (loop-collector-name lc))))))
(push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
(let ((tempvars (loop-collector-tempvars lc)))
(unless tempvars
(setf (loop-collector-tempvars lc)
- (setq tempvars (list (loop-make-variable
+ (setq tempvars (list (loop-make-var
(or (loop-collector-name lc)
- (loop-gentemp 'loop-sum-))
+ (gensym "LOOP-SUM-"))
nil (loop-collector-dtype lc)))))
(unless (loop-collector-name lc)
(loop-emit-final-value (car (loop-collector-tempvars lc)))))
(if (eq specifically 'count)
`(when ,form
(setq ,(car tempvars)
- ,(hide-variable-reference t
- (car tempvars)
- `(1+ ,(car tempvars)))))
+ (1+ ,(car tempvars))))
`(setq ,(car tempvars)
- (+ ,(hide-variable-reference t
- (car tempvars)
- (car tempvars))
+ (+ ,(car tempvars)
,form)))))))
(defun loop-maxmin-collection (specifically)
(multiple-value-bind (lc form)
- (loop-get-collection-info specifically 'maxmin *loop-real-data-type*)
- (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*)
+ (loop-get-collection-info specifically 'maxmin 'real)
+ (loop-check-data-type (loop-collector-dtype lc) 'real)
(let ((data (loop-collector-data lc)))
(unless data
(setf (loop-collector-data lc)
(setq data (make-loop-minimax
(or (loop-collector-name lc)
- (loop-gentemp 'loop-maxmin-))
+ (gensym "LOOP-MAXMIN-"))
(loop-collector-dtype lc))))
(unless (loop-collector-name lc)
(loop-emit-final-value (loop-minimax-answer-variable data))))
(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)))
;;; 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*))))
\f
(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)
(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)))))
keyword))
(apply (car tem) var first-arg data-type (cdr tem))))
-(defun loop-do-repeat ()
- (let ((form (loop-get-form))
- (type (loop-check-data-type (loop-optional-type)
- *loop-real-data-type*)))
- (when (and (consp form) (eq (car form) 'the) (subtypep (second form) type))
- (setq type (second form)))
- (multiple-value-bind (number constantp value)
- (loop-constant-fold-if-possible form type)
- (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
- (t (let ((var (loop-make-variable (loop-gentemp 'loop-repeat-)
- number
- type)))
- (if constantp
- `((not (plusp (setq ,var (1- ,var))))
- () () () () () () ())
- `((minusp (setq ,var (1- ,var)))
- () () ()))))))))
-
-(defun loop-when-it-variable ()
- (or *loop-when-it-variable*
- (setq *loop-when-it-variable*
- (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
+(defun loop-when-it-var ()
+ (or *loop-when-it-var*
+ (setq *loop-when-it-var*
+ (loop-make-var (gensym "LOOP-IT-") nil nil))))
\f
;;;; various FOR/AS subdispatches
-;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN
-;;; is omitted (other than being more stringent in its placement), and like the
-;;; old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first
-;;; initialization occurs in the loop body (first-step), not in the variable
-;;; binding phase.
+;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when
+;;; the THEN is omitted (other than being more stringent in its
+;;; placement), and like the old "FOR x FIRST y THEN z" when the THEN
+;;; is present. I.e., the first initialization occurs in the loop body
+;;; (first-step), not in the variable binding phase.
(defun loop-ansi-for-equals (var val data-type)
- (loop-make-iteration-variable var nil data-type)
+ (loop-make-iteration-var var nil data-type)
(cond ((loop-tequal (car *loop-source-code*) :then)
;; Then we are the same as "FOR x FIRST y THEN z".
(loop-pop-source)
`(() (,var ,val) () ()))))
(defun loop-for-across (var val data-type)
- (loop-make-iteration-variable var nil data-type)
- (let ((vector-var (loop-gentemp 'loop-across-vector-))
- (index-var (loop-gentemp 'loop-across-index-)))
+ (loop-make-iteration-var var nil data-type)
+ (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-"))
+ (index-var (gensym "LOOP-ACROSS-INDEX-")))
(multiple-value-bind (vector-form constantp vector-value)
(loop-constant-fold-if-possible val 'vector)
- (loop-make-variable
+ (loop-make-var
vector-var vector-form
(if (and (consp vector-form) (eq (car vector-form) 'the))
(cadr vector-form)
'vector))
- (loop-make-variable index-var 0 'fixnum)
+ (loop-make-var index-var 0 'fixnum)
(let* ((length 0)
(length-form (cond ((not constantp)
- (let ((v (loop-gentemp 'loop-across-limit-)))
+ (let ((v (gensym "LOOP-ACROSS-LIMIT-")))
(push `(setq ,v (length ,vector-var))
*loop-prologue*)
- (loop-make-variable v 0 'fixnum)))
+ (loop-make-var v 0 'fixnum)))
(t (setq length (length vector-value)))))
(first-test `(>= ,index-var ,length-form))
(other-test first-test)
;;;; 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
((and (consp stepper) (eq (car stepper) 'function))
(list (cadr stepper) listvar))
(t
- `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-)
- stepper
- 'function)
+ `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function)
,listvar)))))
(defun loop-for-on (var val data-type)
(loop-constant-fold-if-possible val)
(let ((listvar var))
(cond ((and var (symbolp var))
- (loop-make-iteration-variable var list data-type))
- (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list)
- (loop-make-iteration-variable var nil data-type)))
+ (loop-make-iteration-var var list data-type))
+ (t (loop-make-var (setq listvar (gensym)) list 'list)
+ (loop-make-iteration-var var nil data-type)))
(let ((list-step (loop-list-step listvar)))
(let* ((first-endtest
- (hide-variable-reference
- (eq var listvar)
- listvar
- ;; the following should use `atom' instead of `endp', per
- ;; [bug2428]
- `(atom ,listvar)))
+ ;; mysterious comment from original CMU CL sources:
+ ;; the following should use `atom' instead of `endp',
+ ;; per [bug2428]
+ `(atom ,listvar))
(other-endtest first-endtest))
(when (and constantp (listp list-value))
(setq first-endtest (null list-value)))
(cond ((eq var listvar)
- ;; Contour of the loop is different because we use the user's
- ;; variable...
- `(() (,listvar ,(hide-variable-reference t listvar list-step))
+ ;; The contour of the loop is different because we
+ ;; use the user's variable...
+ `(() (,listvar ,list-step)
,other-endtest () () () ,first-endtest ()))
(t (let ((step `(,var ,listvar))
(pseudo `(,listvar ,list-step)))
(defun loop-for-in (var val data-type)
(multiple-value-bind (list constantp list-value)
(loop-constant-fold-if-possible val)
- (let ((listvar (loop-gentemp 'loop-list-)))
- (loop-make-iteration-variable var nil data-type)
- (loop-make-variable listvar list 'list)
+ (let ((listvar (gensym "LOOP-LIST-")))
+ (loop-make-iteration-var var nil data-type)
+ (loop-make-var listvar list 'list)
(let ((list-step (loop-list-step listvar)))
(let* ((first-endtest `(endp ,listvar))
(other-endtest first-endtest)
(defun add-loop-path (names function universe
&key preposition-groups inclusive-permitted user-data)
- (unless (listp names) (setq names (list names)))
- (check-type universe loop-universe)
+ (declare (type loop-universe universe))
+ (unless (listp names)
+ (setq names (list names)))
(let ((ht (loop-universe-path-keywords universe))
(lp (make-loop-path
:names (mapcar #'symbol-name names)
(setf (gethash (symbol-name name) ht) lp))
lp))
\f
-;;; 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 =
(setq stuff (if inclusive
(apply fun var data-type preps :inclusive t user-data)
(apply fun var data-type preps user-data))))
- (when *loop-named-variables*
- (loop-error "Unused USING variables: ~S." *loop-named-variables*))
- ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the
- ;; system from the user and the user from himself.
+ (when *loop-named-vars*
+ (loop-error "Unused USING vars: ~S." *loop-named-vars*))
+ ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back).
+ ;; Protect the system from the user and the user from himself.
(unless (member (length stuff) '(6 10))
(loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
path))
(do ((l (car stuff) (cdr l)) (x)) ((null l))
(if (atom (setq x (car l)))
- (loop-make-iteration-variable x nil nil)
- (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
+ (loop-make-iteration-var x nil nil)
+ (loop-make-iteration-var (car x) (cadr x) (caddr x))))
(setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*))
(cddr stuff)))
\f
-(defun named-variable (name)
- (let ((tem (loop-tassoc name *loop-named-variables*)))
+(defun loop-named-var (name)
+ (let ((tem (loop-tassoc name *loop-named-vars*)))
(declare (list tem))
- (cond ((null tem) (values (loop-gentemp) nil))
- (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
+ (cond ((null tem) (values (gensym) nil))
+ (t (setq *loop-named-vars* (delete tem *loop-named-vars*))
(values (cdr tem) t)))))
(defun loop-collect-prepositional-phrases (preposition-groups
&optional
- USING-allowed
+ using-allowed
initial-phrases)
(flet ((in-group-p (x group) (car (loop-tmember x group))))
(do ((token nil)
(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))
(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))))
\f
;;;; 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
(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)))
((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
- (loop-gentemp '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 (loop-gentemp '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"))
(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
- (loop-gentemp '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))))
(if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
(when testfn
(setq test
- (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
+ `(,testfn ,indexv ,endform)))
(when step-hack
(setq step-hack
- `(,variable ,(hide-variable-reference indexv-user-specified-p
- indexv
- 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
limit-value))
(setq remaining-tests t)))
- `(() (,indexv ,(hide-variable-reference t indexv step))
+ `(() (,indexv ,step)
,remaining-tests ,step-hack () () ,first-test ,step-hack))))
\f
;;;; interfaces to the master sequencer
(defun loop-for-arithmetic (var val data-type kwd)
(loop-sequencer
- var (loop-check-data-type data-type *loop-real-data-type*) t
- nil nil nil nil nil nil
- (loop-collect-prepositional-phrases
- '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
- nil (list (list kwd val)))))
+ var (loop-check-data-type data-type 'number)
+ nil nil nil nil nil nil
+ (loop-collect-prepositional-phrases
+ '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
+ nil (list (list kwd val)))))
(defun loop-sequence-elements-path (variable data-type prep-phrases
&key
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)))))
\f
;;;; builtin LOOP iteration paths
||#
(defun loop-hash-table-iteration-path (variable data-type prep-phrases
- &key which)
- (check-type which (member hash-key hash-value))
+ &key (which (sb!int:missing-arg)))
+ (declare (type (member :hash-key :hash-value) which))
(cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
- (loop-error "Too many prepositions!"))
+ (loop-error "too many prepositions!"))
((null prep-phrases)
(loop-error "missing OF or IN in ~S iteration path")))
- (let ((ht-var (loop-gentemp 'loop-hashtab-))
- (next-fn (loop-gentemp 'loop-hashtab-next-))
+ (let ((ht-var (gensym "LOOP-HASHTAB-"))
+ (next-fn (gensym "LOOP-HASHTAB-NEXT-"))
(dummy-predicate-var nil)
(post-steps nil))
(multiple-value-bind (other-var other-p)
- (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
- ;; @@@@ named-variable returns a second value of T if the name was
- ;; actually specified, so clever code can throw away the gensym'ed up
- ;; variable if it isn't really needed. The following is for those
- ;; implementations in which we cannot put dummy NILs into
- ;; multiple-value-setq variable lists.
+ (loop-named-var (ecase which
+ (:hash-key 'hash-value)
+ (:hash-value 'hash-key)))
+ ;; @@@@ LOOP-NAMED-VAR returns a second value of T if the name
+ ;; was actually specified, so clever code can throw away the
+ ;; GENSYM'ed-up variable if it isn't really needed. The
+ ;; following is for those implementations in which we cannot put
+ ;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists.
(setq other-p t
- dummy-predicate-var (loop-when-it-variable))
- (let ((key-var nil)
- (val-var nil)
- (bindings `((,variable nil ,data-type)
- (,ht-var ,(cadar prep-phrases))
- ,@(and other-p other-var `((,other-var nil))))))
- (if (eq which 'hash-key)
- (setq key-var variable val-var (and other-p other-var))
- (setq key-var (and other-p other-var) val-var variable))
+ dummy-predicate-var (loop-when-it-var))
+ (let* ((key-var nil)
+ (val-var nil)
+ (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-")))
+ (bindings `((,variable nil ,data-type)
+ (,ht-var ,(cadar prep-phrases))
+ ,@(and other-p other-var `((,other-var nil))))))
+ (ecase which
+ (:hash-key (setq key-var variable
+ val-var (and other-p other-var)))
+ (:hash-value (setq key-var (and other-p other-var)
+ val-var variable)))
(push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
- (when (consp key-var)
- (setq post-steps
- `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
- ,@post-steps))
- (push `(,key-var nil) bindings))
- (when (consp val-var)
- (setq post-steps
- `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
- ,@post-steps))
- (push `(,val-var nil) bindings))
- `(,bindings ;bindings
- () ;prologue
- () ;pre-test
- () ;parallel steps
+ (when (or (consp key-var) data-type)
+ (setq post-steps
+ `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-"))
+ ,@post-steps))
+ (push `(,key-var nil) bindings))
+ (when (or (consp val-var) data-type)
+ (setq post-steps
+ `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-"))
+ ,@post-steps))
+ (push `(,val-var nil) bindings))
+ `(,bindings ;bindings
+ () ;prologue
+ () ;pre-test
+ () ;parallel steps
(not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var)
- (,next-fn))) ;post-test
+ (,next-fn))) ;post-test
,post-steps)))))
(defun loop-package-symbols-iteration-path (variable data-type prep-phrases
&key symbol-types)
- (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
+ (cond ((and prep-phrases (cdr prep-phrases))
(loop-error "Too many prepositions!"))
- ((null prep-phrases)
- (loop-error "missing OF or IN in ~S iteration path")))
+ ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
+ (sb!int:bug "Unknown preposition ~S." (caar prep-phrases))))
(unless (symbolp variable)
(loop-error "Destructuring is not valid for package symbol iteration."))
- (let ((pkg-var (loop-gentemp 'loop-pkgsym-))
- (next-fn (loop-gentemp 'loop-pkgsym-next-)))
+ (let ((pkg-var (gensym "LOOP-PKGSYM-"))
+ (next-fn (gensym "LOOP-PKGSYM-NEXT-"))
+ (variable (or variable (gensym "LOOP-PKGSYM-VAR-")))
+ (package (or (cadar prep-phrases) '*package*)))
(push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types))
*loop-wrappers*)
- `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases)))
+ `(((,variable nil ,data-type) (,pkg-var ,package))
()
()
()
- (not (multiple-value-setq (,(loop-when-it-variable)
+ (not (multiple-value-setq (,(loop-when-it-var)
,variable)
(,next-fn)))
())))
(defun make-ansi-loop-universe (extended-p)
(let ((w (make-standard-loop-universe
- :keywords `((named (loop-do-named))
+ :keywords '((named (loop-do-named))
(initially (loop-do-initially))
(finally (loop-do-finally))
(do (loop-do-do))
(nconc (loop-list-collection nconc))
(nconcing (loop-list-collection nconc))
(count (loop-sum-collection count
- ,*loop-real-data-type*
+ real
fixnum))
(counting (loop-sum-collection count
- ,*loop-real-data-type*
+ real
fixnum))
(sum (loop-sum-collection sum number number))
(summing (loop-sum-collection sum number number))
(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))
(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
(add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
- :user-data '(:which hash-key))
+ :user-data '(:which :hash-key))
(add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
- :user-data '(:which hash-value))
+ :user-data '(:which :hash-value))
(add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
'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*
(defun loop-standard-expansion (keywords-and-forms environment universe)
(if (and keywords-and-forms (symbolp (car keywords-and-forms)))
- (loop-translate keywords-and-forms environment universe)
- (let ((tag (gensym)))
- `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
+ (loop-translate keywords-and-forms environment universe)
+ (let ((tag (gensym)))
+ `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
-(sb!kernel:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
+(sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
(loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
-(sb!kernel:defmacro-mundanely loop-finish ()
+(sb!int:defmacro-mundanely loop-finish ()
#!+sb-doc
- "Causes the iteration to terminate \"normally\", the same as implicit
+ "Cause the iteration to terminate \"normally\", the same as implicit
termination by an iteration driving clause, or by use of WHILE or
UNTIL -- the epilogue code (if any) will be run, and any implicitly
collected result will be returned as the value of the LOOP."
projects / sbcl.git / blobdiff