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 ()
(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-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 'real))
+ (let ((var (loop-make-var (gensym "LOOP-REPEAT-") form type)))
+ (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*)
+ (push `(when (minusp (decf ,var)) (go end-loop)) *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)
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*
(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-"))
- (variable (or variable (gensym "LOOP-PKGSYM-VAR-"))))
+ (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))
(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*))