- `(let* ((,head-place nil)
- (,tail-var
- ,(hide-variable-reference
- user-head-var user-head-var
- `(progn #+Genera (scl:locf ,head-place)
- #-Genera (system:variable-location ,head-place)))))
- ,@body))
+ `(let* ((,head-place nil)
+ (,tail-var
+ ,(hide-variable-reference
+ user-head-var user-head-var
+ `(progn #+Genera (scl:locf ,head-place)
+ #-Genera (system:variable-location ,head-place)))))
+ ,@body))
- #+CLOE `(sys::with-stack-list* (,head-var nil nil)
- (let ((,tail-var ,head-var) ,@l)
- ,@body))
- #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
- ,@body)))
+ #+CLOE `(sys::with-stack-list* (,head-var nil nil)
+ (let ((,tail-var ,head-var) ,@l)
+ ,@body))
+ #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
+ ,@body)))
- (cond ((eq (car form) 'list)
- (setq ncdrs (1- (length (cdr form))))
- ;;@@@@ Because the last element is going to be RPLACDed,
- ;; we don't want the cdr-coded implementations to use
- ;; cdr-nil at the end (which would just force copying
- ;; the whole list again).
- #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
- ((member (car form) '(list* cons))
- (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
- (setq ncdrs (- (length (cdr form)) 2))))))
+ (cond ((eq (car form) 'list)
+ (setq ncdrs (1- (length (cdr form))))
+ ;;@@@@ Because the last element is going to be RPLACDed,
+ ;; we don't want the cdr-coded implementations to use
+ ;; cdr-nil at the end (which would just force copying
+ ;; the whole list again).
+ #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
+ ((member (car form) '(list* cons))
+ (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
+ (setq ncdrs (- (length (cdr form)) 2))))))
- (cond ((null ncdrs)
- `(when (setf (cdr ,tail-var) ,tail-form)
- (setq ,tail-var (last (cdr ,tail-var)))))
- ((< ncdrs 0) (return-from loop-collect-rplacd nil))
- ((= ncdrs 0)
- ;;@@@@ Here we have a choice of two idioms:
- ;; (rplacd tail (setq tail tail-form))
- ;; (setq tail (setf (cdr tail) tail-form)).
- ;;Genera and most others I have seen do better with the former.
- `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
- (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
- ncdrs))))))
- ;;If not using locatives or something similar to update the user's
- ;; head variable, we've got to set it... It's harmless to repeatedly set it
- ;; unconditionally, and probably faster than checking.
- #-LISPM (when user-head-var
- (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
- answer))))
+ (cond ((null ncdrs)
+ `(when (setf (cdr ,tail-var) ,tail-form)
+ (setq ,tail-var (last (cdr ,tail-var)))))
+ ((< ncdrs 0) (return-from loop-collect-rplacd nil))
+ ((= ncdrs 0)
+ ;;@@@@ Here we have a choice of two idioms:
+ ;; (rplacd tail (setq tail tail-form))
+ ;; (setq tail (setf (cdr tail) tail-form)).
+ ;;Genera and most others I have seen do better with the former.
+ `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
+ (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
+ ncdrs))))))
+ ;;If not using locatives or something similar to update the user's
+ ;; head variable, we've got to set it... It's harmless to repeatedly set it
+ ;; unconditionally, and probably faster than checking.
+ #-LISPM (when user-head-var
+ (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
+ answer))))
- ;;@@@@ This is the sort of value this should take on for a Lisp that has
- ;; "eminently usable" infinities. n.b. there are neither constants nor
- ;; printed representations for infinities defined by CL.
- ;;@@@@ This grotesque read-from-string below is to help implementations
- ;; which croak on the infinity character when it appears in a token, even
- ;; conditionalized out.
- #+Genera
- '#.(read-from-string
- "((fixnum most-positive-fixnum most-negative-fixnum)
- (short-float +1s\ e -1s\ e)
- (single-float +1f\ e -1f\ e)
- (double-float +1d\ e -1d\ e)
- (long-float +1l\ e -1l\ e))")
- ;;This is how the alist should look for a lisp that has no infinities. In
- ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive.
- #+(or CLOE-Runtime Minima)
- '((fixnum most-positive-fixnum most-negative-fixnum)
- (short-float most-positive-short-float most-negative-short-float)
- (single-float most-positive-single-float most-negative-single-float)
- (double-float most-positive-double-float most-negative-double-float)
- (long-float most-positive-long-float most-negative-long-float))
- ;; CMUCL has infinities so let's use them.
- #+CMU
- '((fixnum most-positive-fixnum most-negative-fixnum)
- (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity)
- (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity)
- (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity)
- (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity))
- ;; If we don't know, then we cannot provide "infinite" initial values for any of the
- ;; types but FIXNUM:
- #-(or Genera CLOE-Runtime Minima CMU)
- '((fixnum most-positive-fixnum most-negative-fixnum))
- )
+ ;;@@@@ This is the sort of value this should take on for a Lisp that has
+ ;; "eminently usable" infinities. n.b. there are neither constants nor
+ ;; printed representations for infinities defined by CL.
+ ;;@@@@ This grotesque read-from-string below is to help implementations
+ ;; which croak on the infinity character when it appears in a token, even
+ ;; conditionalized out.
+ #+Genera
+ '#.(read-from-string
+ "((fixnum most-positive-fixnum most-negative-fixnum)
+ (short-float +1s\ e -1s\ e)
+ (single-float +1f\ e -1f\ e)
+ (double-float +1d\ e -1d\ e)
+ (long-float +1l\ e -1l\ e))")
+ ;;This is how the alist should look for a lisp that has no infinities. In
+ ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive.
+ #+(or CLOE-Runtime Minima)
+ '((fixnum most-positive-fixnum most-negative-fixnum)
+ (short-float most-positive-short-float most-negative-short-float)
+ (single-float most-positive-single-float most-negative-single-float)
+ (double-float most-positive-double-float most-negative-double-float)
+ (long-float most-positive-long-float most-negative-long-float))
+ ;; CMUCL has infinities so let's use them.
+ #+CMU
+ '((fixnum most-positive-fixnum most-negative-fixnum)
+ (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity)
+ (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity)
+ (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity)
+ (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity))
+ ;; If we don't know, then we cannot provide "infinite" initial values for any of the
+ ;; types but FIXNUM:
+ #-(or Genera CLOE-Runtime Minima CMU)
+ '((fixnum most-positive-fixnum most-negative-fixnum))
+ )
- (which (car (loop-minimax-operations lm)))
- (infinity-data (loop-minimax-infinity-data lm))
- (answer-var (loop-minimax-answer-variable lm))
- (temp-var (loop-minimax-temp-variable lm))
- (flag-var (loop-minimax-flag-variable lm))
- (type (loop-minimax-type lm)))
+ (which (car (loop-minimax-operations lm)))
+ (infinity-data (loop-minimax-infinity-data lm))
+ (answer-var (loop-minimax-answer-variable lm))
+ (temp-var (loop-minimax-temp-variable lm))
+ (flag-var (loop-minimax-flag-variable lm))
+ (type (loop-minimax-type lm)))
- `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil))
- (declare (type ,type ,answer-var ,temp-var))
- ,@body)
- `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data)))
- (,temp-var ,init))
- (declare (type ,type ,answer-var ,temp-var))
- ,@body))))
+ `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil))
+ (declare (type ,type ,answer-var ,temp-var))
+ ,@body)
+ `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data)))
+ (,temp-var ,init))
+ (declare (type ,type ,answer-var ,temp-var))
+ ,@body))))
- (:print-function print-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.
- implicit-for-required ;see loop-hack-iteration
+ (:print-function print-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.
+ implicit-for-required ;see loop-hack-iteration
- ;; see if 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)
- ;; returns a list of actions to be performed
- (typecase var
- (null
- (when (consp val)
- ;; 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 (macroexpand x env)))))
- (cons x nil)))
- (cdr val))
- `(,val))))
- (cons
- (let* ((car (car var))
- (cdr (cdr var))
- (car-non-null (find-non-null car))
- (cdr-non-null (find-non-null cdr)))
- (when (or car-non-null cdr-non-null)
- (if cdr-non-null
- (let* ((temp-p temp)
- (temp (or temp *loop-desetq-temporary*))
- (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
- car
- `(prog1 (car ,temp)
- (setq ,temp (cdr ,temp))))
- ,@(loop-desetq-internal cdr temp temp))
- #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
- (setq ,temp (cdr ,temp))
- ,@(loop-desetq-internal cdr temp temp))))
- (if temp-p
- `(,@(unless (eq temp val)
- `((setq ,temp ,val)))
- ,@body)
- `((let ((,temp ,val))
- ,@body))))
- ;; no cdring to do
- (loop-desetq-internal car `(car ,val) temp)))))
- (otherwise
- (unless (eq var val)
- `((setq ,var ,val)))))))
+ ;; see if 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)
+ ;; returns a list of actions to be performed
+ (typecase var
+ (null
+ (when (consp val)
+ ;; 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 (macroexpand x env)))))
+ (cons x nil)))
+ (cdr val))
+ `(,val))))
+ (cons
+ (let* ((car (car var))
+ (cdr (cdr var))
+ (car-non-null (find-non-null car))
+ (cdr-non-null (find-non-null cdr)))
+ (when (or car-non-null cdr-non-null)
+ (if cdr-non-null
+ (let* ((temp-p temp)
+ (temp (or temp *loop-desetq-temporary*))
+ (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
+ car
+ `(prog1 (car ,temp)
+ (setq ,temp (cdr ,temp))))
+ ,@(loop-desetq-internal cdr temp temp))
+ #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
+ (setq ,temp (cdr ,temp))
+ ,@(loop-desetq-internal cdr temp temp))))
+ (if temp-p
+ `(,@(unless (eq temp val)
+ `((setq ,temp ,val)))
+ ,@body)
+ `((let ((,temp ,val))
+ ,@body))))
+ ;; no cdring to do
+ (loop-desetq-internal car `(car ,val) temp)))))
+ (otherwise
+ (unless (eq var val)
+ `((setq ,var ,val)))))))
- (let ((ans nil))
- (dolist (x l)
- (when x
- (push x ans)
- (when (and (consp x) (member (car x) '(go return return-from)))
- (return nil))))
- (nreverse ans)))
- (pify (l) (if (null (cdr l)) (car l) `(progn ,@l)))
- (makebody ()
- (let ((form `(tagbody
- ;; ANSI CL 6.1.7.2 says that initially clauses are
- ;; evaluated in the loop prologue, which precedes
- ;; all loop code except for the initial settings
- ;; provided by with, for, or as.
- ,@(psimp (append (nreverse rbefore) prologue))
- next-loop
- ,@(psimp (append main-body (nreconc rafter `((go next-loop)))))
- end-loop
- ,@(psimp epilogue))))
- (if flagvar `(let ((,flagvar nil)) ,form) form))))
+ (let ((ans nil))
+ (dolist (x l)
+ (when x
+ (push x ans)
+ (when (and (consp x) (member (car x) '(go return return-from)))
+ (return nil))))
+ (nreverse ans)))
+ (pify (l) (if (null (cdr l)) (car l) `(progn ,@l)))
+ (makebody ()
+ (let ((form `(tagbody
+ ;; ANSI CL 6.1.7.2 says that initially clauses are
+ ;; evaluated in the loop prologue, which precedes
+ ;; all loop code except for the initial settings
+ ;; provided by with, for, or as.
+ ,@(psimp (append (nreverse rbefore) prologue))
+ next-loop
+ ,@(psimp (append main-body (nreconc rafter `((go next-loop)))))
+ end-loop
+ ,@(psimp epilogue))))
+ (if flagvar `(let ((,flagvar nil)) ,form) form))))
- ((null bb) (return-from loop-body (makebody))) ;Did it.
- (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0))
- ((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.
- (let ((then nil) (else nil))
- (do () (nil)
- (push (pop rbefore) else)
- (push (pop rafter) then)
- (when (eq rbefore (cdr lastdiff)) (return)))
- (unless flagvar
- (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else))
- (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
- main-body))
- ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb)
- ;; is the same in rbefore and rafter so just copy it into the body
- (do () (nil)
- (pop rafter)
- (push (pop rbefore) main-body)
- (when (eq rbefore (cdr bb)) (return)))
- (return)))))))
+ ((null bb) (return-from loop-body (makebody))) ;Did it.
+ (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0))
+ ((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.
+ (let ((then nil) (else nil))
+ (do () (nil)
+ (push (pop rbefore) else)
+ (push (pop rafter) then)
+ (when (eq rbefore (cdr lastdiff)) (return)))
+ (unless flagvar
+ (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else))
+ (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
+ main-body))
+ ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb)
+ ;; is the same in rbefore and rafter so just copy it into the body
+ (do () (nil)
+ (pop rafter)
+ (push (pop rbefore) main-body)
+ (when (eq rbefore (cdr bb)) (return)))
+ (return)))))))
- '((return 0) (progn 0)
- (null 1) (not 1) (eq 1) (car 1) (cdr 1)
- (when 1) (unless 1) (if 1)
- (caar 2) (cadr 2) (cdar 2) (cddr 2)
- (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
- (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4)
- (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4)
- (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4)
- (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4)))
+ '((return 0) (progn 0)
+ (null 1) (not 1) (eq 1) (car 1) (cdr 1)
+ (when 1) (unless 1) (if 1)
+ (caar 2) (cadr 2) (cdar 2) (cddr 2)
+ (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
+ (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4)
+ (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4)
+ (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4)
+ (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4)))
- ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
- (if expanded-p (estimate-code-size-1 new-form env) 1)))
- ((atom x) 1) ;??? self-evaluating???
- ((symbolp (car x))
- (let ((fn (car x)) (tem nil) (n 0))
- (declare (symbol fn) (fixnum n))
- (macrolet ((f (overhead &optional (args nil args-p))
- `(the fixnum (+ (the fixnum ,overhead)
- (the fixnum (list-size ,(if args-p args '(cdr x))))))))
- (cond ((setq tem (get fn 'estimate-code-size))
- (typecase tem
- (fixnum (f tem))
- (t (funcall tem x env))))
- ((setq tem (assoc fn *special-code-sizes*)) (f (second tem)))
- #+Genera
- ((eq fn 'compiler:invisible-references) (list-size (cddr x)))
- ((eq fn 'cond)
- (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n)))
- ((eq fn 'desetq)
- (do ((l (cdr x) (cdr l))) ((null l) n)
- (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env)))))
- ((member fn '(setq psetq))
- (do ((l (cdr x) (cdr l))) ((null l) n)
- (setq n (+ n (estimate-code-size-1 (cadr l) env) 1))))
- ((eq fn 'go) 1)
- ((eq fn 'function)
- ;;This skirts the issue of implementationally-defined lambda macros
- ;; by recognizing CL function names and nothing else.
+ ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
+ (if expanded-p (estimate-code-size-1 new-form env) 1)))
+ ((atom x) 1) ;??? self-evaluating???
+ ((symbolp (car x))
+ (let ((fn (car x)) (tem nil) (n 0))
+ (declare (symbol fn) (fixnum n))
+ (macrolet ((f (overhead &optional (args nil args-p))
+ `(the fixnum (+ (the fixnum ,overhead)
+ (the fixnum (list-size ,(if args-p args '(cdr x))))))))
+ (cond ((setq tem (get fn 'estimate-code-size))
+ (typecase tem
+ (fixnum (f tem))
+ (t (funcall tem x env))))
+ ((setq tem (assoc fn *special-code-sizes*)) (f (second tem)))
+ #+Genera
+ ((eq fn 'compiler:invisible-references) (list-size (cddr x)))
+ ((eq fn 'cond)
+ (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n)))
+ ((eq fn 'desetq)
+ (do ((l (cdr x) (cdr l))) ((null l) n)
+ (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env)))))
+ ((member fn '(setq psetq))
+ (do ((l (cdr x) (cdr l))) ((null l) n)
+ (setq n (+ n (estimate-code-size-1 (cadr l) env) 1))))
+ ((eq fn 'go) 1)
+ ((eq fn 'function)
+ ;;This skirts the issue of implementationally-defined lambda macros
+ ;; by recognizing CL function names and nothing else.
- ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x)))
- ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env)))
- ((or (special-operator-p fn) (member fn *estimate-code-size-punt*))
- (throw 'estimate-code-size nil))
- (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
- (if expanded-p
- (estimate-code-size-1 new-form env)
- (f 3))))))))
- (t (throw 'estimate-code-size nil)))))
+ ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x)))
+ ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env)))
+ ((or (special-operator-p fn) (member fn *estimate-code-size-punt*))
+ (throw 'estimate-code-size nil))
+ (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
+ (if expanded-p
+ (estimate-code-size-1 new-form env)
+ (f 3))))))))
+ (t (throw 'estimate-code-size nil)))))
- (*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-bind-stack* nil)
- (*loop-prologue* nil)
- (*loop-wrappers* nil)
- (*loop-before-loop* nil)
- (*loop-body* nil)
- (*loop-emitted-body* nil)
- (*loop-after-body* nil)
- (*loop-epilogue* 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-names* nil)
- (*loop-collection-cruft* nil))
+ (*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-bind-stack* nil)
+ (*loop-prologue* nil)
+ (*loop-wrappers* nil)
+ (*loop-before-loop* nil)
+ (*loop-body* nil)
+ (*loop-emitted-body* nil)
+ (*loop-after-body* nil)
+ (*loop-epilogue* 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-names* nil)
+ (*loop-collection-cruft* nil))
- ,(nreverse *loop-prologue*)
- ,(nreverse *loop-before-loop*)
- ,(nreverse *loop-body*)
- ,(nreverse *loop-after-body*)
- ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
+ ,(nreverse *loop-prologue*)
+ ,(nreverse *loop-before-loop*)
+ ,(nreverse *loop-body*)
+ ,(nreverse *loop-after-body*)
+ ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
- (let ((vars (first entry))
- (dcls (second entry))
- (crocks (third entry))
- (wrappers (fourth entry)))
- (dolist (w wrappers)
- (setq answer (append w (list answer))))
- (when (or vars dcls crocks)
- (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))
- ,vars
- ,@(loop-build-destructuring-bindings crocks forms)))))))
+ (let ((vars (first entry))
+ (dcls (second entry))
+ (crocks (third entry))
+ (wrappers (fourth entry)))
+ (dolist (w wrappers)
+ (setq answer (append w (list answer))))
+ (when (or vars dcls crocks)
+ (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))
+ ,vars
+ ,@(loop-build-destructuring-bindings crocks forms)))))))
- (loop-error "~S found where LOOP keyword expected." keyword))
- (t (setq *loop-source-context* *loop-source-code*)
- (loop-pop-source)
- (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*)))
- ;;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...
- (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
- keyword (car *loop-source-code*) (cadr *loop-source-code*)))
- (t (loop-error "~S is an unknown keyword in LOOP macro." keyword))))))))
+ (loop-error "~S found where LOOP keyword expected." keyword))
+ (t (setq *loop-source-context* *loop-source-code*)
+ (loop-pop-source)
+ (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*)))
+ ;;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...
+ (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
+ keyword (car *loop-source-code*) (cadr *loop-source-code*)))
+ (t (loop-error "~S is an unknown keyword in LOOP macro." keyword))))))))
- (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.
- (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.
- (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*))
- (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*)))))
- (when type-spec
- (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 specifiers here.
- (if (consp variable)
- (unless (consp z)
- (loop-error
- "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected."
- z))
- (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z))
- (loop-pop-source)
- (labels ((translate (k v)
- (cond ((null k) nil)
- ((atom k)
- (replicate
- (or (gethash k (loop-universe-type-symbols *loop-universe*))
- (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*))
- (loop-error
- "Destructuring type pattern ~S contains unrecognized type keyword ~S."
- z k))
- v))
- ((atom v)
- (loop-error
- "Destructuring type pattern ~S doesn't match variable pattern ~S."
- z variable))
- (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v))))))
- (replicate (typ v)
- (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v))))))
- (translate z variable)))))))
+ (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.
+ (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.
+ (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*))
+ (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*)))))
+ (when type-spec
+ (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 specifiers here.
+ (if (consp variable)
+ (unless (consp z)
+ (loop-error
+ "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected."
+ z))
+ (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z))
+ (loop-pop-source)
+ (labels ((translate (k v)
+ (cond ((null k) nil)
+ ((atom k)
+ (replicate
+ (or (gethash k (loop-universe-type-symbols *loop-universe*))
+ (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*))
+ (loop-error
+ "Destructuring type pattern ~S contains unrecognized type keyword ~S."
+ z k))
+ v))
+ ((atom v)
+ (loop-error
+ "Destructuring type pattern ~S doesn't match variable pattern ~S."
+ z variable))
+ (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v))))))
+ (replicate (typ v)
+ (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v))))))
+ (translate z variable)))))))
- (cond ((not (null initialization))
- (push (list (setq name (loop-gentemp 'loop-ignore-))
- initialization)
- *loop-variables*)
- (push `(ignore ,name) *loop-declarations*))))
- ((atom name)
- (cond (iteration-variable-p
- (if (member name *loop-iteration-variables*)
- (loop-error "Duplicated LOOP iteration variable ~S." name)
- (push name *loop-iteration-variables*)))
- ((assoc name *loop-variables*)
- (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)
- ;; 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*))
- (initialization
- (cond (*loop-destructuring-hooks*
- (loop-declare-variable name dtype)
- (push (list name initialization) *loop-variables*))
- (t (let ((newvar (loop-gentemp '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*))
- #+ignore
- (loop-make-variable name nil dtype iteration-variable-p)))))
- (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))))
+ (cond ((not (null initialization))
+ (push (list (setq name (loop-gentemp 'loop-ignore-))
+ initialization)
+ *loop-variables*)
+ (push `(ignore ,name) *loop-declarations*))))
+ ((atom name)
+ (cond (iteration-variable-p
+ (if (member name *loop-iteration-variables*)
+ (loop-error "Duplicated LOOP iteration variable ~S." name)
+ (push name *loop-iteration-variables*)))
+ ((assoc name *loop-variables*)
+ (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)
+ ;; 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*))
+ (initialization
+ (cond (*loop-destructuring-hooks*
+ (loop-declare-variable name dtype)
+ (push (list name initialization) *loop-variables*))
+ (t (let ((newvar (loop-gentemp '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*))
+ #+ignore
+ (loop-make-variable name nil dtype iteration-variable-p)))))
+ (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))))
- (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))))
- (t (error "Invalid LOOP variable passed in: ~S." name))))
+ (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))))
+ (t (error "Invalid LOOP variable passed in: ~S." name))))
- (do ((body nil)) (nil)
- (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
- (cond ((not (symbolp key))
- (loop-error
- "~S found where keyword expected getting LOOP clause after ~S."
- key for))
- (t (setq *loop-source-context* *loop-source-code*)
- (loop-pop-source)
- (when (and (loop-tequal (car *loop-source-code*) 'it)
- first-clause-p)
- (setq *loop-source-code*
- (cons (or it-p (setq it-p (loop-when-it-variable)))
- (cdr *loop-source-code*))))
- (cond ((or (not (setq data (loop-lookup-keyword
- key (loop-universe-keywords *loop-universe*))))
- (progn (apply (symbol-function (car data)) (cdr data))
- (null *loop-body*)))
- (loop-error
- "~S does not introduce a LOOP clause that can follow ~S."
- key for))
- (t (setq body (nreconc *loop-body* body)))))))
- (setq first-clause-p nil)
- (if (loop-tequal (car *loop-source-code*) :and)
- (loop-pop-source)
- (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
- (setq then (get-clause for))
- (setq else (when (loop-tequal (car *loop-source-code*) :else)
- (loop-pop-source)
- (list (get-clause :else)))))
+ (do ((body nil)) (nil)
+ (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
+ (cond ((not (symbolp key))
+ (loop-error
+ "~S found where keyword expected getting LOOP clause after ~S."
+ key for))
+ (t (setq *loop-source-context* *loop-source-code*)
+ (loop-pop-source)
+ (when (and (loop-tequal (car *loop-source-code*) 'it)
+ first-clause-p)
+ (setq *loop-source-code*
+ (cons (or it-p (setq it-p (loop-when-it-variable)))
+ (cdr *loop-source-code*))))
+ (cond ((or (not (setq data (loop-lookup-keyword
+ key (loop-universe-keywords *loop-universe*))))
+ (progn (apply (symbol-function (car data)) (cdr data))
+ (null *loop-body*)))
+ (loop-error
+ "~S does not introduce a LOOP clause that can follow ~S."
+ key for))
+ (t (setq body (nreconc *loop-body* body)))))))
+ (setq first-clause-p nil)
+ (if (loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
+ (setq then (get-clause for))
+ (setq else (when (loop-tequal (car *loop-source-code*) :else)
+ (loop-pop-source)
+ (list (get-clause :else)))))
- (when (and name (loop-variable-p name))
- (loop-error "Variable ~S cannot be used in INTO clause" name))
- (push (setq cruft (make-loop-collector
- :name name :class class
- :history (list collector) :dtype dtype))
- *loop-collection-cruft*))
- (t (unless (eq (loop-collector-class cruft) class)
- (loop-error
- "Incompatible kinds of LOOP value accumulation specified for collecting~@
- ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S."
- name (car (loop-collector-history cruft)) collector))
- (unless (equal dtype (loop-collector-dtype cruft))
- (loop-warn
- "Unequal datatypes specified in different LOOP value accumulations~@
- into ~S: ~S and ~S."
- name dtype (loop-collector-dtype cruft))
- (when (eq (loop-collector-dtype cruft) t)
- (setf (loop-collector-dtype cruft) dtype)))
- (push collector (loop-collector-history cruft))))
+ (when (and name (loop-variable-p name))
+ (loop-error "Variable ~S cannot be used in INTO clause" name))
+ (push (setq cruft (make-loop-collector
+ :name name :class class
+ :history (list collector) :dtype dtype))
+ *loop-collection-cruft*))
+ (t (unless (eq (loop-collector-class cruft) class)
+ (loop-error
+ "Incompatible kinds of LOOP value accumulation specified for collecting~@
+ ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S."
+ name (car (loop-collector-history cruft)) collector))
+ (unless (equal dtype (loop-collector-dtype cruft))
+ (loop-warn
+ "Unequal datatypes specified in different LOOP value accumulations~@
+ into ~S: ~S and ~S."
+ name dtype (loop-collector-dtype cruft))
+ (when (eq (loop-collector-dtype cruft) t)
+ (setf (loop-collector-dtype cruft) dtype)))
+ (push collector (loop-collector-history cruft))))
- (setf (loop-collector-tempvars lc)
- (setq tempvars (list* (loop-gentemp 'loop-list-head-)
- (loop-gentemp 'loop-list-tail-)
- (and (loop-collector-name lc)
- (list (loop-collector-name lc))))))
- (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
- (unless (loop-collector-name lc)
- (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars)))))
+ (setf (loop-collector-tempvars lc)
+ (setq tempvars (list* (loop-gentemp 'loop-list-head-)
+ (loop-gentemp 'loop-list-tail-)
+ (and (loop-collector-name lc)
+ (list (loop-collector-name lc))))))
+ (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars)))))
- (setf (loop-collector-tempvars lc)
- (setq tempvars (list (loop-make-variable
- (or (loop-collector-name lc)
- (loop-gentemp 'loop-sum-))
- nil (loop-collector-dtype lc)))))
- (unless (loop-collector-name lc)
- (loop-emit-final-value (car (loop-collector-tempvars lc)))))
+ (setf (loop-collector-tempvars lc)
+ (setq tempvars (list (loop-make-variable
+ (or (loop-collector-name lc)
+ (loop-gentemp 'loop-sum-))
+ nil (loop-collector-dtype lc)))))
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value (car (loop-collector-tempvars lc)))))
- (setf (loop-collector-data lc)
- (setq data (make-loop-minimax
- (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-))
- (loop-collector-dtype lc))))
- (unless (loop-collector-name lc)
- (loop-emit-final-value (loop-minimax-answer-variable data))))
+ (setf (loop-collector-data lc)
+ (setq data (make-loop-minimax
+ (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-))
+ (loop-collector-dtype lc))))
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value (loop-minimax-answer-variable data))))
(unless tem (setq tem data))
(when (car tem) (push (car tem) pre-loop-pre-step-tests))
(setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
(when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
(setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
(unless (loop-tequal (car *loop-source-code*) :and)
(unless tem (setq tem data))
(when (car tem) (push (car tem) pre-loop-pre-step-tests))
(setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
(when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
(setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
(unless (loop-tequal (car *loop-source-code*) :and)
- (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps)
- (make-endtest pre-loop-post-step-tests)
- (loop-make-psetq pre-loop-steps)
- (make-endtest pre-loop-pre-step-tests)
- *loop-before-loop*)
- *loop-after-body* (list* (loop-make-desetq pseudo-steps)
- (make-endtest post-step-tests)
- (loop-make-psetq steps)
- (make-endtest pre-step-tests)
- *loop-after-body*))
- (loop-bind-block)
- (return nil))
- (loop-pop-source) ; flush the "AND"
+ (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps)
+ (make-endtest pre-loop-post-step-tests)
+ (loop-make-psetq pre-loop-steps)
+ (make-endtest pre-loop-pre-step-tests)
+ *loop-before-loop*)
+ *loop-after-body* (list* (loop-make-desetq pseudo-steps)
+ (make-endtest post-step-tests)
+ (loop-make-psetq steps)
+ (make-endtest pre-step-tests)
+ *loop-after-body*))
+ (loop-bind-block)
+ (return nil))
+ (loop-pop-source) ; flush the "AND"
- ;;Then we are the same as "FOR x FIRST y THEN z".
- (loop-pop-source)
- `(() (,var ,(loop-get-form)) () ()
- () (,var ,val) () ()))
- (t ;;We are the same as "FOR x = y".
- ;; Let me document here what this is returning. Look at
- ;; loop-hack-iteration for more info. But anyway, we return a list of
- ;; 8 items, in this order: PRE-STEP-TESTS, STEPS, POST-STEP-TESTS,
- ;; PSEUDO-STEPS, PRE-LOOP-PRE-STEP-TESTS, PRE-LOOP-STEPS,
- ;; PRE-LOOP-POST-STEP-TESTS, PRE-LOOP-PSEUDO-STEPS. (We should add
- ;; something to make it easier to figure out what these args are!)
- ;;
- ;; For a "FOR x = y" clause without the THEN, we want the STEPS item to
- ;; step the variable VAR with the value VAL. This gets placed in the
- ;; body of the loop. The original code just did that. It seems that
- ;; the STEPS form is placed in *loop-before-loop* and in
- ;; *loop-after-loop*. Loop optimization would then see the same form
- ;; in both, and move them into the beginning of body. This is ok,
- ;; except that if there are :initially forms that were placed into the
- ;; loop prologue, the :initially forms might refer to incorrectly
- ;; initialized variables, because the optimizer moved STEPS from from
- ;; *loop-before-loop* into the body.
- ;;
- ;; To solve this, we add a PRE-LOOP-PSEUDO-STEP form that is identical
- ;; to the STEPS form. This gets placed in *loop-before-loop*. But
- ;; this won't match any *loop-after-loop* form, so it won't get moved,
- ;; and we maintain the proper sequencing such that the
- ;; PRE-LOOP-PSEUDO-STEP form is in *loop-before-loop*, before any
- ;; :initially clauses that might refer to this. So all is well. Whew.
- ;;
- ;; I hope this doesn't break anything else.
- `(() (,var ,val) () ()
- () () () (,var ,val))
- )))
+ ;;Then we are the same as "FOR x FIRST y THEN z".
+ (loop-pop-source)
+ `(() (,var ,(loop-get-form)) () ()
+ () (,var ,val) () ()))
+ (t ;;We are the same as "FOR x = y".
+ ;; Let me document here what this is returning. Look at
+ ;; loop-hack-iteration for more info. But anyway, we return a list of
+ ;; 8 items, in this order: PRE-STEP-TESTS, STEPS, POST-STEP-TESTS,
+ ;; PSEUDO-STEPS, PRE-LOOP-PRE-STEP-TESTS, PRE-LOOP-STEPS,
+ ;; PRE-LOOP-POST-STEP-TESTS, PRE-LOOP-PSEUDO-STEPS. (We should add
+ ;; something to make it easier to figure out what these args are!)
+ ;;
+ ;; For a "FOR x = y" clause without the THEN, we want the STEPS item to
+ ;; step the variable VAR with the value VAL. This gets placed in the
+ ;; body of the loop. The original code just did that. It seems that
+ ;; the STEPS form is placed in *loop-before-loop* and in
+ ;; *loop-after-loop*. Loop optimization would then see the same form
+ ;; in both, and move them into the beginning of body. This is ok,
+ ;; except that if there are :initially forms that were placed into the
+ ;; loop prologue, the :initially forms might refer to incorrectly
+ ;; initialized variables, because the optimizer moved STEPS from from
+ ;; *loop-before-loop* into the body.
+ ;;
+ ;; To solve this, we add a PRE-LOOP-PSEUDO-STEP form that is identical
+ ;; to the STEPS form. This gets placed in *loop-before-loop*. But
+ ;; this won't match any *loop-after-loop* form, so it won't get moved,
+ ;; and we maintain the proper sequencing such that the
+ ;; PRE-LOOP-PSEUDO-STEP form is in *loop-before-loop*, before any
+ ;; :initially clauses that might refer to this. So all is well. Whew.
+ ;;
+ ;; I hope this doesn't break anything else.
+ `(() (,var ,val) () ()
+ () () () (,var ,val))
+ )))
- (length-form (cond ((not constantp)
- (let ((v (loop-gentemp 'loop-across-limit-)))
- ;; This used to just push the length
- ;; computation into the prologue code. I
- ;; (rtoy) don't think that's right,
- ;; especially since the prologue is supposed
- ;; to happen AFTER other initializations.
- ;; So, this puts the computation in
- ;; *loop-before-body*. We need a matching
- ;; entry for *loop-after-body*, so stuff a
- ;; NIL there.
- (push `(setq ,v (length ,vector-var)) *loop-before-loop*)
- (push nil *loop-after-body*)
- (loop-make-variable v 0 'fixnum)))
- (t (setq length (length vector-value)))))
- (first-test `(>= ,index-var ,length-form))
- (other-test first-test)
- (step `(,var (aref ,vector-var ,index-var)))
- (pstep `(,index-var (1+ ,index-var))))
- (declare (fixnum length))
- (when constantp
- (setq first-test (= length 0))
- (when (<= length 1)
- (setq other-test t)))
- `(,other-test ,step () ,pstep
- ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep)))))))
+ (length-form (cond ((not constantp)
+ (let ((v (loop-gentemp 'loop-across-limit-)))
+ ;; This used to just push the length
+ ;; computation into the prologue code. I
+ ;; (rtoy) don't think that's right,
+ ;; especially since the prologue is supposed
+ ;; to happen AFTER other initializations.
+ ;; So, this puts the computation in
+ ;; *loop-before-body*. We need a matching
+ ;; entry for *loop-after-body*, so stuff a
+ ;; NIL there.
+ (push `(setq ,v (length ,vector-var)) *loop-before-loop*)
+ (push nil *loop-after-body*)
+ (loop-make-variable v 0 'fixnum)))
+ (t (setq length (length vector-value)))))
+ (first-test `(>= ,index-var ,length-form))
+ (other-test first-test)
+ (step `(,var (aref ,vector-var ,index-var)))
+ (pstep `(,index-var (1+ ,index-var))))
+ (declare (fixnum length))
+ (when constantp
+ (setq first-test (= length 0))
+ (when (<= length 1)
+ (setq other-test t)))
+ `(,other-test ,step () ,pstep
+ ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep)))))))
- (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.")
- (values `(funcall ,stepper ,listvar) nil))
- ((and (consp stepper) (eq (car stepper) 'function))
- (values (list (cadr stepper) listvar) (cadr stepper)))
- (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function)
- ,listvar)
- nil)))))
+ (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.")
+ (values `(funcall ,stepper ,listvar) nil))
+ ((and (consp stepper) (eq (car stepper) 'function))
+ (values (list (cadr stepper) listvar) (cadr stepper)))
+ (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function)
+ ,listvar)
+ nil)))))
- (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function))
- ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
- (let* ((first-endtest
- (hide-variable-reference
- (eq var listvar)
- listvar
- ;; 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)) ,other-endtest
- () () () ,first-endtest ()))
- #+LOOP-Prefer-POP
- ((and step-function
- (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2)
- (cdddr . 3) (cddddr . 4))))))
- (and n (do ((l var (cdr l)) (i 0 (1+ i)))
- ((atom l) (and (null l) (= i n)))
- (declare (fixnum i))))))
- (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var)))
- `(,other-endtest () () ,step ,first-endtest () () ,step)))
- (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step)))
- `(,other-endtest ,step () ,pseudo
- ,@(and (not (eq first-endtest other-endtest))
- `(,first-endtest ,step () ,pseudo)))))))))))
+ (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function))
+ ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
+ (let* ((first-endtest
+ (hide-variable-reference
+ (eq var listvar)
+ listvar
+ ;; 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)) ,other-endtest
+ () () () ,first-endtest ()))
+ #+LOOP-Prefer-POP
+ ((and step-function
+ (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2)
+ (cdddr . 3) (cddddr . 4))))))
+ (and n (do ((l var (cdr l)) (i 0 (1+ i)))
+ ((atom l) (and (null l) (= i n)))
+ (declare (fixnum i))))))
+ (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var)))
+ `(,other-endtest () () ,step ,first-endtest () () ,step)))
+ (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step)))
+ `(,other-endtest ,step () ,pseudo
+ ,@(and (not (eq first-endtest other-endtest))
+ `(,first-endtest ,step () ,pseudo)))))))))))
- #-LOOP-Prefer-POP (declare (ignore step-function))
- (let* ((first-endtest `(endp ,listvar))
- (other-endtest first-endtest)
- (step `(,var (car ,listvar)))
- (pseudo-step `(,listvar ,list-step)))
- (when (and constantp (listp list-value))
- (setq first-endtest (null list-value)))
- #+LOOP-Prefer-POP (when (eq step-function 'cdr)
- (setq step `(,var (pop ,listvar)) pseudo-step nil))
- `(,other-endtest ,step () ,pseudo-step
- ,@(and (not (eq first-endtest other-endtest))
- `(,first-endtest ,step () ,pseudo-step))))))))
+ #-LOOP-Prefer-POP (declare (ignore step-function))
+ (let* ((first-endtest `(endp ,listvar))
+ (other-endtest first-endtest)
+ (step `(,var (car ,listvar)))
+ (pseudo-step `(,listvar ,list-step)))
+ (when (and constantp (listp list-value))
+ (setq first-endtest (null list-value)))
+ #+LOOP-Prefer-POP (when (eq step-function 'cdr)
+ (setq step `(,var (pop ,listvar)) pseudo-step nil))
+ `(,other-endtest ,step () ,pseudo-step
+ ,@(and (not (eq first-endtest other-endtest))
+ `(,first-endtest ,step () ,pseudo-step))))))))
- ((loop-tequal (car *loop-source-code*) :and)
- (loop-pop-source)
- (setq inclusive t)
- (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her))
- (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax."
- (car *loop-source-code*)))
- (loop-pop-source)
- (setq path (loop-pop-source))
- (setq initial-prepositions `((:in ,val))))
- (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?")))
+ ((loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (setq inclusive t)
+ (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her))
+ (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax."
+ (car *loop-source-code*)))
+ (loop-pop-source)
+ (setq path (loop-pop-source))
+ (setq initial-prepositions `((:in ,val))))
+ (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?")))
(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.
(unless (member (length stuff) '(6 10))
(loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
(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.
(unless (member (length stuff) '(6 10))
(loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
- (when (member this-prep disallowed-prepositions)
- (loop-error
- (if (member this-prep used-prepositions)
- "A ~S prepositional phrase occurs multiply for some LOOP clause."
- "Preposition ~S used when some other preposition has subsumed it.")
- token))
- (setq used-prepositions (if (listp this-group)
- (append this-group used-prepositions)
- (cons this-group used-prepositions)))
- (loop-pop-source)
- (push (list this-prep (loop-get-form)) prepositional-phrases))
- ((and USING-allowed (loop-tequal token 'using))
- (loop-pop-source)
- (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
- (when (cadr z)
- (if (setq tem (loop-tassoc (car z) *loop-named-variables*))
- (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*)))
- (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*)))
- (return nil))))
- (t (return (nreverse prepositional-phrases)))))))
+ (when (member this-prep disallowed-prepositions)
+ (loop-error
+ (if (member this-prep used-prepositions)
+ "A ~S prepositional phrase occurs multiply for some LOOP clause."
+ "Preposition ~S used when some other preposition has subsumed it.")
+ token))
+ (setq used-prepositions (if (listp this-group)
+ (append this-group used-prepositions)
+ (cons this-group used-prepositions)))
+ (loop-pop-source)
+ (push (list this-prep (loop-get-form)) prepositional-phrases))
+ ((and USING-allowed (loop-tequal token 'using))
+ (loop-pop-source)
+ (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
+ (when (cadr z)
+ (if (setq tem (loop-tassoc (car z) *loop-named-variables*))
+ (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*)))
+ (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*)))
+ (return nil))))
+ (t (return (nreverse prepositional-phrases)))))))
- variable variable-type
- sequence-variable sequence-type
- step-hack default-top
- prep-phrases)
- (let ((endform nil) ;Form (constant or variable) with limit value.
- (sequencep nil) ;T if sequence arg has been provided.
- (testfn nil) ;endtest function
- (test nil) ;endtest form.
- (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment.
- (stepby-constantp t)
- (step nil) ;step form.
- (dir nil) ;Direction of stepping: NIL, :UP, :DOWN.
- (inclusive-iteration nil) ;T if include last index.
- (start-given nil) ;T when prep phrase has specified start
- (start-value nil)
- (start-constantp nil)
- (limit-given nil) ;T when prep phrase has specified end
- (limit-constantp nil)
- (limit-value nil)
- )
+ variable variable-type
+ sequence-variable sequence-type
+ step-hack default-top
+ prep-phrases)
+ (let ((endform nil) ;Form (constant or variable) with limit value.
+ (sequencep nil) ;T if sequence arg has been provided.
+ (testfn nil) ;endtest function
+ (test nil) ;endtest form.
+ (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment.
+ (stepby-constantp t)
+ (step nil) ;step form.
+ (dir nil) ;Direction of stepping: NIL, :UP, :DOWN.
+ (inclusive-iteration nil) ;T if include last index.
+ (start-given nil) ;T when prep phrase has specified start
+ (start-value nil)
+ (start-constantp nil)
+ (limit-given nil) ;T when prep phrase has specified end
+ (limit-constantp nil)
+ (limit-value nil)
+ )
- ((:of :in)
- (setq sequencep t)
- (loop-make-variable 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))
- ((:upto :to :downto :above :below)
- (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up)))
- ((loop-tequal prep :to) (setq inclusive-iteration t))
- ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down)))
- ((loop-tequal prep :above) (setq dir ':down))
- ((loop-tequal prep :below) (setq dir ':up)))
- (setq limit-given t)
- (multiple-value-setq (form limit-constantp limit-value)
- (loop-constant-fold-if-possible form indexv-type))
- (setq endform (if limit-constantp
- `',limit-value
- (loop-make-variable
- (loop-gentemp '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-)) form indexv-type)))
- (t (loop-error
- "~S invalid preposition in sequencing or sequence path.~@
- Invalid prepositions specified in iteration path descriptor or something?"
- prep)))
+ ((:of :in)
+ (setq sequencep t)
+ (loop-make-variable 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))
+ ((:upto :to :downto :above :below)
+ (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up)))
+ ((loop-tequal prep :to) (setq inclusive-iteration t))
+ ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down)))
+ ((loop-tequal prep :above) (setq dir ':down))
+ ((loop-tequal prep :below) (setq dir ':up)))
+ (setq limit-given t)
+ (multiple-value-setq (form limit-constantp limit-value)
+ (loop-constant-fold-if-possible form indexv-type))
+ (setq endform (if limit-constantp
+ `',limit-value
+ (loop-make-variable
+ (loop-gentemp '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-)) form indexv-type)))
+ (t (loop-error
+ "~S invalid preposition in sequencing or sequence path.~@
+ Invalid prepositions specified in iteration path descriptor or something?"
+ prep)))
- (when (or limit-given default-top)
- (unless limit-given
- (loop-make-variable (setq endform (loop-gentemp '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))))
- (t (unless start-given
- (unless default-top
- (loop-error "Don't know where to start stepping."))
- (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
- (when (and default-top (not endform))
- (setq endform (loop-typed-init indexv-type) inclusive-iteration t))
- (when endform (setq testfn (if inclusive-iteration '< '<=)))
- (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
+ (when (or limit-given default-top)
+ (unless limit-given
+ (loop-make-variable (setq endform (loop-gentemp '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))))
+ (t (unless start-given
+ (unless default-top
+ (loop-error "Don't know where to start stepping."))
+ (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
+ (when (and default-top (not endform))
+ (setq endform (loop-typed-init indexv-type) inclusive-iteration t))
+ (when endform (setq testfn (if inclusive-iteration '< '<=)))
+ (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
(when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
(when step-hack
(setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack))))
(let ((first-test test) (remaining-tests test))
(when (and stepby-constantp start-constantp limit-constantp)
(when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
(when step-hack
(setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack))))
(let ((first-test test) (remaining-tests test))
(when (and stepby-constantp start-constantp limit-constantp)
- (symbolp sequencev)
- sequence-type
- (subtypep sequence-type 'vector)
- (not (member (the symbol sequencev) *loop-nodeclare*)))
- (push `(sys:array-register ,sequencev) *loop-declarations*))
- (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)))))
+ (symbolp sequencev)
+ sequence-type
+ (subtypep sequence-type 'vector)
+ (not (member (the symbol sequencev) *loop-nodeclare*)))
+ (push `(sys:array-register ,sequencev) *loop-declarations*))
+ (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)))))
- (val-var nil)
- (temp-val-var (loop-gentemp 'loop-hash-val-temp-))
- (temp-key-var (loop-gentemp 'loop-hash-key-temp-))
- (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-))
- (variable (or variable (loop-gentemp)))
- (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))
- (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
- (when (consp key-var)
- (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
- ,@post-steps))
- (push `(,key-var nil) bindings))
- (when (consp val-var)
- (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
- ,@post-steps))
- (push `(,val-var nil) bindings))
- `(,bindings ;bindings
- () ;prologue
- () ;pre-test
- () ;parallel steps
- (not
- (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var)
- (,next-fn)
- ;; We use M-V-BIND instead of M-V-SETQ because we only
- ;; want to assign values to the key and val vars when we
- ;; are in the hash table. When we reach the end,
- ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and
- ;; temp-val-var. This might break any type declarations
- ;; on the key and val vars.
- (when ,temp-predicate-var
- (setq ,val-var ,temp-val-var)
- (setq ,key-var ,temp-key-var))
- (setq ,dummy-predicate-var ,temp-predicate-var)
- )) ;post-test
- ,post-steps)))))
+ (val-var nil)
+ (temp-val-var (loop-gentemp 'loop-hash-val-temp-))
+ (temp-key-var (loop-gentemp 'loop-hash-key-temp-))
+ (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-))
+ (variable (or variable (loop-gentemp)))
+ (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))
+ (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
+ (when (consp key-var)
+ (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
+ ,@post-steps))
+ (push `(,key-var nil) bindings))
+ (when (consp val-var)
+ (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
+ ,@post-steps))
+ (push `(,val-var nil) bindings))
+ `(,bindings ;bindings
+ () ;prologue
+ () ;pre-test
+ () ;parallel steps
+ (not
+ (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var)
+ (,next-fn)
+ ;; We use M-V-BIND instead of M-V-SETQ because we only
+ ;; want to assign values to the key and val vars when we
+ ;; are in the hash table. When we reach the end,
+ ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and
+ ;; temp-val-var. This might break any type declarations
+ ;; on the key and val vars.
+ (when ,temp-predicate-var
+ (setq ,val-var ,temp-val-var)
+ (setq ,key-var ,temp-key-var))
+ (setq ,dummy-predicate-var ,temp-predicate-var)
+ )) ;post-test
+ ,post-steps)))))
(push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
`(((,variable nil ,data-type) (,pkg-var ,pkg))
()
()
()
(not (multiple-value-setq (,(progn
(push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
`(((,variable nil ,data-type) (,pkg-var ,pkg))
()
()
()
(not (multiple-value-setq (,(progn
- (while (loop-do-while nil :while)) ; Normal, do while
- (until (loop-do-while t :until)) ; Negate the test on while
- (when (loop-do-if when nil)) ; Normal, do when
- (if (loop-do-if if nil)) ; synonymous
- (unless (loop-do-if unless t)) ; Negate the test on when
+ (while (loop-do-while nil :while)) ; Normal, do while
+ (until (loop-do-while t :until)) ; Negate the test on while
+ (when (loop-do-if when nil)) ; Normal, do when
+ (if (loop-do-if if nil)) ; synonymous
+ (unless (loop-do-if unless t)) ; Negate the test on when