(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
- ;; These can come from psetq or desetq below.
- ;; Throw away the value, keep the side-effects.
+ ;; These can come from PSETQ or DESETQ below.
+ ;; Throw away the value, keep the side effects.
(defvar *loop-declarations*)
;;; This is used by LOOP for destructuring binding, if it is doing
(defvar *loop-declarations*)
;;; This is used by LOOP for destructuring binding, if it is doing
(defvar *loop-desetq-crocks*)
;;; list of wrapping forms, innermost first, which go immediately
;;; inside the current set of parallel bindings being accumulated in
(defvar *loop-desetq-crocks*)
;;; list of wrapping forms, innermost first, which go immediately
;;; inside the current set of parallel bindings being accumulated in
;;; this list could conceivably have as its value
;;; ((WITH-OPEN-FILE (G0001 G0002 ...))),
;;; this list could conceivably have as its value
;;; ((WITH-OPEN-FILE (G0001 G0002 ...))),
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; list of all the value-accumulation descriptor structures in the
;;; loop. See LOOP-GET-COLLECTION-INFO.
;;; list of all the value-accumulation descriptor structures in the
;;; loop. See LOOP-GET-COLLECTION-INFO.
t)
else))
(push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
t)
else))
(push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
(*loop-after-epilogue* nil)
(*loop-final-value-culprit* nil)
(*loop-inside-conditional* nil)
(*loop-after-epilogue* nil)
(*loop-final-value-culprit* nil)
(*loop-inside-conditional* nil)
- (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-error "duplicated variable ~S in LOOP parallel binding"
name)))
(unless (symbolp name)
(loop-error "bad variable ~S somewhere in LOOP" name))
(loop-error "duplicated variable ~S in LOOP parallel binding"
name)))
(unless (symbolp name)
(loop-error "bad variable ~S somewhere in LOOP" name))
;; 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)))
;; 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-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-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))))
-(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))
- (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
(t (error "invalid LOOP variable passed in: ~S" name))))
(defun loop-maybe-bind-form (form data-type)
(if (loop-constantp form)
form
\f
(defun loop-do-if (for negatep)
(let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil))
\f
(defun loop-do-if (for negatep)
(let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil))
(cdr *loop-source-code*))))
(cond ((or (not (setq data (loop-lookup-keyword
key (loop-universe-keywords *loop-universe*))))
(cdr *loop-source-code*))))
(cond ((or (not (setq data (loop-lookup-keyword
key (loop-universe-keywords *loop-universe*))))
;;; Under ANSI this is not permitted to appear under conditionalization.
(defun loop-do-thereis (restrictive)
(when restrictive (loop-disallow-conditional))
;;; 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*))))
(multiple-value-bind (number constantp value)
(loop-constant-fold-if-possible form type)
(cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
(multiple-value-bind (number constantp value)
(loop-constant-fold-if-possible form type)
(cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
(if constantp
`((not (plusp (setq ,var (1- ,var))))
() () () () () () ())
`((minusp (setq ,var (1- ,var)))
() () ()))))))))
(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))))
;;; 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)
;;; 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)
(cond ((loop-tequal (car *loop-source-code*) :then)
;; Then we are the same as "FOR x FIRST y THEN z".
(loop-pop-source)
(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)
`(() (,var ,val) () ()))))
(defun loop-for-across (var val 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)
(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)
(let* ((length 0)
(length-form (cond ((not constantp)
(let ((v (gensym "LOOP-ACROSS-LIMIT-")))
(push `(setq ,v (length ,vector-var))
*loop-prologue*)
(let* ((length 0)
(length-form (cond ((not constantp)
(let ((v (gensym "LOOP-ACROSS-LIMIT-")))
(push `(setq ,v (length ,vector-var))
*loop-prologue*)
(t (setq length (length vector-value)))))
(first-test `(>= ,index-var ,length-form))
(other-test first-test)
(t (setq length (length vector-value)))))
(first-test `(>= ,index-var ,length-form))
(other-test first-test)
- (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)))
(multiple-value-bind (list constantp list-value)
(loop-constant-fold-if-possible val)
(let ((listvar (gensym "LOOP-LIST-")))
(multiple-value-bind (list constantp list-value)
(loop-constant-fold-if-possible val)
(let ((listvar (gensym "LOOP-LIST-")))
(let ((list-step (loop-list-step listvar)))
(let* ((first-endtest `(endp ,listvar))
(other-endtest first-endtest)
(let ((list-step (loop-list-step listvar)))
(let* ((first-endtest `(endp ,listvar))
(other-endtest first-endtest)
;;; the prologue, etc.
(defun loop-for-being (var val data-type)
;; FOR var BEING each/the pathname prep-phrases using-stuff... each/the =
;;; 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))))
(setq stuff (if inclusive
(apply fun var data-type preps :inclusive t user-data)
(apply fun var data-type preps user-data))))
;; 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))
;; 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
"The variable substitution for ~S occurs twice in a USING phrase,~@
with ~S and ~S."
(car z) (cadr z) (cadr tem))
(loop-error
"The variable substitution for ~S occurs twice in a USING phrase,~@
with ~S and ~S."
(car z) (cadr z) (cadr tem))
(sequencep nil) ; T if sequence arg has been provided
(testfn nil) ; endtest function
(test nil) ; endtest form
(sequencep nil) ; T if sequence arg has been provided
(testfn nil) ; endtest function
(test nil) ; endtest form
((: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))
((: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))
(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
(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
(t (loop-error
"~S invalid preposition in sequencing or sequence path;~@
maybe invalid prepositions were specified in iteration path descriptor?"
(t (loop-error
"~S invalid preposition in sequencing or sequence path;~@
maybe invalid prepositions were specified in iteration path descriptor?"
(push `(setq ,endform ,default-top) *loop-prologue*))
(setq testfn (if inclusive-iteration '> '>=)))
(setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
(push `(setq ,endform ,default-top) *loop-prologue*))
(setq testfn (if inclusive-iteration '> '>=)))
(setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
;; 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
;; 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