X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=1f86e9fc441683178a8279fdcfa432523834619e;hb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;hp=59504a9b555e5a471b5f76d4507246bbfcca5ced;hpb=8fa4431617a64ef0b5fe70aa2d1c725a8e6ce4cf;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 59504a9..1f86e9f 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -709,12 +709,10 @@ code to be loaded. (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))) @@ -760,9 +758,27 @@ code to be loaded. specified-type required-type))) specified-type))) +(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)) @@ -883,17 +899,26 @@ code to be loaded. (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."))) ;;;; loop types @@ -986,6 +1011,13 @@ code to be loaded. *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)) @@ -1048,7 +1080,10 @@ code to be loaded. (loop-make-var (gensym "LOOP-BIND-") form data-type))) (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) @@ -1058,7 +1093,8 @@ code to be loaded. 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 @@ -1073,6 +1109,7 @@ code to be loaded. "~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) @@ -1110,7 +1147,7 @@ code to be loaded. (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)))) @@ -1135,11 +1172,15 @@ code to be loaded. (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)) @@ -1231,6 +1272,7 @@ code to be loaded. (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))) @@ -1240,13 +1282,31 @@ code to be loaded. ;;; 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*)))) (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) @@ -1256,6 +1316,8 @@ code to be loaded. (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) @@ -1348,24 +1410,6 @@ code to be loaded. 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* @@ -1806,22 +1850,22 @@ code to be loaded. (: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 @@ -1883,7 +1927,8 @@ code to be loaded. (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)) @@ -1899,8 +1944,7 @@ code to be loaded. (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 @@ -1944,9 +1988,9 @@ code to be loaded. (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*))