;;; end of the list might be suboptimal because the end of the list will
;;; probably be RPLACDed and so cdr-normal should be used instead.
(defmacro loop-copylist* (l)
- #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted)
+ #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted)
;;@@@@Explorer??
#-Genera `(copy-list ,l)
)
;; replaced with the appropriate conditional name for your
;; implementation/dialect.
(declare #-ANSI (ignore env)
- #+Genera (values speed space safety compilation-speed debug))
+ #+Genera (values speed space safety compilation-speed debug))
#+ANSI (let ((stuff (declaration-information 'optimize env)))
- (values (or (cdr (assoc 'speed stuff)) 1)
- (or (cdr (assoc 'space stuff)) 1)
- (or (cdr (assoc 'safety stuff)) 1)
- (or (cdr (assoc 'compilation-speed stuff)) 1)
- (or (cdr (assoc 'debug stuff)) 1)))
+ (values (or (cdr (assoc 'speed stuff)) 1)
+ (or (cdr (assoc 'space stuff)) 1)
+ (or (cdr (assoc 'safety stuff)) 1)
+ (or (cdr (assoc 'compilation-speed stuff)) 1)
+ (or (cdr (assoc 'debug stuff)) 1)))
#+CLOE-Runtime (values compiler::time compiler::space
- compiler::safety compiler::compilation-speed 1)
+ compiler::safety compiler::compilation-speed 1)
#-(or ANSI CLOE-Runtime) (values 1 1 1 1 1))
;;; for all callers to contain the conditional invisibility construction.
(defun hide-variable-reference (really-hide variable form)
(declare #-Genera (ignore really-hide variable))
- #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns
- `(compiler:invisible-references (,variable) ,form)
- form)
+ #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns
+ `(compiler:invisible-references (,variable) ,form)
+ form)
#-Genera form)
\f
(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var)
- &body body)
+ &body body)
;;@@@@ TI? Exploder?
#+LISPM (let ((head-place (or user-head-var head-var)))
- `(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))
#-LISPM (let ((l (and user-head-var (list (list user-head-var nil)))))
- #+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)))
(defmacro loop-collect-rplacd (&environment env
- (head-var tail-var &optional user-head-var) form)
+ (head-var tail-var &optional user-head-var) form)
(declare
- #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail.
+ #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail.
)
(setq form (macroexpand form env))
(flet ((cdr-wrap (form n)
- (declare (fixnum n))
- (do () ((<= n 4) (setq form `(,(case n
- (1 'cdr)
- (2 'cddr)
- (3 'cdddr)
- (4 'cddddr))
- ,form)))
- (setq form `(cddddr ,form) n (- n 4)))))
+ (declare (fixnum n))
+ (do () ((<= n 4) (setq form `(,(case n
+ (1 'cdr)
+ (2 'cddr)
+ (3 'cdddr)
+ (4 'cddddr))
+ ,form)))
+ (setq form `(cddddr ,form) n (- n 4)))))
(let ((tail-form form) (ncdrs nil))
;;Determine if the form being constructed is a list of known length.
(when (consp form)
- (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))))))
(let ((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))))
+ (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))))
(defmacro loop-collect-answer (head-var &optional user-head-var)
(or user-head-var
(progn
- ;;If we use locatives to get tail-updating to update the head var,
- ;; then the head var itself contains the answer. Otherwise we
- ;; have to cdr it.
- #+LISPM head-var
- #-LISPM `(cdr ,head-var))))
+ ;;If we use locatives to get tail-updating to update the head var,
+ ;; then the head var itself contains the answer. Otherwise we
+ ;; have to cdr it.
+ #+LISPM head-var
+ #-LISPM `(cdr ,head-var))))
\f
;;;; Maximization Technology
(defstruct (loop-minimax
- (:constructor make-loop-minimax-internal)
- (:copier nil)
- (:predicate nil))
+ (:constructor make-loop-minimax-internal)
+ (:copier nil)
+ (:predicate nil))
answer-variable
type
temp-variable
(defvar *loop-minimax-type-infinities-alist*
- ;;@@@@ 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))
+ )
(defun make-loop-minimax (answer-variable type)
(defun loop-note-minimax-operation (operation minimax)
(pushnew (the symbol operation) (loop-minimax-operations minimax))
(when (and (cdr (loop-minimax-operations minimax))
- (not (loop-minimax-flag-variable minimax)))
+ (not (loop-minimax-flag-variable minimax)))
(setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-)))
operation)
(defmacro with-minimax-value (lm &body body)
(let ((init (loop-typed-init (loop-minimax-type lm)))
- (which (car (loop-minimax-operations lm)))
- (infinity-data (loop-minimax-infinity-data lm))
- (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)))
(if flag-var
- `(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))))
(defmacro loop-accumulate-minimax-value (lm operation form)
(let* ((answer-var (loop-minimax-answer-variable lm))
- (temp-var (loop-minimax-temp-variable lm))
- (flag-var (loop-minimax-flag-variable lm))
- (test
- (hide-variable-reference
- t (loop-minimax-answer-variable lm)
- `(,(ecase operation
- (min '<)
- (max '>))
- ,temp-var ,answer-var))))
+ (temp-var (loop-minimax-temp-variable lm))
+ (flag-var (loop-minimax-flag-variable lm))
+ (test
+ (hide-variable-reference
+ t (loop-minimax-answer-variable lm)
+ `(,(ecase operation
+ (min '<)
+ (max '>))
+ ,temp-var ,answer-var))))
`(progn
(setq ,temp-var ,form)
(when ,(if flag-var `(or (not ,flag-var) ,test) test)
- (setq ,@(and flag-var `(,flag-var t))
- ,answer-var ,temp-var)))))
+ (setq ,@(and flag-var `(,flag-var t))
+ ,answer-var ,temp-var)))))
\f
(defstruct (loop-universe
- (: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
)
(defvar *loop-destructuring-hooks*
- nil
+ nil
"If not NIL, this must be a list of two things:
a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.")
(defun loop-make-psetq (frobs)
(and frobs
(loop-make-desetq
- (list (car frobs)
- (if (null (cddr frobs)) (cadr frobs)
- `(prog1 ,(cadr frobs)
- ,(loop-make-psetq (cddr frobs))))))))
+ (list (car frobs)
+ (if (null (cddr frobs)) (cadr frobs)
+ `(prog1 ,(cadr frobs)
+ ,(loop-make-psetq (cddr 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)))
+ (cadr *loop-destructuring-hooks*)
+ 'loop-really-desetq)
+ var-val-pairs)))
(defvar *loop-desetq-temporary*
- (make-symbol "LOOP-DESETQ-TEMP"))
+ (make-symbol "LOOP-DESETQ-TEMP"))
(defmacro loop-really-desetq (&environment env &rest var-val-pairs)
(labels ((find-non-null (var)
- ;; 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)))))))
(do ((actions))
- ((null var-val-pairs)
- (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
+ ((null var-val-pairs)
+ (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
(setq actions (revappend
- (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs))
- actions)))))
+ (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs))
+ actions)))))
\f
;;;; LOOP-local variables
;;;List of all the value-accumulation descriptor structures in the loop.
;;; See loop-get-collection-info.
-(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc)
+(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc)
\f
;;;; Code Analysis Stuff
#+Genera (declare (values new-form constantp constant-value))
(let ((new-form form) (constantp nil) (constant-value nil))
#+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment*
- :repeat t
- :do-macro-expansion t
- :do-named-constants t
- :do-inline-forms t
- :do-optimizers t
- :do-constant-folding t
- :do-function-args t)
- constantp (constantp new-form *loop-macro-environment*)
- constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*)))
+ :repeat t
+ :do-macro-expansion t
+ :do-named-constants t
+ :do-inline-forms t
+ :do-optimizers t
+ :do-constant-folding t
+ :do-function-args t)
+ constantp (constantp new-form *loop-macro-environment*)
+ constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*)))
#-Genera (when (setq constantp (constantp new-form))
- (setq constant-value (eval new-form)))
+ (setq constant-value (eval new-form)))
(when (and constantp expected-type)
(unless (typep constant-value expected-type)
- (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
- form constant-value expected-type)
- (setq constantp nil constant-value nil)))
+ (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
+ form constant-value expected-type)
+ (setq constantp nil constant-value nil)))
(values new-form constantp constant-value)))
;;;; LOOP Iteration Optimization
(defvar *loop-duplicate-code*
- nil)
+ nil)
(defvar *loop-iteration-flag-variable*
- (make-symbol "LOOP-NOT-FIRST-TIME"))
+ (make-symbol "LOOP-NOT-FIRST-TIME"))
(defun loop-code-duplication-threshold (env)
(defmacro loop-body (&environment env
- prologue
- before-loop
- main-body
- after-loop
- epilogue
- &aux rbefore rafter flagvar)
+ prologue
+ before-loop
+ main-body
+ after-loop
+ epilogue
+ &aux rbefore rafter flagvar)
(unless (= (length before-loop) (length after-loop))
(error "LOOP-BODY called with non-synched before- and after-loop lists."))
;;All our work is done from these copies, working backwards from the end:
(setq rbefore (reverse before-loop) rafter (reverse after-loop))
(labels ((psimp (l)
- (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))))
(when (or *loop-duplicate-code* (not rbefore))
(return-from loop-body (makebody)))
;; This outer loop iterates once for each not-first-time flag test generated
;; Go backwards from the ends of before-loop and after-loop merging all the equivalent
;; forms into the body.
(do () ((or (null rbefore) (not (equal (car rbefore) (car rafter)))))
- (push (pop rbefore) main-body)
- (pop rafter))
+ (push (pop rbefore) main-body)
+ (pop rafter))
(unless rbefore (return (makebody)))
;; The first forms in rbefore & rafter (which are the chronologically
;; last forms in the list) differ, therefore they cannot be moved
;; What chronologically precedes the non-duplicatable form will
;; be handled the next time around the outer loop.
(do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil))
- ((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)))))))
\f
(defun duplicatable-code-p (expr env)
(if (null expr) 0
(let ((ans (estimate-code-size expr env)))
- (declare (fixnum ans))
- ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of
- ;; optimize quantities back to help quantify how much code we are willing to
- ;; duplicate.
- ans)))
+ (declare (fixnum ans))
+ ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of
+ ;; optimize quantities back to help quantify how much code we are willing to
+ ;; duplicate.
+ ans)))
(defvar *special-code-sizes*
- '((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)))
(defvar *estimate-code-size-punt*
- '(block
- do do* dolist
- flet
- labels lambda let let* locally
- macrolet multiple-value-bind
- prog prog*
- symbol-macrolet
- tagbody
- unwind-protect
- with-open-file))
+ '(block
+ do do* dolist
+ flet
+ labels lambda let let* locally
+ macrolet multiple-value-bind
+ prog prog*
+ symbol-macrolet
+ tagbody
+ unwind-protect
+ with-open-file))
(defun destructuring-size (x)
(defun estimate-code-size-1 (x env)
(flet ((list-size (l)
- (let ((n 0))
- (declare (fixnum n))
- (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
+ (let ((n 0))
+ (declare (fixnum n))
+ (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
;;@@@@ ???? (declare (function list-size (list) fixnum))
(cond ((constantp x #+Genera env) 1)
- ((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.
#-cmu 1
#+cmu (if (ext:valid-function-name-p (cadr x))
1
(throw 'duplicatable-code-p 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)))))
+ ((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)))))
\f
;;;; Loop Errors
(defun loop-error (format-string &rest format-args)
#+(or Genera CLOE) (declare (dbg:error-reporter))
- #+Genera (setq format-args (copy-list format-args)) ;Don't ask.
+ #+Genera (setq format-args (copy-list format-args)) ;Don't ask.
#+cmu
(kernel:simple-program-error "~?~%Current LOOP context:~{ ~S~}."
- format-string format-args (loop-context))
+ format-string format-args (loop-context))
#-cmu
(error "~?~%Current LOOP context:~{ ~S~}."
format-string format-args (loop-context)))
(defun loop-check-data-type (specified-type required-type
- &optional (default-type required-type))
+ &optional (default-type required-type))
(if (null specified-type)
default-type
(multiple-value-bind (a b) (subtypep specified-type required-type)
- (cond ((not b)
- (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
- specified-type required-type))
- ((not a)
- (loop-error "Specified data type ~S is not a subtype of ~S."
- specified-type required-type)))
- specified-type)))
+ (cond ((not b)
+ (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
+ specified-type required-type))
+ ((not a)
+ (loop-error "Specified data type ~S is not a subtype of ~S."
+ specified-type required-type)))
+ specified-type)))
\f
;;;INTERFACE: Traditional, ANSI, Lucid.
((null tree) (car (push (loop-gentemp) *ignores*)))
((atom tree) tree)
(t (cons (subst-gensyms-for-nil (car tree))
- (subst-gensyms-for-nil (cdr tree))))))
+ (subst-gensyms-for-nil (cdr tree))))))
(defun loop-build-destructuring-bindings (crocks forms)
(if crocks
(let ((*ignores* ()))
- (declare (special *ignores*))
- `((destructuring-bind ,(subst-gensyms-for-nil (car crocks))
- ,(cadr crocks)
- (declare (ignore ,@*ignores*))
- ,@(loop-build-destructuring-bindings (cddr crocks) forms))))
+ (declare (special *ignores*))
+ `((destructuring-bind ,(subst-gensyms-for-nil (car crocks))
+ ,(cadr crocks)
+ (declare (ignore ,@*ignores*))
+ ,@(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-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))
(loop-iteration-driver)
(loop-bind-block)
(let ((answer `(loop-body
- ,(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*)))))
(dolist (entry *loop-bind-stack*)
- (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)))))))
(if *loop-names*
- (do () ((null (car *loop-names*)) answer)
- (setq answer `(block ,(pop *loop-names*) ,answer)))
- `(block nil ,answer)))))
+ (do () ((null (car *loop-names*)) answer)
+ (setq answer `(block ,(pop *loop-names*) ,answer)))
+ `(block nil ,answer)))))
(defun loop-iteration-driver ()
(do () ((null *loop-source-code*))
(let ((keyword (car *loop-source-code*)) (tem nil))
(cond ((not (symbolp 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))))))))
+ (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))))))))
\f
(defun loop-pseudo-body (form)
(cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*))
- (t (push form *loop-before-loop*) (push form *loop-after-body*))))
+ (t (push form *loop-before-loop*) (push form *loop-after-body*))))
(defun loop-emit-body (form)
(setq *loop-emitted-body* t)
(push (loop-construct-return form) *loop-after-epilogue*))
(when *loop-final-value-culprit*
(loop-warn "LOOP clause is providing a value for the iteration,~@
- however one was already established by a ~S clause."
- *loop-final-value-culprit*))
+ however one was already established by a ~S clause."
+ *loop-final-value-culprit*))
(setq *loop-final-value-culprit* (car *loop-source-context*)))
(defun loop-typed-init (data-type)
(when (and data-type (subtypep data-type 'number))
(if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
- (coerce 0 data-type)
- 0)))
+ (coerce 0 data-type)
+ 0)))
(defun loop-optional-type (&optional variable)
;;No variable specified implies that no destructuring is permissible.
- (and *loop-source-code* ;Don't get confused by NILs...
+ (and *loop-source-code* ;Don't get confused by NILs...
(let ((z (car *loop-source-code*)))
- (cond ((loop-tequal z 'of-type)
- ;;This is the syntactically unambigous form in that the form of the
- ;; type specifier does not matter. Also, it is assumed that the
- ;; type specifier is unambiguously, and without need of translation,
- ;; a common lisp type specifier or pattern (matching the variable) thereof.
- (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)))))))
\f
(defun loop-bind-block ()
(when (or *loop-variables* *loop-declarations* *loop-wrappers*)
(push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*)
- *loop-bind-stack*)
+ *loop-bind-stack*)
(setq *loop-variables* nil
- *loop-declarations* nil
- *loop-desetq-crocks* nil
- *loop-wrappers* nil)))
+ *loop-declarations* nil
+ *loop-desetq-crocks* nil
+ *loop-wrappers* nil)))
(defun loop-variable-p (name)
(do ((entry *loop-bind-stack* (cdr entry))) (nil)
(cond ((null entry)
- (return nil))
- ((assoc name (caar entry) :test #'eq)
- (return t)))))
+ (return nil))
+ ((assoc name (caar entry) :test #'eq)
+ (return t)))))
(defun loop-make-variable (name initialization dtype &optional iteration-variable-p)
(cond ((null name)
- (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))))
name)
(defun loop-declare-variable (name dtype)
(cond ((or (null name) (null dtype) (eq dtype t)) nil)
- ((symbolp name)
- (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
- (let ((dtype (let ((init (loop-typed-init dtype)))
- (if (typep init dtype)
+ ((symbolp name)
+ (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
+ (let ((dtype (let ((init (loop-typed-init dtype)))
+ (if (typep init dtype)
dtype
`(or (member ,init) ,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))))
- (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))))
(defun loop-maybe-bind-form (form data-type)
(defun loop-do-if (for negatep)
(let ((form (loop-get-form))
- (it-p nil)
- (first-clause-p t) then else)
+ (it-p nil)
+ (first-clause-p t) then else)
(let ((*loop-inside-conditional* t))
(flet ((get-clause (for)
- (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 (loop-tequal (car *loop-source-code*) :end)
- (loop-pop-source))
+ (loop-pop-source))
(when it-p
- (setq form `(setq ,it-p ,form))))
+ (setq form `(setq ,it-p ,form))))
(loop-pseudo-body
`(if ,(if negatep `(not ,form) form)
- ,then
- ,@else))))
+ ,then
+ ,@else))))
(defun loop-do-initially ()
(loop-error "The NAMED ~S clause occurs too late." name))
(when *loop-names*
(loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
- (car *loop-names*) name))
+ (car *loop-names*) name))
(setq *loop-names* (list name nil))))
(defun loop-do-return ()
(defstruct (loop-collector
- (:copier nil)
- (:predicate nil))
+ (:copier nil)
+ (:predicate nil))
name
class
(history nil)
(tempvars nil)
dtype
- (data nil)) ;collector-specific data
+ (data nil)) ;collector-specific data
(defun loop-get-collection-info (collector class default-type)
(let ((form (loop-get-form))
- (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
- (name (when (loop-tequal (car *loop-source-code*) 'into)
- (loop-pop-source)
- (loop-pop-source))))
+ (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
+ (name (when (loop-tequal (car *loop-source-code*) 'into)
+ (loop-pop-source)
+ (loop-pop-source))))
(when (not (symbolp name))
(loop-error "Value accumulation recipient name, ~S, is not a symbol." name))
(unless name
(unless dtype
(setq dtype (or (loop-optional-type) default-type)))
(let ((cruft (find (the symbol name) *loop-collection-cruft*
- :key #'loop-collector-name)))
+ :key #'loop-collector-name)))
(cond ((not 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))))
+ (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))))
(values cruft form))))
-(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND
+(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND
(multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list)
(let ((tempvars (loop-collector-tempvars lc)))
(unless tempvars
- (setf (loop-collector-tempvars lc)
- (setq tempvars (list* (loop-gentemp 'loop-list-head-)
- (loop-gentemp 'loop-list-tail-)
- (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)))))
(ecase specifically
- (list (setq form `(list ,form)))
- (nconc nil)
- (append (unless (and (consp form) (eq (car form) 'list))
- (setq form `(loop-copylist* ,form)))))
+ (list (setq form `(list ,form)))
+ (nconc nil)
+ (append (unless (and (consp form) (eq (car form) 'list))
+ (setq form `(loop-copylist* ,form)))))
(loop-emit-body `(loop-collect-rplacd ,tempvars ,form)))))
\f
-(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT
+(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT
(multiple-value-bind (lc form)
(loop-get-collection-info specifically 'sum default-type)
(loop-check-data-type (loop-collector-dtype lc) required-type)
(let ((tempvars (loop-collector-tempvars lc)))
(unless 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)))))
(loop-emit-body
- (if (eq specifically 'count)
- `(when ,form
- (setq ,(car tempvars)
- ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars)))))
- `(setq ,(car tempvars)
- (+ ,(hide-variable-reference t (car tempvars) (car tempvars))
- ,form)))))))
+ (if (eq specifically 'count)
+ `(when ,form
+ (setq ,(car tempvars)
+ ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars)))))
+ `(setq ,(car tempvars)
+ (+ ,(hide-variable-reference t (car tempvars) (car tempvars))
+ ,form)))))))
(loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*)
(let ((data (loop-collector-data lc)))
(unless data
- (setf (loop-collector-data lc)
- (setq data (make-loop-minimax
- (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-))
- (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))))
(loop-note-minimax-operation specifically data)
(push `(with-minimax-value ,data) *loop-wrappers*)
(loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form))
(when restrictive (loop-disallow-conditional))
(loop-disallow-anonymous-collectors)
(loop-emit-body `(,(if negate 'when 'unless) ,form
- ,(loop-construct-return nil)))
+ ,(loop-construct-return nil)))
(loop-emit-final-value t)))
(loop-disallow-anonymous-collectors)
(loop-emit-final-value)
(loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))
- ,(loop-construct-return *loop-when-it-variable*))))
+ ,(loop-construct-return *loop-when-it-variable*))))
\f
(defun loop-do-while (negate kwd &aux (form (loop-get-form)))
(loop-disallow-conditional :with)
(do ((var) (val) (dtype)) (nil)
(setq var (loop-pop-source)
- dtype (loop-optional-type var)
- val (cond ((loop-tequal (car *loop-source-code*) :=)
- (loop-pop-source)
- (loop-get-form))
- (t nil)))
+ dtype (loop-optional-type var)
+ val (cond ((loop-tequal (car *loop-source-code*) :=)
+ (loop-pop-source)
+ (loop-get-form))
+ (t nil)))
(when (and var (loop-variable-p var))
(loop-error "Variable ~S has already been used" var))
(loop-make-variable var val dtype)
(if (loop-tequal (car *loop-source-code*) :and)
- (loop-pop-source)
- (return (loop-bind-block)))))
+ (loop-pop-source)
+ (return (loop-bind-block)))))
\f
;;;; The iteration driver
(defun loop-hack-iteration (entry)
(flet ((make-endtest (list-of-forms)
- (cond ((null list-of-forms) nil)
- ((member t list-of-forms) '(go end-loop))
- (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
- (car list-of-forms)
- (cons 'or list-of-forms))
- (go end-loop))))))
+ (cond ((null list-of-forms) nil)
+ ((member t list-of-forms) '(go end-loop))
+ (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
+ (car list-of-forms)
+ (cons 'or list-of-forms))
+ (go end-loop))))))
(do ((pre-step-tests nil)
- (steps nil)
- (post-step-tests nil)
- (pseudo-steps nil)
- (pre-loop-pre-step-tests nil)
- (pre-loop-steps nil)
- (pre-loop-post-step-tests nil)
- (pre-loop-pseudo-steps nil)
- (tem) (data))
- (nil)
+ (steps nil)
+ (post-step-tests nil)
+ (pseudo-steps nil)
+ (pre-loop-pre-step-tests nil)
+ (pre-loop-steps nil)
+ (pre-loop-post-step-tests nil)
+ (pre-loop-pseudo-steps nil)
+ (tem) (data))
+ (nil)
;; Note we collect endtests in reverse order, but steps in correct
;; order. MAKE-ENDTEST does the nreverse for us.
(setq tem (setq data (apply (symbol-function (first entry)) (rest entry))))
(setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
(setq tem (cdr tem))
(when *loop-emitted-body*
- (loop-error "Iteration in LOOP follows body code."))
+ (loop-error "Iteration in LOOP follows body code."))
(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"
(when (and (not (loop-universe-implicit-for-required *loop-universe*))
- (setq tem (loop-lookup-keyword
- (car *loop-source-code*)
- (loop-universe-iteration-keywords *loop-universe*))))
- ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied.
- (loop-pop-source)
- (setq entry tem)))))
+ (setq tem (loop-lookup-keyword
+ (car *loop-source-code*)
+ (loop-universe-iteration-keywords *loop-universe*))))
+ ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied.
+ (loop-pop-source)
+ (setq entry tem)))))
\f
;;;; Main Iteration Drivers
;FOR variable keyword ..args..
(defun loop-do-for ()
(let* ((var (or (loop-pop-source) (loop-gentemp 'loop-do-for-anon-)))
- (data-type (loop-optional-type var))
- (keyword (loop-pop-source))
- (first-arg nil)
- (tem nil))
+ (data-type (loop-optional-type var))
+ (keyword (loop-pop-source))
+ (first-arg nil)
+ (tem nil))
(setq first-arg (loop-get-form))
(unless (and (symbolp keyword)
- (setq tem (loop-lookup-keyword
- keyword
- (loop-universe-for-keywords *loop-universe*))))
+ (setq tem (loop-lookup-keyword
+ keyword
+ (loop-universe-for-keywords *loop-universe*))))
(loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword))
(apply (car tem) var first-arg data-type (cdr tem))))
(defun loop-do-repeat ()
(loop-disallow-conditional :repeat)
(let ((form (loop-get-form))
- (type 'real))
+ (type 'real))
(let ((var (loop-make-variable (loop-gentemp) form type)))
(push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*)
(push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*)
(defun loop-when-it-variable ()
(or *loop-when-it-variable*
(setq *loop-when-it-variable*
- (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
+ (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
\f
;;;; Various FOR/AS Subdispatches
(defun loop-ansi-for-equals (var val data-type)
(loop-make-iteration-variable var nil data-type)
(cond ((loop-tequal (car *loop-source-code*) :then)
- ;;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))
+ )))
(defun loop-for-across (var val data-type)
(loop-make-iteration-variable var nil data-type)
(let ((vector-var (loop-gentemp 'loop-across-vector-))
- (index-var (loop-gentemp 'loop-across-index-)))
+ (index-var (loop-gentemp 'loop-across-index-)))
(multiple-value-bind (vector-form constantp vector-value)
- (loop-constant-fold-if-possible val 'vector)
+ (loop-constant-fold-if-possible val 'vector)
(loop-make-variable
- vector-var vector-form
- (if (and (consp vector-form) (eq (car vector-form) 'the))
- (cadr vector-form)
- 'vector))
+ vector-var vector-form
+ (if (and (consp vector-form) (eq (car vector-form) 'the))
+ (cadr vector-form)
+ 'vector))
#+Genera (push `(system:array-register ,vector-var) *loop-declarations*)
(loop-make-variable index-var 0 'fixnum)
(let* ((length 0)
- (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)))))))
\f
;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not
;; recognizing FOO may defeat some LOOP optimizations.
(let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by)
- (loop-pop-source)
- (loop-get-form))
- (t '(function cdr)))))
+ (loop-pop-source)
+ (loop-get-form))
+ (t '(function cdr)))))
(cond ((and (consp stepper) (eq (car stepper) 'quote))
- (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)))))
(defun loop-for-on (var val data-type)
(multiple-value-bind (list constantp list-value) (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 (loop-gentemp)) list 't)
- (loop-make-iteration-variable var nil data-type)))
+ (t (loop-make-variable (setq listvar (loop-gentemp)) list 't)
+ (loop-make-iteration-variable var nil data-type)))
(multiple-value-bind (list-step step-function) (loop-list-step listvar)
- (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)))))))))))
(defun loop-for-in (var val data-type)
(loop-make-iteration-variable var nil data-type)
(loop-make-variable listvar list 'list)
(multiple-value-bind (list-step step-function) (loop-list-step listvar)
- #-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))))))))
\f
;;;; Iteration Paths
(defstruct (loop-path
- (:copier nil)
- (:predicate nil))
+ (:copier nil)
+ (:predicate nil))
names
preposition-groups
inclusive-permitted
:function function
:user-data user-data
:preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups)
- :inclusive-permitted inclusive-permitted)))
+ :inclusive-permitted inclusive-permitted)))
(dolist (name names) (setf (gethash (symbol-name name) ht) lp))
lp)))
\f
;; FOR var BEING each/the pathname prep-phrases using-stuff...
;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn.
(let ((path nil)
- (data nil)
- (inclusive nil)
- (stuff nil)
- (initial-prepositions nil))
+ (data nil)
+ (inclusive nil)
+ (stuff nil)
+ (initial-prepositions nil))
(cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source)))
- ((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?")))
(cond ((not (symbolp path))
- (loop-error "~S found where a LOOP iteration path name was expected." path))
- ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*))))
- (loop-error "~S is not the name of a LOOP iteration path." path))
- ((and inclusive (not (loop-path-inclusive-permitted data)))
- (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path)))
+ (loop-error "~S found where a LOOP iteration path name was expected." path))
+ ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*))))
+ (loop-error "~S is not the name of a LOOP iteration path." path))
+ ((and inclusive (not (loop-path-inclusive-permitted data)))
+ (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path)))
(let ((fun (loop-path-function data))
- (preps (nconc initial-prepositions
- (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t)))
- (user-data (loop-path-user-data data)))
+ (preps (nconc initial-prepositions
+ (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t)))
+ (user-data (loop-path-user-data data)))
(when (symbolp fun) (setq fun (symbol-function fun)))
(setq stuff (if inclusive
- (apply fun var data-type preps :inclusive t user-data)
- (apply fun var data-type preps user-data))))
+ (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*))
;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user
;; and the user from himself.
(unless (member (length stuff) '(6 10))
(loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
- path))
+ 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-variable x nil nil)
+ (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
(setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*))
(cddr stuff)))
\f
(let ((tem (loop-tassoc name *loop-named-variables*)))
(declare (list tem))
(cond ((null tem) (values (loop-gentemp) nil))
- (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
- (values (cdr tem) t)))))
+ (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
+ (values (cdr tem) t)))))
(defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases)
(flet ((in-group-p (x group) (car (loop-tmember x group))))
(do ((token nil)
- (prepositional-phrases initial-phrases)
- (this-group nil nil)
- (this-prep nil nil)
- (disallowed-prepositions
- (mapcan #'(lambda (x)
- (loop-copylist*
- (find (car x) preposition-groups :test #'in-group-p)))
- initial-phrases))
- (used-prepositions (mapcar #'car initial-phrases)))
- ((null *loop-source-code*) (nreverse prepositional-phrases))
+ (prepositional-phrases initial-phrases)
+ (this-group nil nil)
+ (this-prep nil nil)
+ (disallowed-prepositions
+ (mapcan #'(lambda (x)
+ (loop-copylist*
+ (find (car x) preposition-groups :test #'in-group-p)))
+ initial-phrases))
+ (used-prepositions (mapcar #'car initial-phrases)))
+ ((null *loop-source-code*) (nreverse prepositional-phrases))
(declare (symbol this-prep))
(setq token (car *loop-source-code*))
(dolist (group preposition-groups)
- (when (setq this-prep (in-group-p token group))
- (return (setq this-group group))))
+ (when (setq this-prep (in-group-p token group))
+ (return (setq this-group group))))
(cond (this-group
- (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)))))))
\f
;;;; Master Sequencer Function
(defun loop-sequencer (indexv indexv-type indexv-user-specified-p
- variable variable-type
- sequence-variable sequence-type
- step-hack default-top
- prep-phrases)
- (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)
+ )
(when variable (loop-make-iteration-variable 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))
- ((: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 (and odir dir (not (eq dir odir)))
- (loop-error "Conflicting stepping directions in LOOP sequencing path"))
+ (loop-error "Conflicting stepping directions in LOOP sequencing path"))
(setq odir dir))
(when (and sequence-variable (not sequencep))
(loop-error "Missing OF or IN phrase in sequence path"))
;; Now fill in the defaults.
(unless start-given
(loop-make-iteration-variable
- indexv
- (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0))
- indexv-type))
+ indexv
+ (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0))
+ indexv-type))
(cond ((member dir '(nil :up))
- (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 (setq first-test (funcall (symbol-function testfn) start-value limit-value))
- (setq remaining-tests t)))
+ (when (setq first-test (funcall (symbol-function testfn) start-value limit-value))
+ (setq remaining-tests t)))
`(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack
- () () ,first-test ,step-hack))))
+ () () ,first-test ,step-hack))))
\f
;;;; Interfaces to the Master Sequencer
(defun loop-sequence-elements-path (variable data-type prep-phrases
- &key fetch-function size-function sequence-type element-type)
+ &key fetch-function size-function sequence-type element-type)
(multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index)
(let ((sequencev (named-variable 'sequence)))
#+Genera (when (and sequencev
- (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)))))
\f
;;;; Builtin LOOP Iteration Paths
(defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which)
(check-type which (member hash-key hash-value))
(cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
- (loop-error "Too many prepositions!"))
- ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path.")))
+ (loop-error "Too many prepositions!"))
+ ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path.")))
(let ((ht-var (loop-gentemp 'loop-hashtab-))
- (next-fn (loop-gentemp 'loop-hashtab-next-))
- (dummy-predicate-var nil)
- (post-steps nil))
+ (next-fn (loop-gentemp 'loop-hashtab-next-))
+ (dummy-predicate-var nil)
+ (post-steps nil))
(multiple-value-bind (other-var other-p)
- (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
+ (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
;;@@@@ named-variable returns a second value of T if the name was actually
;; specified, so clever code can throw away the gensym'ed up variable if
;; it isn't really needed.
;;The following is for those implementations in which we cannot put dummy NILs
;; into multiple-value-setq variable lists.
#-Genera (setq other-p t
- dummy-predicate-var (loop-when-it-variable))
+ dummy-predicate-var (loop-when-it-variable))
(let* ((key-var nil)
- (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)))))
(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types)
(cond ((and prep-phrases (cdr prep-phrases))
- (loop-error "Too many prepositions!"))
- ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
- (loop-error "Unknow preposition ~S" (caar prep-phrases))))
+ (loop-error "Too many prepositions!"))
+ ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
+ (loop-error "Unknow preposition ~S" (caar prep-phrases))))
(unless (symbolp variable)
(loop-error "Destructuring is not valid for package symbol iteration."))
(let ((pkg-var (loop-gentemp 'loop-pkgsym-))
- (next-fn (loop-gentemp 'loop-pkgsym-next-))
- (variable (or variable (loop-gentemp)))
- (pkg (or (cadar prep-phrases) '*package*)))
+ (next-fn (loop-gentemp 'loop-pkgsym-next-))
+ (variable (or variable (loop-gentemp)))
+ (pkg (or (cadar prep-phrases) '*package*)))
(push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
`(((,variable nil ,data-type) (,pkg-var ,pkg))
()
()
()
(not (multiple-value-setq (,(progn
- ;;@@@@ If an implementation can get away without actually
- ;; using a variable here, so much the better.
- #+Genera NIL
- #-Genera (loop-when-it-variable))
- ,variable)
- (,next-fn)))
+ ;;@@@@ If an implementation can get away without actually
+ ;; using a variable here, so much the better.
+ #+Genera NIL
+ #-Genera (loop-when-it-variable))
+ ,variable)
+ (,next-fn)))
())))
\f
;;;; ANSI Loop
(minimize (loop-maxmin-collection min))
(maximizing (loop-maxmin-collection max))
(minimizing (loop-maxmin-collection min))
- (always (loop-do-always t nil)) ; Normal, do always
- (never (loop-do-always t t)) ; Negate the test on always.
+ (always (loop-do-always t nil)) ; Normal, do always
+ (never (loop-do-always t t)) ; Negate the test on always.
(thereis (loop-do-thereis t))
- (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
(with (loop-do-with))
(repeat (loop-do-repeat)))
:for-keywords '((= (loop-ansi-for-equals))
:type-keywords nil
:ansi (if extended-p :extended t))))
(add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
- :preposition-groups '((:of :in))
- :inclusive-permitted nil
- :user-data '(:which hash-key))
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:which hash-key))
(add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
(add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
- :user-data '(:symbol-types (:internal :external :inherited)))
+ :user-data '(:symbol-types (:internal :external :inherited)))
(add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
(if (and keywords-and-forms (symbolp (car keywords-and-forms)))
(loop-translate keywords-and-forms environment universe)
(let ((tag (gensym)))
- `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
+ `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
) ;; eval-when
;;;INTERFACE: ANSI
(defmacro loop (&environment env &rest keywords-and-forms)
#+Genera (declare (compiler:do-not-record-macroexpansions)
- (zwei:indentation . zwei:indent-loop))
+ (zwei:indentation . zwei:indent-loop))
(loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
#+allegro
projects / clsql.git / blobdiff