(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!int:defmacro-mundanely loop-really-desetq (&environment env
- &rest var-val-pairs)
+ &rest var-val-pairs)
(labels ((find-non-null (var)
- ;; see whether there's any non-null thing here
- ;; recurse if the list element is itself a list
+ ;; See whether there's any non-null thing here. Recurse
+ ;; if the list element is itself a list.
(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
(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)
(defvar *loop-macro-environment*)
;;; This holds variable names specified with the USING clause.
-;;; See LOOP-NAMED-VARIABLE.
-(defvar *loop-named-variables*)
+;;; See LOOP-NAMED-VAR.
+(defvar *loop-named-vars*)
;;; LETlist-like list being accumulated for one group of parallel bindings.
-(defvar *loop-variables*)
+(defvar *loop-vars*)
-;;; list of declarations being accumulated in parallel with *LOOP-VARIABLES*
+;;; list of declarations being accumulated in parallel with *LOOP-VARS*
(defvar *loop-declarations*)
;;; This is used by LOOP for destructuring binding, if it is doing
-;;; that itself. See LOOP-MAKE-VARIABLE.
+;;; that itself. See LOOP-MAKE-VAR.
(defvar *loop-desetq-crocks*)
;;; list of wrapping forms, innermost first, which go immediately
;;; inside the current set of parallel bindings being accumulated in
-;;; *LOOP-VARIABLES*. The wrappers are appended onto a body. E.g.,
+;;; *LOOP-VARS*. The wrappers are appended onto a body. E.g.,
;;; this list could conceivably have as its value
;;; ((WITH-OPEN-FILE (G0001 G0002 ...))),
-;;; with G0002 being one of the bindings in *LOOP-VARIABLES* (This is
+;;; with G0002 being one of the bindings in *LOOP-VARS* (This is
;;; why the wrappers go inside of the variable bindings).
(defvar *loop-wrappers*)
-;;; This accumulates lists of previous values of *LOOP-VARIABLES* and
+;;; This accumulates lists of previous values of *LOOP-VARS* and
;;; the other lists above, for each new nesting of bindings. See
;;; LOOP-BIND-BLOCK.
(defvar *loop-bind-stack*)
;;; This is simply a list of LOOP iteration variables, used for
;;; checking for duplications.
-(defvar *loop-iteration-variables*)
+(defvar *loop-iteration-vars*)
;;; list of prologue forms of the loop, accumulated in reverse order
(defvar *loop-prologue*)
;;; If not NIL, this is a temporary bound around the loop for holding
;;; the temporary value for "it" in things like "when (f) collect it".
;;; It may be used as a supertemporary by some other things.
-(defvar *loop-when-it-variable*)
+(defvar *loop-when-it-var*)
;;; Sometimes we decide we need to fold together parts of the loop,
;;; but some part of the generated iteration code is different for the
;;; first and remaining iterations. This variable will be the
;;; temporary which is the flag used in the loop to tell whether we
;;; are in the first or remaining iterations.
-(defvar *loop-never-stepped-variable*)
+(defvar *loop-never-stepped-var*)
;;; list of all the value-accumulation descriptor structures in the
;;; loop. See LOOP-GET-COLLECTION-INFO.
(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)
(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)))
((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~}."
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 ((*loop-original-source-code* *loop-source-code*)
(*loop-source-context* nil)
- (*loop-iteration-variables* nil)
- (*loop-variables* nil)
- (*loop-named-variables* nil)
+ (*loop-iteration-vars* nil)
+ (*loop-vars* nil)
+ (*loop-named-vars* nil)
(*loop-declarations* nil)
(*loop-desetq-crocks* nil)
(*loop-bind-stack* nil)
(*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)
(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))
;;;; 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-make-var (name initialization dtype &optional iteration-var-p)
(cond ((null name)
(cond ((not (null initialization))
(push (list (setq name (gensym "LOOP-IGNORE-"))
initialization)
- *loop-variables*)
+ *loop-vars*)
(push `(ignore ,name) *loop-declarations*))))
((atom name)
- (cond (iteration-variable-p
- (if (member name *loop-iteration-variables*)
+ (cond (iteration-var-p
+ (if (member name *loop-iteration-vars*)
(loop-error "duplicated LOOP iteration variable ~S" name)
- (push name *loop-iteration-variables*)))
- ((assoc name *loop-variables*)
+ (push name *loop-iteration-vars*)))
+ ((assoc name *loop-vars*)
(loop-error "duplicated variable ~S in LOOP parallel binding"
name)))
(unless (symbolp name)
(loop-error "bad variable ~S somewhere in LOOP" name))
- (loop-declare-variable name dtype)
+ (loop-declare-var name dtype)
;; We use ASSOC on this list to check for duplications (above),
;; so don't optimize out this list:
(push (list name (or initialization (loop-typed-init dtype)))
- *loop-variables*))
+ *loop-vars*))
(initialization
- (cond (*loop-destructuring-hooks*
- (loop-declare-variable name dtype)
- (push (list name initialization) *loop-variables*))
- (t (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
- (push (list newvar initialization) *loop-variables*)
- ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
- (setq *loop-desetq-crocks*
- (list* name newvar *loop-desetq-crocks*))))))
+ (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
+ (loop-declare-var name dtype)
+ (push (list newvar initialization) *loop-vars*)
+ ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
+ (setq *loop-desetq-crocks*
+ (list* name newvar *loop-desetq-crocks*))))
(t (let ((tcar nil) (tcdr nil))
(if (atom dtype) (setq tcar (setq tcdr dtype))
(setq tcar (car dtype) tcdr (cdr dtype)))
- (loop-make-variable (car name) nil tcar iteration-variable-p)
- (loop-make-variable (cdr name) nil tcdr iteration-variable-p))))
+ (loop-make-var (car name) nil tcar iteration-var-p)
+ (loop-make-var (cdr name) nil tcdr iteration-var-p))))
name)
-(defun loop-make-iteration-variable (name initialization dtype)
- (loop-make-variable name initialization dtype t))
+(defun loop-make-iteration-var (name initialization dtype)
+ (loop-make-var name initialization dtype t))
-(defun loop-declare-variable (name dtype)
+(defun loop-declare-var (name dtype)
(cond ((or (null name) (null dtype) (eq dtype t)) nil)
((symbolp name)
(unless (sb!xc:subtypep t dtype)
(push `(type ,dtype ,name) *loop-declarations*))))
((consp name)
(cond ((consp dtype)
- (loop-declare-variable (car name) (car dtype))
- (loop-declare-variable (cdr name) (cdr dtype)))
- (t (loop-declare-variable (car name) dtype)
- (loop-declare-variable (cdr name) dtype))))
+ (loop-declare-var (car name) (car dtype))
+ (loop-declare-var (cdr name) (cdr dtype)))
+ (t (loop-declare-var (car name) dtype)
+ (loop-declare-var (cdr name) dtype))))
(t (error "invalid LOOP variable passed in: ~S" name))))
(defun loop-maybe-bind-form (form data-type)
(if (loop-constantp form)
form
- (loop-make-variable (gensym "LOOP-BIND-") form data-type)))
+ (loop-make-var (gensym "LOOP-BIND-") form data-type)))
\f
(defun loop-do-if (for negatep)
(let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil))
(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*))))
(let ((tempvars (loop-collector-tempvars lc)))
(unless tempvars
(setf (loop-collector-tempvars lc)
- (setq tempvars (list (loop-make-variable
+ (setq tempvars (list (loop-make-var
(or (loop-collector-name lc)
(gensym "LOOP-SUM-"))
nil (loop-collector-dtype lc)))))
;;; 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-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-pop-source)
(loop-get-form))
(t nil)))
- (loop-make-variable var val dtype)
+ (loop-make-var var val dtype)
(if (loop-tequal (car *loop-source-code*) :and)
(loop-pop-source)
(return (loop-bind-block)))))
(multiple-value-bind (number constantp value)
(loop-constant-fold-if-possible form type)
(cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
- (t (let ((var (loop-make-variable (gensym "LOOP-REPEAT-")
- number
- type)))
+ (t (let ((var (loop-make-var (gensym "LOOP-REPEAT-") number type)))
(if constantp
`((not (plusp (setq ,var (1- ,var))))
() () () () () () ())
`((minusp (setq ,var (1- ,var)))
() () ()))))))))
-(defun loop-when-it-variable ()
- (or *loop-when-it-variable*
- (setq *loop-when-it-variable*
- (loop-make-variable (gensym "LOOP-IT-") nil nil))))
+(defun loop-when-it-var ()
+ (or *loop-when-it-var*
+ (setq *loop-when-it-var*
+ (loop-make-var (gensym "LOOP-IT-") nil nil))))
\f
;;;; various FOR/AS subdispatches
;;; 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)
+ (loop-make-iteration-var var nil data-type)
(let ((vector-var (gensym "LOOP-ACROSS-VECTOR-"))
(index-var (gensym "LOOP-ACROSS-INDEX-")))
(multiple-value-bind (vector-form constantp vector-value)
(loop-constant-fold-if-possible val 'vector)
- (loop-make-variable
+ (loop-make-var
vector-var vector-form
(if (and (consp vector-form) (eq (car vector-form) 'the))
(cadr vector-form)
'vector))
- (loop-make-variable index-var 0 'fixnum)
+ (loop-make-var index-var 0 'fixnum)
(let* ((length 0)
(length-form (cond ((not constantp)
(let ((v (gensym "LOOP-ACROSS-LIMIT-")))
(push `(setq ,v (length ,vector-var))
*loop-prologue*)
- (loop-make-variable v 0 'fixnum)))
+ (loop-make-var v 0 'fixnum)))
(t (setq length (length vector-value)))))
(first-test `(>= ,index-var ,length-form))
(other-test first-test)
((and (consp stepper) (eq (car stepper) 'function))
(list (cadr stepper) listvar))
(t
- `(funcall ,(loop-make-variable (gensym "LOOP-FN-")
- stepper
- 'function)
+ `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function)
,listvar)))))
(defun loop-for-on (var val data-type)
(loop-constant-fold-if-possible val)
(let ((listvar var))
(cond ((and var (symbolp var))
- (loop-make-iteration-variable var list data-type))
- (t (loop-make-variable (setq listvar (gensym)) list 'list)
- (loop-make-iteration-variable var nil data-type)))
+ (loop-make-iteration-var var list data-type))
+ (t (loop-make-var (setq listvar (gensym)) list 'list)
+ (loop-make-iteration-var var nil data-type)))
(let ((list-step (loop-list-step listvar)))
(let* ((first-endtest
;; mysterious comment from original CMU CL sources:
(multiple-value-bind (list constantp list-value)
(loop-constant-fold-if-possible val)
(let ((listvar (gensym "LOOP-LIST-")))
- (loop-make-iteration-variable var nil data-type)
- (loop-make-variable listvar list 'list)
+ (loop-make-iteration-var var nil data-type)
+ (loop-make-var listvar list 'list)
(let ((list-step (loop-list-step listvar)))
(let* ((first-endtest `(endp ,listvar))
(other-endtest first-endtest)
(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*))
+ (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))
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 (gensym) nil))
- (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
+ (t (setq *loop-named-vars* (delete tem *loop-named-vars*))
(values (cdr tem) t)))))
(defun loop-collect-prepositional-phrases (preposition-groups
&optional
- USING-allowed
+ using-allowed
initial-phrases)
(flet ((in-group-p (x group) (car (loop-tmember x group))))
(do ((token nil)
(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)
(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))))
sequence-variable sequence-type
step-hack default-top
prep-phrases)
- (let ((endform nil) ; Form (constant or variable) with limit value
+ (let ((endform nil) ; form (constant or variable) with limit value
(sequencep nil) ; T if sequence arg has been provided
(testfn nil) ; endtest function
(test nil) ; endtest form
(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-constant-fold-if-possible form indexv-type))
(setq endform (if limit-constantp
`',limit-value
- (loop-make-variable
+ (loop-make-var
(gensym "LOOP-LIMIT-") form indexv-type))))
(:by
(multiple-value-setq (form stepby-constantp stepby)
(loop-constant-fold-if-possible form indexv-type))
(unless stepby-constantp
- (loop-make-variable (setq stepby (gensym "LOOP-STEP-BY-"))
- form
- indexv-type)))
+ (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
+ form
+ indexv-type)))
(t (loop-error
"~S invalid preposition in sequencing or sequence path;~@
maybe invalid prepositions were specified in iteration path descriptor?"
(loop-error "missing OF or IN phrase in sequence path"))
;; Now fill in the defaults.
(unless start-given
- (loop-make-iteration-variable
+ (loop-make-iteration-var
indexv
(setq start-constantp t
start-value (or (loop-typed-init indexv-type) 0))
(cond ((member dir '(nil :up))
(when (or limit-given default-top)
(unless limit-given
- (loop-make-variable (setq endform
- (gensym "LOOP-SEQ-LIMIT-"))
- nil indexv-type)
+ (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-"))
+ nil
+ indexv-type)
(push `(setq ,endform ,default-top) *loop-prologue*))
(setq testfn (if inclusive-iteration '> '>=)))
(setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
size-function
sequence-type
element-type)
- (multiple-value-bind (indexv) (named-variable 'index)
- (let ((sequencev (named-variable 'sequence)))
+ (multiple-value-bind (indexv) (loop-named-var 'index)
+ (let ((sequencev (named-var 'sequence)))
(list* nil nil ; dummy bindings and prologue
(loop-sequencer
indexv 'fixnum
||#
(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!"))
(dummy-predicate-var nil)
(post-steps nil))
(multiple-value-bind (other-var other-p)
- (named-variable (ecase which
+ (loop-named-var (ecase which
(:hash-key 'hash-value)
(:hash-value 'hash-key)))
- ;; @@@@ NAMED-VARIABLE returns a second value of T if the name
+ ;; @@@@ LOOP-NAMED-VAR returns a second value of T if the name
;; was actually specified, so clever code can throw away the
;; GENSYM'ed-up variable if it isn't really needed. The
;; following is for those implementations in which we cannot put
;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists.
(setq other-p t
- dummy-predicate-var (loop-when-it-variable))
+ dummy-predicate-var (loop-when-it-var))
(let ((key-var nil)
(val-var nil)
(bindings `((,variable nil ,data-type)
()
()
()
- (not (multiple-value-setq (,(loop-when-it-variable)
+ (not (multiple-value-setq (,(loop-when-it-var)
,variable)
(,next-fn)))
())))
(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