(setf (gethash (car x) ht) (cadr x))))
ht))))
\f
-;;;; SETQ hackery
+;;;; SETQ hackery, including destructuring ("DESETQ")
(defun loop-make-psetq (frobs)
(and frobs
(make-symbol "LOOP-DESETQ-TEMP"))
(sb!int:defmacro-mundanely loop-really-desetq (&environment env
- &rest var-val-pairs)
+ &rest var-val-pairs)
(labels ((find-non-null (var)
- ;; see whether there's any non-null thing here
- ;; recurse if the list element is itself a list
+ ;; See whether there's any non-null thing here. Recurse
+ ;; if the list element is itself a list.
(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
(typecase var
(null
(when (consp val)
- ;; Don't lose possible side-effects.
+ ;; Don't lose possible side effects.
(if (eq (car val) 'prog1)
- ;; These can come from psetq or desetq below.
- ;; Throw away the value, keep the side-effects.
+ ;; 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)
,@body)
`((let ((,temp ,val))
,@body))))
- ;; no cdring to do
+ ;; no CDRing to do
(loop-desetq-internal car `(car ,val) temp)))))
(otherwise
(unless (eq var val)
(defvar *loop-after-epilogue*)
;;; the "culprit" responsible for supplying a final value from the
-;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple
-;;; return values being supplied.
+;;; loop. This is so LOOP-DISALLOW-AGGREGATE-BOOLEANS can moan about
+;;; disallowed anonymous collections.
(defvar *loop-final-value-culprit*)
;;; If this is true, we are in some branch of a conditional. Some
(setq constant-value (eval new-form)))
(when (and constantp expected-type)
(unless (sb!xc:typep constant-value expected-type)
- (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
+ (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)))
;; CLTL2, removed from ANSI standard) we could set these
;; values flexibly. Without DECLARATION-INFORMATION, we have
;; to set them to constants.
+ ;;
+ ;; except FIXME: we've lost all pretence of portability,
+ ;; considering this instead an internal implementation, so
+ ;; we're free to couple to our own representation of the
+ ;; environment.
(speed 1)
(space 1))
(+ 40 (* (- speed space) 10))))
(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.
- (if (or (symbolp (cadr x))
- (and (consp (cadr x)) (eq (caadr x) 'setf)))
+ (if (sb!int:legal-fun-name-p (cadr x))
1
+ ;; FIXME: This tag appears not to be present
+ ;; anywhere.
(throw 'duplicatable-code-p nil)))
((eq fn 'multiple-value-setq)
(f (length (second x)) (cddr x)))
((eq l (cdr *loop-source-code*)) (nreverse new))))
(defun loop-error (format-string &rest format-args)
- (error "~?~%current LOOP context:~{ ~S~}."
- format-string
- format-args
- (loop-context)))
+ (error 'sb!int:simple-program-error
+ :format-control "~?~%current LOOP context:~{ ~S~}."
+ :format-arguments (list format-string format-args (loop-context))))
(defun loop-warn (format-string &rest format-args)
(warn "~?~%current LOOP context:~{ ~S~}."
specified-type required-type)))
specified-type)))
\f
+(defun subst-gensyms-for-nil (tree)
+ (declare (special *ignores*))
+ (cond
+ ((null tree) (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*)))
+ ((atom tree) tree)
+ (t (cons (subst-gensyms-for-nil (car tree))
+ (subst-gensyms-for-nil (cdr tree))))))
+
+(sb!int:defmacro-mundanely loop-destructuring-bind
+ (lambda-list arg-list &rest body)
+ (let ((*ignores* nil))
+ (declare (special *ignores*))
+ (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list)))
+ `(destructuring-bind ,d-var-lambda-list
+ ,arg-list
+ (declare (ignore ,@*ignores*))
+ ,@body))))
+
(defun loop-build-destructuring-bindings (crocks forms)
(if crocks
- `((destructuring-bind ,(car crocks) ,(cadr crocks)
+ `((loop-destructuring-bind ,(car crocks) ,(cadr crocks)
,@(loop-build-destructuring-bindings (cddr crocks) forms)))
forms))
,(nreverse *loop-after-body*)
,(nreconc *loop-epilogue*
(nreverse *loop-after-epilogue*)))))
- (do () (nil)
- (setq answer `(block ,(pop *loop-names*) ,answer))
- (unless *loop-names* (return nil)))
(dolist (entry *loop-bind-stack*)
(let ((vars (first entry))
(dcls (second entry))
,vars
,@(loop-build-destructuring-bindings crocks
forms)))))))
+ (do () (nil)
+ (setq answer `(block ,(pop *loop-names*) ,answer))
+ (unless *loop-names* (return nil)))
answer)))
(defun loop-iteration-driver ()
(setq *loop-emitted-body* t)
(loop-pseudo-body form))
-(defun loop-emit-final-value (form)
- (push (loop-construct-return form) *loop-after-epilogue*)
- (when *loop-final-value-culprit*
- (loop-warn "The LOOP clause is providing a value for the iteration,~@
- however one was already established by a ~S clause."
- *loop-final-value-culprit*))
+(defun loop-emit-final-value (&optional (form nil form-supplied-p))
+ (when form-supplied-p
+ (push (loop-construct-return form) *loop-after-epilogue*))
(setq *loop-final-value-culprit* (car *loop-source-context*)))
(defun loop-disallow-conditional (&optional kwd)
(when *loop-inside-conditional*
(loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
+
+(defun loop-disallow-anonymous-collectors ()
+ (when (find-if-not 'loop-collector-name *loop-collection-cruft*)
+ (loop-error "This LOOP clause is not permitted with anonymous collectors.")))
+
+(defun loop-disallow-aggregate-booleans ()
+ (when (loop-tmember *loop-final-value-culprit* '(always never thereis))
+ (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans.")))
\f
;;;; loop types
-(defun loop-typed-init (data-type)
+(defun loop-typed-init (data-type &optional step-var-p)
(when (and data-type (sb!xc:subtypep data-type 'number))
(if (or (sb!xc:subtypep data-type 'float)
(sb!xc:subtypep data-type '(complex float)))
- (coerce 0 data-type)
- 0)))
+ (coerce (if step-var-p 1 0) data-type)
+ (if step-var-p 1 0))))
(defun loop-optional-type (&optional variable)
;; No variable specified implies that no destructuring is permissible.
*loop-desetq-crocks* nil
*loop-wrappers* nil)))
-(defun loop-make-var (name initialization dtype &optional iteration-var-p)
+(defun loop-var-p (name)
+ (do ((entry *loop-bind-stack* (cdr entry)))
+ (nil)
+ (cond
+ ((null entry) (return nil))
+ ((assoc name (caar entry) :test #'eq) (return t)))))
+
+(defun loop-make-var (name initialization dtype &optional iteration-var-p step-var-p)
(cond ((null name)
- (cond ((not (null initialization))
- (push (list (setq name (gensym "LOOP-IGNORE-"))
- initialization)
- *loop-vars*)
- (push `(ignore ,name) *loop-declarations*))))
+ (setq name (gensym "LOOP-IGNORE-"))
+ (push (list name initialization) *loop-vars*)
+ (if (null initialization)
+ (push `(ignore ,name) *loop-declarations*)
+ (loop-declare-var name dtype)))
((atom name)
(cond (iteration-var-p
(if (member name *loop-iteration-vars*)
name)))
(unless (symbolp name)
(loop-error "bad variable ~S somewhere in LOOP" name))
- (loop-declare-var name dtype)
+ (loop-declare-var name dtype step-var-p)
;; 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)))
+ (push (list name (or initialization (loop-typed-init dtype step-var-p)))
*loop-vars*))
(initialization
(let ((newvar (gensym "LOOP-DESTRUCTURE-")))
(defun loop-make-iteration-var (name initialization dtype)
(loop-make-var name initialization dtype t))
-(defun loop-declare-var (name dtype)
+(defun loop-declare-var (name dtype &optional step-var-p)
(cond ((or (null name) (null dtype) (eq dtype t)) nil)
((symbolp name)
(unless (sb!xc:subtypep t dtype)
- (let ((dtype (let ((init (loop-typed-init dtype)))
+ (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
(if (sb!xc:typep init dtype)
dtype
`(or (member ,init) ,dtype)))))
(loop-make-var (gensym "LOOP-BIND-") form data-type)))
\f
(defun loop-do-if (for negatep)
- (let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil))
+ (let ((form (loop-get-form))
+ (*loop-inside-conditional* t)
+ (it-p nil)
+ (first-clause-p t))
(flet ((get-clause (for)
(do ((body nil)) (nil)
(let ((key (car *loop-source-code*)) (*loop-body* nil) data)
key for))
(t (setq *loop-source-context* *loop-source-code*)
(loop-pop-source)
- (when (loop-tequal (car *loop-source-code*) 'it)
+ (when (and (loop-tequal (car *loop-source-code*) 'it)
+ first-clause-p)
(setq *loop-source-code*
(cons (or it-p
(setq it-p
"~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)
(when *loop-names*
(loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
(car *loop-names*) name))
- (setq *loop-names* (list name nil))))
+ (setq *loop-names* (list name))))
(defun loop-do-return ()
- (loop-pseudo-body (loop-construct-return (loop-get-form))))
+ (loop-emit-body (loop-construct-return (loop-get-form))))
\f
;;;; value accumulation: LIST
(loop-pop-source))))
(when (not (symbolp name))
(loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
+ (unless name
+ (loop-disallow-aggregate-booleans))
(unless dtype
(setq dtype (or (loop-optional-type) default-type)))
(let ((cruft (find (the symbol name) *loop-collection-cruft*
:key #'loop-collector-name)))
(cond ((not cruft)
+ (when (and name (loop-var-p name))
+ (loop-error "Variable ~S in INTO clause is a duplicate" name))
(push (setq cruft (make-loop-collector
:name name :class class
:history (list collector) :dtype dtype))
(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"
+ ~:[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"
+ into ~S: ~S and ~S"
name dtype (loop-collector-dtype cruft))
(when (eq (loop-collector-dtype cruft) t)
(setf (loop-collector-dtype cruft) dtype)))
(defun loop-do-always (restrictive negate)
(let ((form (loop-get-form)))
(when restrictive (loop-disallow-conditional))
+ (loop-disallow-anonymous-collectors)
(loop-emit-body `(,(if negate 'when 'unless) ,form
,(loop-construct-return nil)))
(loop-emit-final-value t)))
;;; Under ANSI this is not permitted to appear under conditionalization.
(defun loop-do-thereis (restrictive)
(when restrictive (loop-disallow-conditional))
+ (loop-disallow-anonymous-collectors)
+ (loop-emit-final-value)
(loop-emit-body `(when (setq ,(loop-when-it-var) ,(loop-get-form))
- ,(loop-construct-return *loop-when-it-var*))))
+ ,(loop-construct-return *loop-when-it-var*))))
\f
(defun loop-do-while (negate kwd &aux (form (loop-get-form)))
(loop-disallow-conditional kwd)
(loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
+(defun loop-do-repeat ()
+ (loop-disallow-conditional :repeat)
+ (let ((form (loop-get-form))
+ (type 'integer))
+ (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type)))
+ (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*)
+ (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-after-body*)
+ ;; FIXME: What should
+ ;; (loop count t into a
+ ;; repeat 3
+ ;; count t into b
+ ;; finally (return (list a b)))
+ ;; return: (3 3) or (4 3)? PUSHes above are for the former
+ ;; variant, L-P-B below for the latter.
+ #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop))))))
+
(defun loop-do-with ()
(loop-disallow-conditional :with)
(do ((var) (val) (dtype)) (nil)
(loop-pop-source)
(loop-get-form))
(t nil)))
+ (when (and var (loop-var-p var))
+ (loop-error "Variable ~S has already been used" var))
(loop-make-var var val dtype)
(if (loop-tequal (car *loop-source-code*) :and)
(loop-pop-source)
keyword))
(apply (car tem) var first-arg data-type (cdr tem))))
-(defun loop-do-repeat ()
- (let ((form (loop-get-form))
- (type (loop-check-data-type (loop-optional-type)
- 'real)))
- (when (and (consp form)
- (eq (car form) 'the)
- (sb!xc:subtypep (second form) type))
- (setq type (second form)))
- (multiple-value-bind (number constantp value)
- (loop-constant-fold-if-possible form type)
- (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
- (t (let ((var (loop-make-var (gensym "LOOP-REPEAT-") number type)))
- (if constantp
- `((not (plusp (setq ,var (1- ,var))))
- () () () () () () ())
- `((minusp (setq ,var (1- ,var)))
- () () ()))))))))
-
(defun loop-when-it-var ()
(or *loop-when-it-var*
(setq *loop-when-it-var*
(let ((listvar var))
(cond ((and var (symbolp var))
(loop-make-iteration-var var list data-type))
- (t (loop-make-var (setq listvar (gensym)) list 'list)
+ (t (loop-make-var (setq listvar (gensym)) list 't)
(loop-make-iteration-var var nil data-type)))
(let ((list-step (loop-list-step listvar)))
(let* ((first-endtest
((and using-allowed (loop-tequal token 'using))
(loop-pop-source)
(do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
- (when (or (atom z)
- (atom (cdr z))
- (not (null (cddr z)))
- (not (symbolp (car z)))
- (and (cadr z) (not (symbolp (cadr z)))))
- (loop-error "~S bad variable pair in path USING phrase" z))
(when (cadr z)
(if (setq tem (loop-tassoc (car z) *loop-named-vars*))
(loop-error
"The variable substitution for ~S occurs twice in a USING phrase,~@
- with ~S and ~S."
+ with ~S and ~S."
(car z) (cadr z) (cadr tem))
(push (cons (car z) (cadr z)) *loop-named-vars*)))
(when (or (null *loop-source-code*)
(limit-constantp nil)
(limit-value nil)
)
- (when variable (loop-make-iteration-var variable nil variable-type))
- (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
- (setq prep (caar l) form (cadar l))
- (case prep
- ((:of :in)
- (setq sequencep t)
- (loop-make-var sequence-variable form sequence-type))
- ((:from :downfrom :upfrom)
- (setq start-given t)
- (cond ((eq prep :downfrom) (setq dir ':down))
- ((eq prep :upfrom) (setq dir ':up)))
- (multiple-value-setq (form start-constantp start-value)
- (loop-constant-fold-if-possible form indexv-type))
- (loop-make-iteration-var 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-var
- (gensym "LOOP-LIMIT-") form indexv-type))))
- (:by
- (multiple-value-setq (form stepby-constantp stepby)
- (loop-constant-fold-if-possible form indexv-type))
- (unless stepby-constantp
- (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
- form
- indexv-type)))
- (t (loop-error
- "~S invalid preposition in sequencing or sequence path;~@
- maybe invalid prepositions were specified in iteration path descriptor?"
- prep)))
- (when (and odir dir (not (eq dir odir)))
- (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-var
- 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-var (setq endform (gensym "LOOP-SEQ-LIMIT-"))
- nil
- indexv-type)
- (push `(setq ,endform ,default-top) *loop-prologue*))
- (setq testfn (if inclusive-iteration '> '>=)))
- (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
- (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
- `(,testfn ,indexv ,endform)))
- (when step-hack
- (setq step-hack
- `(,variable ,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)))
- `(() (,indexv ,step)
- ,remaining-tests ,step-hack () () ,first-test ,step-hack))))
+ (flet ((assert-index-for-arithmetic (index)
+ (unless (atom index)
+ (loop-error "Arithmetic index must be an atom."))))
+ (when variable (loop-make-iteration-var variable nil variable-type))
+ (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
+ (setq prep (caar l) form (cadar l))
+ (case prep
+ ((:of :in)
+ (setq sequencep t)
+ (loop-make-var sequence-variable form sequence-type))
+ ((:from :downfrom :upfrom)
+ (setq start-given t)
+ (cond ((eq prep :downfrom) (setq dir ':down))
+ ((eq prep :upfrom) (setq dir ':up)))
+ (multiple-value-setq (form start-constantp start-value)
+ (loop-constant-fold-if-possible form indexv-type))
+ (assert-index-for-arithmetic indexv)
+ ;; KLUDGE: loop-make-var generates a temporary symbol for
+ ;; indexv if it is NIL. We have to use it to have the index
+ ;; actually count
+ (setq indexv (loop-make-iteration-var indexv form indexv-type)))
+ ((:upto :to :downto :above :below)
+ (cond ((loop-tequal prep :upto) (setq inclusive-iteration
+ (setq dir ':up)))
+ ((loop-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 `(and ,indexv-type real)))
+ (setq endform (if limit-constantp
+ `',limit-value
+ (loop-make-var
+ (gensym "LOOP-LIMIT-") form
+ `(and ,indexv-type real)))))
+ (:by
+ (multiple-value-setq (form stepby-constantp stepby)
+ (loop-constant-fold-if-possible form `(and ,indexv-type (real (0)))))
+ (unless stepby-constantp
+ (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
+ form
+ `(and ,indexv-type (real (0)))
+ nil t)))
+ (t (loop-error
+ "~S invalid preposition in sequencing or sequence path;~@
+ maybe invalid prepositions were specified in iteration path descriptor?"
+ prep)))
+ (when (and odir dir (not (eq dir odir)))
+ (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.
+ (if start-given
+ (when limit-given
+ ;; if both start and limit are given, they had better both
+ ;; be REAL. We already enforce the REALness of LIMIT,
+ ;; above; here's the KLUDGE to enforce the type of START.
+ (flet ((type-declaration-of (x)
+ (and (eq (car x) 'type) (caddr x))))
+ (let ((decl (find indexv *loop-declarations*
+ :key #'type-declaration-of))
+ (%decl (find indexv *loop-declarations*
+ :key #'type-declaration-of
+ :from-end t)))
+ (sb!int:aver (eq decl %decl))
+ (setf (cadr decl)
+ `(and real ,(cadr decl))))))
+ ;; default start
+ ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
+ ;; symbol for indexv if it is NIL. See also the comment in
+ ;; the (:from :downfrom :upfrom) case
+ (progn
+ (assert-index-for-arithmetic indexv)
+ (setq indexv
+ (loop-make-iteration-var
+ indexv
+ (setq start-constantp t
+ start-value (or (loop-typed-init indexv-type) 0))
+ `(and ,indexv-type real)))))
+ (cond ((member dir '(nil :up))
+ (when (or limit-given default-top)
+ (unless limit-given
+ (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-"))
+ nil
+ indexv-type)
+ (push `(setq ,endform ,default-top) *loop-prologue*))
+ (setq testfn (if inclusive-iteration '> '>=)))
+ (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
+ (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
+ `(,testfn ,indexv ,endform)))
+ (when step-hack
+ (setq step-hack
+ `(,variable ,step-hack)))
+ (let ((first-test test) (remaining-tests test))
+ (when (and stepby-constantp start-constantp limit-constantp
+ (realp start-value) (realp limit-value))
+ (when (setq first-test
+ (funcall (symbol-function testfn)
+ start-value
+ limit-value))
+ (setq remaining-tests t)))
+ `(() (,indexv ,step)
+ ,remaining-tests ,step-hack () () ,first-test ,step-hack)))))
\f
;;;; interfaces to the master sequencer
(defun loop-for-arithmetic (var val data-type kwd)
(loop-sequencer
- var (loop-check-data-type data-type 'real)
+ var (loop-check-data-type data-type 'number)
nil nil nil nil nil nil
(loop-collect-prepositional-phrases
'((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
sequence-type
element-type)
(multiple-value-bind (indexv) (loop-named-var 'index)
- (let ((sequencev (named-var 'sequence)))
+ (let ((sequencev (loop-named-var 'sequence)))
(list* nil nil ; dummy bindings and prologue
(loop-sequencer
indexv 'fixnum
||#
(defun loop-hash-table-iteration-path (variable data-type prep-phrases
- &key (which (missing-arg)))
+ &key (which (sb!int:missing-arg)))
(declare (type (member :hash-key :hash-value) which))
(cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
(loop-error "too many prepositions!"))
;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists.
(setq other-p t
dummy-predicate-var (loop-when-it-var))
- (let ((key-var nil)
- (val-var nil)
- (bindings `((,variable nil ,data-type)
- (,ht-var ,(cadar prep-phrases))
- ,@(and other-p other-var `((,other-var nil))))))
+ (let* ((key-var nil)
+ (val-var nil)
+ (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-")))
+ (bindings `((,variable nil ,data-type)
+ (,ht-var ,(cadar prep-phrases))
+ ,@(and other-p other-var `((,other-var nil))))))
(ecase which
(:hash-key (setq key-var variable
val-var (and other-p other-var)))
(:hash-value (setq key-var (and other-p other-var)
val-var variable)))
(push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
- (when (consp key-var)
- (setq post-steps
- `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-"))
- ,@post-steps))
- (push `(,key-var nil) bindings))
- (when (consp val-var)
- (setq post-steps
- `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-"))
- ,@post-steps))
- (push `(,val-var nil) bindings))
- `(,bindings ;bindings
- () ;prologue
- () ;pre-test
- () ;parallel steps
+ (when (or (consp key-var) data-type)
+ (setq post-steps
+ `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-"))
+ ,@post-steps))
+ (push `(,key-var nil) bindings))
+ (when (or (consp val-var) data-type)
+ (setq post-steps
+ `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-"))
+ ,@post-steps))
+ (push `(,val-var nil) bindings))
+ `(,bindings ;bindings
+ () ;prologue
+ () ;pre-test
+ () ;parallel steps
(not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var)
- (,next-fn))) ;post-test
+ (,next-fn))) ;post-test
,post-steps)))))
(defun loop-package-symbols-iteration-path (variable data-type prep-phrases
&key symbol-types)
- (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
+ (cond ((and prep-phrases (cdr prep-phrases))
(loop-error "Too many prepositions!"))
- ((null prep-phrases)
- (loop-error "missing OF or IN in ~S iteration path")))
+ ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
+ (sb!int:bug "Unknown preposition ~S." (caar prep-phrases))))
(unless (symbolp variable)
(loop-error "Destructuring is not valid for package symbol iteration."))
(let ((pkg-var (gensym "LOOP-PKGSYM-"))
- (next-fn (gensym "LOOP-PKGSYM-NEXT-")))
+ (next-fn (gensym "LOOP-PKGSYM-NEXT-"))
+ (variable (or variable (gensym "LOOP-PKGSYM-VAR-")))
+ (package (or (cadar prep-phrases) '*package*)))
(push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types))
*loop-wrappers*)
- `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases)))
+ `(((,variable nil ,data-type) (,pkg-var ,package))
()
()
()
(when (loop-do-if when nil)) ; Normal, do when
(if (loop-do-if if nil)) ; synonymous
(unless (loop-do-if unless t)) ; Negate test on when
- (with (loop-do-with)))
+ (with (loop-do-with))
+ (repeat (loop-do-repeat)))
:for-keywords '((= (loop-ansi-for-equals))
(across (loop-for-across))
(in (loop-for-in))
(downfrom (loop-for-arithmetic :downfrom))
(upfrom (loop-for-arithmetic :upfrom))
(below (loop-for-arithmetic :below))
+ (above (loop-for-arithmetic :above))
(to (loop-for-arithmetic :to))
(upto (loop-for-arithmetic :upto))
+ (downto (loop-for-arithmetic :downto))
(by (loop-for-arithmetic :by))
(being (loop-for-being)))
:iteration-keywords '((for (loop-do-for))
- (as (loop-do-for))
- (repeat (loop-do-repeat)))
+ (as (loop-do-for)))
:type-symbols '(array atom bignum bit bit-vector character
compiled-function complex cons double-float
fixnum float function hash-table integer
(defun loop-standard-expansion (keywords-and-forms environment universe)
(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))))))
+ (loop-translate keywords-and-forms environment universe)
+ (let ((tag (gensym)))
+ `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
(sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
(loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
projects / sbcl.git / blobdiff