X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Floop.lisp;h=a1cec364536e36aa844afa811e8464a42489883c;hb=731bc63e2e5c9bac2799c299e37d7654579b0716;hp=5cc33477957b2372b6c0164d87a511e5f73ee80c;hpb=c3d4cd43d7cd8e0495dbb9c11fd9c121ea069a45;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 5cc3347..a1cec36 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -760,9 +760,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)) @@ -800,9 +818,6 @@ code to be loaded. ,(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)) @@ -818,6 +833,9 @@ code to be loaded. ,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 () @@ -1110,7 +1128,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)))) @@ -1247,6 +1265,22 @@ code to be loaded. (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) @@ -1348,24 +1382,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* @@ -1614,12 +1630,6 @@ code to be loaded. ((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 @@ -1759,7 +1769,7 @@ code to be loaded. 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 @@ -1779,7 +1789,7 @@ code to be loaded. ||# (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!")) @@ -1800,11 +1810,12 @@ code to be loaded. ;; 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))) @@ -1831,17 +1842,19 @@ code to be loaded. (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)) () () () @@ -1886,7 +1899,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)) @@ -1902,8 +1916,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 @@ -1947,9 +1960,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*))