;;;; 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
(in-package "SB!LOOP")
-(sb!int:file-comment
- "$Header$")
-
;;;; The design of this LOOP is intended to permit, using mostly the same
;;;; kernel of code, up to three different "loop" macros:
;;;;
;;;; 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)
(defvar *loop-desetq-temporary*
(make-symbol "LOOP-DESETQ-TEMP"))
-(sb!kernel:defmacro-mundanely loop-really-desetq (&environment env
+(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
\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.
+;;; This holds variable names specified with the USING clause.
;;; See LOOP-NAMED-VARIABLE.
(defvar *loop-named-variables*)
;;; LETlist-like list being accumulated for one group of parallel bindings.
(defvar *loop-variables*)
-;;;List of declarations being accumulated in parallel with
-;;;*loop-variables*.
+;;; list of declarations being accumulated in parallel with *LOOP-VARIABLES*
(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-VARIABLE.
(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-VARIABLES*. The wrappers are appended onto a body. E.g.,
+;;; this list could conceivably have as its value
+;;; ((WITH-OPEN-FILE (G0001 G0002 ...))),
+;;; with G0002 being one of the bindings in *LOOP-VARIABLES* (This is
+;;; why the wrappers go inside of the variable bindings).
(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-VARIABLES* 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.
+;;; 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.
+;;; 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.
+;;; 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)
+;;; 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)
+ (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)))
(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.
(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
(push (pop rbefore) main-body)
(pop rafter))
(unless rbefore (return (makebody)))
- ;; The first forms in rbefore & rafter (which are the chronologically
+ ;; 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
((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 `(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)
&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))
(*loop-source-context* nil)
(*loop-iteration-variables* nil)
(*loop-variables* nil)
- (*loop-nodeclare* nil)
(*loop-named-variables* nil)
(*loop-declarations* nil)
(*loop-desetq-crocks* nil)
(loop-lookup-keyword keyword
(loop-universe-keywords
*loop-universe*)))
- ;; It's a "miscellaneous" toplevel LOOP keyword (do,
- ;; collect, named, etc.)
+ ;; It's a "miscellaneous" toplevel LOOP keyword (DO,
+ ;; COLLECT, NAMED, etc.)
(apply (symbol-function (first tem)) (rest tem)))
((setq tem
(loop-lookup-keyword keyword
(loop-universe-iteration-keywords *loop-universe*)))
(loop-hack-iteration tem))
((loop-tmember keyword '(and else))
- ;; Alternative is to ignore it, ie let it go around to
- ;; the next keyword...
+ ;; The alternative is to ignore it, i.e. let it go
+ ;; around to the next keyword...
(loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
keyword
(car *loop-source-code*)
;;;; 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)))
&optional iteration-variable-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*)
(push `(ignore ,name) *loop-declarations*))))
(cond (*loop-destructuring-hooks*
(loop-declare-variable name dtype)
(push (list name initialization) *loop-variables*))
- (t (let ((newvar (loop-gentemp 'loop-destructure-)))
+ (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*))
- ;; FIXME: We can delete this, right?
- #+ignore
- (loop-make-variable name
- nil
- dtype
- iteration-variable-p)))))
+ (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)))
(defun loop-declare-variable (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)
(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-variable (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))
;;;; value accumulation: LIST
(defstruct (loop-collector
- (:copier nil)
- (:predicate nil))
+ (:copier nil)
+ (:predicate nil))
name
class
(history nil)
(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*)
(setf (loop-collector-tempvars lc)
(setq tempvars (list (loop-make-variable
(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))))
,specifically
,form)))))
\f
-;;;; value accumulation: aggregate booleans
+;;;; value accumulation: aggregate booleans
-;;; ALWAYS and NEVER
+;;; handling the ALWAYS and NEVER loop keywords
;;;
;;; Under ANSI these are not permitted to appear under conditionalization.
(defun loop-do-always (restrictive negate)
,(loop-construct-return nil)))
(loop-emit-final-value t)))
-;;; THEREIS
+;;; handling the THEREIS loop keyword
;;;
;;; Under ANSI this is not permitted to appear under conditionalization.
(defun loop-do-thereis (restrictive)
(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))
+ '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 (loop-gentemp 'loop-repeat-)
+ (t (let ((var (loop-make-variable (gensym "LOOP-REPEAT-")
number
type)))
(if constantp
(defun loop-when-it-variable ()
(or *loop-when-it-variable*
(setq *loop-when-it-variable*
- (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
+ (loop-make-variable (gensym "LOOP-IT-") nil nil))))
\f
;;;; various FOR/AS subdispatches
(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-)))
+ (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-variable 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)))
((and (consp stepper) (eq (car stepper) 'function))
(list (cadr stepper) listvar))
(t
- `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-)
+ `(funcall ,(loop-make-variable (gensym "LOOP-FN-")
stepper
'function)
,listvar)))))
(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)
+ (t (loop-make-variable (setq listvar (gensym)) list 'list)
(loop-make-iteration-variable 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-)))
+ (let ((listvar (gensym "LOOP-LIST-")))
(loop-make-iteration-variable var nil data-type)
(loop-make-variable listvar list 'list)
(let ((list-step (loop-list-step listvar)))
;;;; iteration paths
(defstruct (loop-path
- (:copier nil)
- (:predicate nil))
+ (:copier nil)
+ (:predicate nil))
names
preposition-groups
inclusive-permitted
(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)
(defun named-variable (name)
(let ((tem (loop-tassoc name *loop-named-variables*)))
(declare (list tem))
- (cond ((null tem) (values (loop-gentemp) nil))
+ (cond ((null tem) (values (gensym) nil))
(t (setq *loop-named-variables* (delete tem *loop-named-variables*))
(values (cdr tem) t)))))
(setq endform (if limit-constantp
`',limit-value
(loop-make-variable
- (loop-gentemp 'loop-limit-) form indexv-type))))
+ (gensym "LOOP-LIMIT-") form indexv-type))))
(:by
(multiple-value-setq (form stepby-constantp stepby)
(loop-constant-fold-if-possible form indexv-type))
(unless stepby-constantp
- (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-))
+ (loop-make-variable (setq stepby (gensym "LOOP-STEP-BY-"))
form
indexv-type)))
(t (loop-error
(when (or limit-given default-top)
(unless limit-given
(loop-make-variable (setq endform
- (loop-gentemp 'loop-seq-limit-))
+ (gensym "LOOP-SEQ-LIMIT-"))
nil indexv-type)
(push `(setq ,endform ,default-top) *loop-prologue*))
(setq testfn (if inclusive-iteration '> '>=)))
(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 (setq first-test
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
+ var (loop-check-data-type data-type 'real) t
nil nil nil nil nil nil
(loop-collect-prepositional-phrases
'((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
||#
(defun loop-hash-table-iteration-path (variable data-type prep-phrases
- &key which)
- (check-type which (member hash-key hash-value))
+ &key (which (required-argument)))
+ (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)
(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-))
+ `(,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 (loop-gentemp 'loop-hash-val-temp-))
+ `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-"))
,@post-steps))
(push `(,val-var nil) bindings))
`(,bindings ;bindings
(loop-error "missing OF or IN in ~S iteration path")))
(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-")))
(push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types))
*loop-wrappers*)
`(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases)))
(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))
(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
(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