(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)))
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))
(setq *loop-emitted-body* t)
(loop-pseudo-body form))
-(defun loop-emit-final-value (form)
- (push (loop-construct-return form) *loop-after-epilogue*)
+(defun loop-emit-final-value (&optional (form nil form-supplied-p))
+ (when form-supplied-p
+ (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-warn "The LOOP clause is providing a value for the iteration;~@
+ however, one was already established by a ~S clause."
*loop-final-value-culprit*))
(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
*loop-desetq-crocks* nil
*loop-wrappers* nil)))
+(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)
(cond ((null name)
(cond ((not (null initialization))
(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-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))
(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*
(: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
(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