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*
((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
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)))
(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))
(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