;;;; 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!int:defmacro-mundanely with-loop-list-collection-head
(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!int:defmacro-mundanely with-minimax-value (lm &body body)
(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)
\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.")
-
(defun loop-make-psetq (frobs)
(and frobs
(loop-make-desetq
(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"))
(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)
(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*
specified-type required-type)))
specified-type)))
\f
+(defun loop-build-destructuring-bindings (crocks forms)
+ (if crocks
+ `((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 ((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)))))))
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))
(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)
&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*))))
(push (list name (or initialization (loop-typed-init dtype)))
*loop-variables*))
(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*))))))
+ (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
+ (loop-declare-variable name dtype)
+ (push (list newvar initialization) *loop-variables*)
+ ;; *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)))
(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))
(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))))
(defun loop-do-repeat ()
(let ((form (loop-get-form))
(type (loop-check-data-type (loop-optional-type)
- *loop-real-data-type*)))
+ 'real)))
(when (and (consp form)
(eq (car form) 'the)
(sb!xc:subtypep (second form) type))
(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
-;;; 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)
(cond ((loop-tequal (car *loop-source-code*) :then)
(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)))
;;;; 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-)
+ `(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)))
(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.
+ ;; 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))
(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)))))
\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)
+(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
(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
- 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 'real)
+ 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)
+ (multiple-value-bind (indexv) (named-variable 'index)
(let ((sequencev (named-variable '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 (required-argument)))
+ &key (which (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!"))
((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.
+ (named-variable (ecase which
+ (:hash-key 'hash-value)
+ (: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.
(setq other-p t
dummy-predicate-var (loop-when-it-variable))
(let ((key-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))
+ (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-))
+ `(,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))
(below (loop-for-arithmetic :below))
(to (loop-for-arithmetic :to))
(upto (loop-for-arithmetic :upto))
+ (by (loop-for-arithmetic :by))
(being (loop-for-being)))
:iteration-keywords '((for (loop-do-for))
(as (loop-do-for))
'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*
projects / sbcl.git / blobdiff