X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=a7e276206826001ad27f9a19512b5113211c6e87;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=5cc33477957b2372b6c0164d87a511e5f73ee80c;hpb=c3d4cd43d7cd8e0495dbb9c11fd9c121ea069a45;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 5cc3347..a7e2762 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -87,11 +87,6 @@ ;;;; ;;;; KLUDGE: In SBCL, we only really use variant (1), and any generality ;;;; for the other variants is wasted. -- WHN 20000121 - -;;;; FIXME: the STEP-FUNCTION stuff in the code seems to've been -;;;; intended to support code which was conditionalized with -;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been -;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too. ;;;; list collection macrology @@ -103,52 +98,52 @@ (sb!int:defmacro-mundanely loop-collect-rplacd (&environment env (head-var tail-var &optional user-head-var) form) - (setq form (sb!xc:macroexpand form env)) + (setq form (sb!int:%macroexpand form env)) (flet ((cdr-wrap (form n) - (declare (fixnum n)) - (do () ((<= n 4) (setq form `(,(case n - (1 'cdr) - (2 'cddr) - (3 'cdddr) - (4 'cddddr)) - ,form))) - (setq form `(cddddr ,form) n (- n 4))))) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) (let ((tail-form form) (ncdrs nil)) ;; Determine whether the form being constructed is a list of known ;; length. (when (consp form) - (cond ((eq (car form) 'list) - (setq ncdrs (1- (length (cdr form))))) - ((member (car form) '(list* cons)) - (when (and (cddr form) (member (car (last form)) '(nil 'nil))) - (setq ncdrs (- (length (cdr form)) 2)))))) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form))))) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) (let ((answer - (cond ((null ncdrs) - `(when (setf (cdr ,tail-var) ,tail-form) - (setq ,tail-var (last (cdr ,tail-var))))) - ((< ncdrs 0) (return-from loop-collect-rplacd nil)) - ((= ncdrs 0) - ;; @@@@ Here we have a choice of two idioms: - ;; (RPLACD TAIL (SETQ TAIL TAIL-FORM)) - ;; (SETQ TAIL (SETF (CDR TAIL) TAIL-FORM)). - ;; Genera and most others I have seen do better with the - ;; former. - `(rplacd ,tail-var (setq ,tail-var ,tail-form))) - (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) - ,tail-form) - ncdrs)))))) - ;; If not using locatives or something similar to update the - ;; user's head variable, we've got to set it... It's harmless - ;; to repeatedly set it unconditionally, and probably faster - ;; than checking. - (when user-head-var - (setq answer - `(progn ,answer - (setq ,user-head-var (cdr ,head-var))))) - answer)))) + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;; @@@@ Here we have a choice of two idioms: + ;; (RPLACD TAIL (SETQ TAIL TAIL-FORM)) + ;; (SETQ TAIL (SETF (CDR TAIL) TAIL-FORM)). + ;; Genera and most others I have seen do better with the + ;; former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) + ,tail-form) + ncdrs)))))) + ;; If not using locatives or something similar to update the + ;; user's head variable, we've got to set it... It's harmless + ;; to repeatedly set it unconditionally, and probably faster + ;; than checking. + (when user-head-var + (setq answer + `(progn ,answer + (setq ,user-head-var (cdr ,head-var))))) + answer)))) (sb!int:defmacro-mundanely loop-collect-answer (head-var - &optional user-head-var) + &optional user-head-var) (or user-head-var `(cdr ,head-var))) @@ -169,9 +164,9 @@ constructed. |# (defstruct (loop-minimax - (:constructor make-loop-minimax-internal) - (:copier nil) - (:predicate nil)) + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) answer-variable type temp-variable @@ -186,57 +181,57 @@ constructed. (defun make-loop-minimax (answer-variable type) (let ((infinity-data (cdr (assoc type - *loop-minimax-type-infinities-alist* - :test #'sb!xc:subtypep)))) + *loop-minimax-type-infinities-alist* + :test #'sb!xc:subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable :type type :temp-variable (gensym "LOOP-MAXMIN-TEMP-") :flag-variable (and (not infinity-data) - (gensym "LOOP-MAXMIN-FLAG-")) + (gensym "LOOP-MAXMIN-FLAG-")) :operations nil :infinity-data infinity-data))) (defun loop-note-minimax-operation (operation minimax) (pushnew (the symbol operation) (loop-minimax-operations minimax)) (when (and (cdr (loop-minimax-operations minimax)) - (not (loop-minimax-flag-variable minimax))) + (not (loop-minimax-flag-variable minimax))) (setf (loop-minimax-flag-variable minimax) - (gensym "LOOP-MAXMIN-FLAG-"))) + (gensym "LOOP-MAXMIN-FLAG-"))) operation) (sb!int:defmacro-mundanely with-minimax-value (lm &body body) (let ((init (loop-typed-init (loop-minimax-type lm))) - (which (car (loop-minimax-operations lm))) - (infinity-data (loop-minimax-infinity-data lm)) - (answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (type (loop-minimax-type lm))) + (which (car (loop-minimax-operations lm))) + (infinity-data (loop-minimax-infinity-data lm)) + (answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (type (loop-minimax-type lm))) (if flag-var - `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body) - `(let ((,answer-var ,(if (eq which 'min) - (first infinity-data) - (second infinity-data))) - (,temp-var ,init)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body)))) + `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body) + `(let ((,answer-var ,(if (eq which 'min) + (first infinity-data) + (second infinity-data))) + (,temp-var ,init)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body)))) (sb!int:defmacro-mundanely loop-accumulate-minimax-value (lm operation form) (let* ((answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (test `(,(ecase operation - (min '<) - (max '>)) - ,temp-var ,answer-var))) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (test `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var))) `(progn (setq ,temp-var ,form) (when ,(if flag-var `(or (not ,flag-var) ,test) test) - (setq ,@(and flag-var `(,flag-var t)) - ,answer-var ,temp-var))))) + (setq ,@(and flag-var `(,flag-var t)) + ,answer-var ,temp-var))))) ;;;; LOOP keyword tables @@ -273,68 +268,57 @@ code to be loaded. `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) (defstruct (loop-universe - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) keywords ; hash table, value = (fn-name . extra-data) iteration-keywords ; hash table, value = (fn-name . extra-data) for-keywords ; hash table, value = (fn-name . extra-data) path-keywords ; hash table, value = (fn-name . extra-data) type-symbols ; hash table of type SYMBOLS, test EQ, ; value = CL type specifier - type-keywords ; hash table of type STRINGS, test EQUAL, + type-keywords) ; hash table of type STRINGS, test EQUAL, ; value = CL type spec - ansi ; NIL, T, or :EXTENDED - implicit-for-required) ; see loop-hack-iteration (sb!int:def!method print-object ((u loop-universe) stream) - (let ((string (case (loop-universe-ansi u) - ((nil) "non-ANSI") - ((t) "ANSI") - (:extended "extended-ANSI") - (t (loop-universe-ansi u))))) - (print-unreadable-object (u stream :type t) - (write-string string stream)))) + (print-unreadable-object (u stream :type t :identity t))) ;;; This is the "current" loop context in use when we are expanding a ;;; loop. It gets bound on each invocation of LOOP. (defvar *loop-universe*) (defun make-standard-loop-universe (&key keywords for-keywords - iteration-keywords path-keywords - type-keywords type-symbols ansi) - (declare (type (member nil t :extended) ansi)) + iteration-keywords path-keywords + type-keywords type-symbols) (flet ((maketable (entries) - (let* ((size (length entries)) - (ht (make-hash-table :size (if (< size 10) 10 size) - :test 'equal))) - (dolist (x entries) - (setf (gethash (symbol-name (car x)) ht) (cadr x))) - ht))) + (let* ((size (length entries)) + (ht (make-hash-table :size (if (< size 10) 10 size) + :test 'equal))) + (dolist (x entries) + (setf (gethash (symbol-name (car x)) ht) (cadr x))) + ht))) (make-loop-universe :keywords (maketable keywords) :for-keywords (maketable for-keywords) :iteration-keywords (maketable iteration-keywords) :path-keywords (maketable path-keywords) - :ansi ansi - :implicit-for-required (not (null ansi)) :type-keywords (maketable type-keywords) :type-symbols (let* ((size (length type-symbols)) - (ht (make-hash-table :size (if (< size 10) 10 size) - :test 'eq))) - (dolist (x type-symbols) - (if (atom x) - (setf (gethash x ht) x) - (setf (gethash (car x) ht) (cadr x)))) - ht)))) + (ht (make-hash-table :size (if (< size 10) 10 size) + :test 'eq))) + (dolist (x type-symbols) + (if (atom x) + (setf (gethash x ht) x) + (setf (gethash (car x) ht) (cadr x)))) + ht)))) ;;;; SETQ hackery, including destructuring ("DESETQ") (defun loop-make-psetq (frobs) (and frobs (loop-make-desetq - (list (car frobs) - (if (null (cddr frobs)) (cadr frobs) - `(prog1 ,(cadr frobs) - ,(loop-make-psetq (cddr frobs)))))))) + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) (defun loop-make-desetq (var-val-pairs) (if (null var-val-pairs) @@ -342,66 +326,66 @@ code to be loaded. (cons 'loop-really-desetq var-val-pairs))) (defvar *loop-desetq-temporary* - (make-symbol "LOOP-DESETQ-TEMP")) + (make-symbol "LOOP-DESETQ-TEMP")) (sb!int:defmacro-mundanely loop-really-desetq (&environment env - &rest var-val-pairs) + &rest var-val-pairs) (labels ((find-non-null (var) - ;; See whether there's any non-null thing here. Recurse - ;; if the list element is itself a list. - (do ((tail var)) ((not (consp tail)) tail) - (when (find-non-null (pop tail)) (return t)))) - (loop-desetq-internal (var val &optional temp) - ;; returns a list of actions to be performed - (typecase var - (null - (when (consp val) - ;; Don't lose possible side effects. - (if (eq (car val) 'prog1) - ;; These can come from PSETQ or DESETQ below. - ;; Throw away the value, keep the side effects. - ;; Special case is for handling an expanded POP. - (mapcan (lambda (x) - (and (consp x) - (or (not (eq (car x) 'car)) - (not (symbolp (cadr x))) - (not (symbolp (setq x (sb!xc:macroexpand x env))))) - (cons x nil))) - (cdr val)) - `(,val)))) - (cons - (let* ((car (car var)) - (cdr (cdr var)) - (car-non-null (find-non-null car)) - (cdr-non-null (find-non-null cdr))) - (when (or car-non-null cdr-non-null) - (if cdr-non-null - (let* ((temp-p temp) - (temp (or temp *loop-desetq-temporary*)) - (body `(,@(loop-desetq-internal car - `(car ,temp)) - (setq ,temp (cdr ,temp)) - ,@(loop-desetq-internal cdr - temp - temp)))) - (if temp-p - `(,@(unless (eq temp val) - `((setq ,temp ,val))) - ,@body) - `((let ((,temp ,val)) - ,@body)))) - ;; no CDRing to do - (loop-desetq-internal car `(car ,val) temp))))) - (otherwise - (unless (eq var val) - `((setq ,var ,val))))))) + ;; See whether there's any non-null thing here. Recurse + ;; if the list element is itself a list. + (do ((tail var)) ((not (consp tail)) tail) + (when (find-non-null (pop tail)) (return t)))) + (loop-desetq-internal (var val &optional temp) + ;; returns a list of actions to be performed + (typecase var + (null + (when (consp val) + ;; Don't lose possible side effects. + (if (eq (car val) 'prog1) + ;; These can come from PSETQ or DESETQ below. + ;; Throw away the value, keep the side effects. + ;; Special case is for handling an expanded POP. + (mapcan (lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (sb!int:%macroexpand x env))))) + (cons x nil))) + (cdr val)) + `(,val)))) + (cons + (let* ((car (car var)) + (cdr (cdr var)) + (car-non-null (find-non-null car)) + (cdr-non-null (find-non-null cdr))) + (when (or car-non-null cdr-non-null) + (if cdr-non-null + (let* ((temp-p temp) + (temp (or temp *loop-desetq-temporary*)) + (body `(,@(loop-desetq-internal car + `(car ,temp)) + (setq ,temp (cdr ,temp)) + ,@(loop-desetq-internal cdr + temp + temp)))) + (if temp-p + `(,@(unless (eq temp val) + `((setq ,temp ,val))) + ,@body) + `((let ((,temp ,val)) + ,@body)))) + ;; no CDRing to do + (loop-desetq-internal car `(car ,val) temp))))) + (otherwise + (unless (eq var val) + `((setq ,var ,val))))))) (do ((actions)) - ((null var-val-pairs) - (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) + ((null var-val-pairs) + (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) (setq actions (revappend - (loop-desetq-internal (pop var-val-pairs) - (pop var-val-pairs)) - actions))))) + (loop-desetq-internal (pop var-val-pairs) + (pop var-val-pairs)) + actions))))) ;;;; LOOP-local variables @@ -426,10 +410,11 @@ code to be loaded. ;;; See LOOP-NAMED-VAR. (defvar *loop-named-vars*) -;;; LETlist-like list being accumulated for one group of parallel bindings. +;;; LETlist-like list being accumulated for current group of bindings. (defvar *loop-vars*) -;;; list of declarations being accumulated in parallel with *LOOP-VARS* +;;; List of declarations being accumulated in parallel with +;;; *LOOP-VARS*. (defvar *loop-declarations*) ;;; This is used by LOOP for destructuring binding, if it is doing @@ -438,22 +423,18 @@ code to be loaded. ;;; list of wrapping forms, innermost first, which go immediately ;;; inside the current set of parallel bindings being accumulated in -;;; *LOOP-VARS*. The wrappers are appended onto a body. E.g., -;;; this list could conceivably have as its value +;;; *LOOP-VARS*. The wrappers are appended onto a body. E.g., this +;;; list could conceivably have as its value ;;; ((WITH-OPEN-FILE (G0001 G0002 ...))), -;;; with G0002 being one of the bindings in *LOOP-VARS* (This is -;;; why the wrappers go inside of the variable bindings). +;;; with G0002 being one of the bindings in *LOOP-VARS* (This is why +;;; the wrappers go inside of the variable bindings). (defvar *loop-wrappers*) -;;; This accumulates lists of previous values of *LOOP-VARS* and -;;; the other lists above, for each new nesting of bindings. See +;;; This accumulates lists of previous values of *LOOP-VARS* and the +;;; other lists above, for each new nesting of bindings. See ;;; LOOP-BIND-BLOCK. (defvar *loop-bind-stack*) -;;; This is simply a list of LOOP iteration variables, used for -;;; checking for duplications. -(defvar *loop-iteration-vars*) - ;;; list of prologue forms of the loop, accumulated in reverse order (defvar *loop-prologue*) @@ -479,8 +460,8 @@ code to be loaded. (defvar *loop-after-epilogue*) ;;; the "culprit" responsible for supplying a final value from the -;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple -;;; return values being supplied. +;;; loop. This is so LOOP-DISALLOW-AGGREGATE-BOOLEANS can moan about +;;; disallowed anonymous collections. (defvar *loop-final-value-culprit*) ;;; If this is true, we are in some branch of a conditional. Some @@ -506,229 +487,42 @@ code to be loaded. ;;;; code analysis stuff (defun loop-constant-fold-if-possible (form &optional expected-type) - (let ((new-form form) (constantp nil) (constant-value nil)) - (when (setq constantp (constantp new-form)) - (setq constant-value (eval new-form))) + (let* ((constantp (sb!xc:constantp form)) + (value (and constantp (sb!int:constant-form-value form)))) (when (and constantp expected-type) - (unless (sb!xc:typep constant-value expected-type) - (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." - form constant-value expected-type) - (setq constantp nil constant-value nil))) - (values new-form constantp constant-value))) - -(defun loop-constantp (form) - (constantp form)) + (unless (sb!xc:typep value expected-type) + (loop-warn "~@" + form value expected-type) + (setq constantp nil value nil))) + (values form constantp value))) -;;;; LOOP iteration optimization - -(defvar *loop-duplicate-code* - nil) - -(defvar *loop-iteration-flag-var* - (make-symbol "LOOP-NOT-FIRST-TIME")) - -(defun loop-code-duplication-threshold (env) - (declare (ignore env)) - (let (;; If we could read optimization declaration information (as - ;; with the DECLARATION-INFORMATION function (present in - ;; CLTL2, removed from ANSI standard) we could set these - ;; values flexibly. Without DECLARATION-INFORMATION, we have - ;; to set them to constants. - (speed 1) - (space 1)) - (+ 40 (* (- speed space) 10)))) - -(sb!int:defmacro-mundanely loop-body (&environment env - prologue - before-loop - main-body - after-loop - epilogue - &aux rbefore rafter flagvar) +(sb!int:defmacro-mundanely loop-body (prologue + before-loop + main-body + after-loop + epilogue) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists")) - ;;All our work is done from these copies, working backwards from the end: - (setq rbefore (reverse before-loop) rafter (reverse after-loop)) - (labels ((psimp (l) - (let ((ans nil)) - (dolist (x l) - (when x - (push x ans) - (when (and (consp x) - (member (car x) '(go return return-from))) - (return nil)))) - (nreverse ans))) - (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) - (makebody () - (let ((form `(tagbody - ,@(psimp (append prologue (nreverse rbefore))) - next-loop - ,@(psimp (append main-body - (nreconc rafter - `((go next-loop))))) - end-loop - ,@(psimp epilogue)))) - (if flagvar `(let ((,flagvar nil)) ,form) form)))) - (when (or *loop-duplicate-code* (not rbefore)) - (return-from loop-body (makebody))) - ;; This outer loop iterates once for each not-first-time flag test - ;; generated plus once more for the forms that don't need a flag test. - (do ((threshold (loop-code-duplication-threshold env))) (nil) - (declare (fixnum threshold)) - ;; Go backwards from the ends of before-loop and after-loop - ;; merging all the equivalent forms into the body. - (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) - (push (pop rbefore) main-body) - (pop rafter)) - (unless rbefore (return (makebody))) - ;; The first forms in RBEFORE & RAFTER (which are the - ;; chronologically last forms in the list) differ, therefore - ;; they cannot be moved into the main body. If everything that - ;; chronologically precedes them either differs or is equal but - ;; is okay to duplicate, we can just put all of rbefore in the - ;; prologue and all of rafter after the body. Otherwise, there - ;; is something that is not okay to duplicate, so it and - ;; everything chronologically after it in rbefore and rafter - ;; must go into the body, with a flag test to distinguish the - ;; first time around the loop from later times. What - ;; chronologically precedes the non-duplicatable form will be - ;; handled the next time around the outer loop. - (do ((bb rbefore (cdr bb)) - (aa rafter (cdr aa)) - (lastdiff nil) - (count 0) - (inc nil)) - ((null bb) (return-from loop-body (makebody))) ; Did it. - (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) - ((or (not (setq inc (estimate-code-size (car bb) env))) - (> (incf count inc) threshold)) - ;; Ok, we have found a non-duplicatable piece of code. - ;; Everything chronologically after it must be in the - ;; central body. Everything chronologically at and - ;; after LASTDIFF goes into the central body under a - ;; flag test. - (let ((then nil) (else nil)) - (do () (nil) - (push (pop rbefore) else) - (push (pop rafter) then) - (when (eq rbefore (cdr lastdiff)) (return))) - (unless flagvar - (push `(setq ,(setq flagvar *loop-iteration-flag-var*) - t) - else)) - (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) - main-body)) - ;; Everything chronologically before lastdiff until the - ;; non-duplicatable form (CAR BB) is the same in - ;; RBEFORE and RAFTER, so just copy it into the body. - (do () (nil) - (pop rafter) - (push (pop rbefore) main-body) - (when (eq rbefore (cdr bb)) (return))) - (return))))))) - -(defun duplicatable-code-p (expr env) - (if (null expr) 0 - (let ((ans (estimate-code-size expr env))) - (declare (fixnum ans)) - ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to - ;; get an alist of optimize quantities back to help quantify - ;; how much code we are willing to duplicate. - ans))) - -(defvar *special-code-sizes* - '((return 0) (progn 0) - (null 1) (not 1) (eq 1) (car 1) (cdr 1) - (when 1) (unless 1) (if 1) - (caar 2) (cadr 2) (cdar 2) (cddr 2) - (caaar 3) (caadr 3) (cadar 3) (caddr 3) - (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) - (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) - (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) - (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) - (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) - -(defvar *estimate-code-size-punt* - '(block - do do* dolist - flet - labels lambda let let* locally - macrolet multiple-value-bind - prog prog* - symbol-macrolet - tagbody - unwind-protect - with-open-file)) - -(defun destructuring-size (x) - (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) - ((atom x) (+ n (if (null x) 0 1))))) - -(defun estimate-code-size (x env) - (catch 'estimate-code-size - (estimate-code-size-1 x env))) - -(defun estimate-code-size-1 (x env) - (flet ((list-size (l) - (let ((n 0)) - (declare (fixnum n)) - (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) - ;;@@@@ ???? (declare (function list-size (list) fixnum)) - (cond ((constantp x) 1) - ((symbolp x) (multiple-value-bind (new-form expanded-p) - (sb!xc:macroexpand-1 x env) - (if expanded-p - (estimate-code-size-1 new-form env) - 1))) - ((atom x) 1) ;; ??? self-evaluating??? - ((symbolp (car x)) - (let ((fn (car x)) (tem nil) (n 0)) - (declare (symbol fn) (fixnum n)) - (macrolet ((f (overhead &optional (args nil args-p)) - `(the fixnum (+ (the fixnum ,overhead) - (the fixnum - (list-size ,(if args-p - args - '(cdr x)))))))) - (cond ((setq tem (get fn 'estimate-code-size)) - (typecase tem - (fixnum (f tem)) - (t (funcall tem x env)))) - ((setq tem (assoc fn *special-code-sizes*)) - (f (second tem))) - ((eq fn 'cond) - (dolist (clause (cdr x) n) - (incf n (list-size clause)) (incf n))) - ((eq fn 'desetq) - (do ((l (cdr x) (cdr l))) ((null l) n) - (setq n (+ n - (destructuring-size (car l)) - (estimate-code-size-1 (cadr l) env))))) - ((member fn '(setq psetq)) - (do ((l (cdr x) (cdr l))) ((null l) n) - (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))) - 1 - (throw 'duplicatable-code-p nil))) - ((eq fn 'multiple-value-setq) - (f (length (second x)) (cddr x))) - ((eq fn 'return-from) - (1+ (estimate-code-size-1 (third x) env))) - ((or (special-operator-p fn) - (member fn *estimate-code-size-punt*)) - (throw 'estimate-code-size nil)) - (t (multiple-value-bind (new-form expanded-p) - (sb!xc:macroexpand-1 x env) - (if expanded-p - (estimate-code-size-1 new-form env) - (f 3)))))))) - (t (throw 'estimate-code-size nil))))) + ;; All our work is done from these copies, working backwards from the end + (let ((rbefore (reverse before-loop)) + (rafter (reverse after-loop))) + ;; Go backwards from the ends of before-loop and after-loop + ;; merging all the equivalent forms into the body. + (do () + ((or (null rbefore) + (not (equal (car rbefore) (car rafter))))) + (push (pop rbefore) main-body) + (pop rafter)) + `(tagbody + ,@(remove nil prologue) + ,@(nreverse (remove nil rbefore)) + next-loop + ,@(remove nil main-body) + ,@(nreverse (remove nil rafter)) + (go next-loop) + end-loop + ,@(remove nil epilogue)))) ;;;; loop errors @@ -738,114 +532,132 @@ code to be loaded. (defun loop-error (format-string &rest format-args) (error 'sb!int:simple-program-error - :format-control "~?~%current LOOP context:~{ ~S~}." - :format-arguments (list format-string format-args (loop-context)))) + :format-control "~?~%current LOOP context:~{ ~S~}." + :format-arguments (list format-string format-args (loop-context)))) (defun loop-warn (format-string &rest format-args) (warn "~?~%current LOOP context:~{ ~S~}." - format-string - format-args - (loop-context))) + format-string + format-args + (loop-context))) (defun loop-check-data-type (specified-type required-type - &optional (default-type required-type)) + &optional (default-type required-type)) (if (null specified-type) default-type (multiple-value-bind (a b) (sb!xc:subtypep specified-type required-type) - (cond ((not b) - (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." - specified-type required-type)) - ((not a) - (loop-error "The specified data type ~S is not a subtype of ~S." - specified-type required-type))) - specified-type))) + (cond ((not b) + (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." + specified-type required-type)) + ((not a) + (loop-error "The specified data type ~S is not a subtype of ~S." + 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)) (defun loop-translate (*loop-source-code* - *loop-macro-environment* - *loop-universe*) + *loop-macro-environment* + *loop-universe*) (let ((*loop-original-source-code* *loop-source-code*) - (*loop-source-context* nil) - (*loop-iteration-vars* nil) - (*loop-vars* nil) - (*loop-named-vars* nil) - (*loop-declarations* nil) - (*loop-desetq-crocks* nil) - (*loop-bind-stack* nil) - (*loop-prologue* nil) - (*loop-wrappers* nil) - (*loop-before-loop* nil) - (*loop-body* nil) - (*loop-emitted-body* nil) - (*loop-after-body* nil) - (*loop-epilogue* nil) - (*loop-after-epilogue* nil) - (*loop-final-value-culprit* nil) - (*loop-inside-conditional* nil) - (*loop-when-it-var* nil) - (*loop-never-stepped-var* nil) - (*loop-names* nil) - (*loop-collection-cruft* nil)) + (*loop-source-context* nil) + (*loop-vars* nil) + (*loop-named-vars* nil) + (*loop-declarations* nil) + (*loop-desetq-crocks* nil) + (*loop-bind-stack* nil) + (*loop-prologue* nil) + (*loop-wrappers* nil) + (*loop-before-loop* nil) + (*loop-body* nil) + (*loop-emitted-body* nil) + (*loop-after-body* nil) + (*loop-epilogue* nil) + (*loop-after-epilogue* nil) + (*loop-final-value-culprit* nil) + (*loop-inside-conditional* nil) + (*loop-when-it-var* nil) + (*loop-never-stepped-var* nil) + (*loop-names* nil) + (*loop-collection-cruft* nil)) (loop-iteration-driver) (loop-bind-block) (let ((answer `(loop-body - ,(nreverse *loop-prologue*) - ,(nreverse *loop-before-loop*) - ,(nreverse *loop-body*) - ,(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))) + ,(nreverse *loop-prologue*) + ,(nreverse *loop-before-loop*) + ,(nreverse *loop-body*) + ,(nreverse *loop-after-body*) + ,(nreconc *loop-epilogue* + (nreverse *loop-after-epilogue*))))) (dolist (entry *loop-bind-stack*) - (let ((vars (first entry)) - (dcls (second entry)) - (crocks (third entry)) - (wrappers (fourth entry))) - (dolist (w wrappers) - (setq answer (append w (list answer)))) - (when (or vars dcls crocks) - (let ((forms (list answer))) - ;;(when crocks (push crocks forms)) - (when dcls (push `(declare ,@dcls) forms)) - (setq answer `(,(if vars 'let 'locally) - ,vars - ,@(loop-build-destructuring-bindings crocks - forms))))))) + (let ((vars (first entry)) + (dcls (second entry)) + (crocks (third entry)) + (wrappers (fourth entry))) + (dolist (w wrappers) + (setq answer (append w (list answer)))) + (when (or vars dcls crocks) + (let ((forms (list answer))) + ;;(when crocks (push crocks forms)) + (when dcls (push `(declare ,@dcls) forms)) + (setq answer `(,(if vars 'let 'locally) + ,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 () - (do () ((null *loop-source-code*)) + (do () + ((null *loop-source-code*)) (let ((keyword (car *loop-source-code*)) (tem nil)) (cond ((not (symbolp keyword)) - (loop-error "~S found where LOOP keyword expected" keyword)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (cond ((setq tem - (loop-lookup-keyword keyword - (loop-universe-keywords - *loop-universe*))) - ;; It's a "miscellaneous" toplevel LOOP keyword (DO, - ;; COLLECT, NAMED, etc.) - (apply (symbol-function (first tem)) (rest tem))) - ((setq tem - (loop-lookup-keyword keyword - (loop-universe-iteration-keywords *loop-universe*))) - (loop-hack-iteration tem)) - ((loop-tmember keyword '(and else)) - ;; The alternative is to ignore it, i.e. let it go - ;; around to the next keyword... - (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." - keyword - (car *loop-source-code*) - (cadr *loop-source-code*))) - (t (loop-error "unknown LOOP keyword: ~S" keyword)))))))) + (loop-error "~S found where LOOP keyword expected" keyword)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (cond ((setq tem + (loop-lookup-keyword keyword + (loop-universe-keywords + *loop-universe*))) + ;; It's a "miscellaneous" toplevel LOOP keyword (DO, + ;; COLLECT, NAMED, etc.) + (apply (symbol-function (first tem)) (rest tem))) + ((setq tem + (loop-lookup-keyword keyword + (loop-universe-iteration-keywords *loop-universe*))) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; The alternative is to ignore it, i.e. let it go + ;; around to the next keyword... + (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." + keyword + (car *loop-source-code*) + (cadr *loop-source-code*))) + (t (loop-error "unknown LOOP keyword: ~S" keyword)))))))) (defun loop-pop-source () (if *loop-source-code* @@ -876,219 +688,256 @@ code to be loaded. (defun loop-pseudo-body (form) (cond ((or *loop-emitted-body* *loop-inside-conditional*) - (push form *loop-body*)) - (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + (push form *loop-body*)) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) (defun loop-emit-body (form) (setq *loop-emitted-body* t) (loop-pseudo-body form)) -(defun loop-emit-final-value (form) - (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-final-value-culprit*)) +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) (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 -(defun loop-typed-init (data-type) - (when (and data-type (sb!xc:subtypep data-type 'number)) - (if (or (sb!xc:subtypep data-type 'float) - (sb!xc:subtypep data-type '(complex float))) - (coerce 0 data-type) - 0))) +(defun loop-typed-init (data-type &optional step-var-p) + (cond ((null data-type) + nil) + ((sb!xc:subtypep data-type 'number) + (let ((init (if step-var-p 1 0))) + (flet ((like (&rest types) + (coerce init (find-if (lambda (type) + (sb!xc:subtypep data-type type)) + types)))) + (cond ((sb!xc:subtypep data-type 'float) + (like 'single-float 'double-float + 'short-float 'long-float 'float)) + ((sb!xc:subtypep data-type '(complex float)) + (like '(complex single-float) + '(complex double-float) + '(complex short-float) + '(complex long-float) + '(complex float))) + (t + init))))) + ((sb!xc:subtypep data-type 'vector) + (let ((ctype (sb!kernel:specifier-type data-type))) + (when (sb!kernel:array-type-p ctype) + (let ((etype (sb!kernel:type-*-to-t + (sb!kernel:array-type-specialized-element-type ctype)))) + (make-array 0 :element-type (sb!kernel:type-specifier etype)))))) + ((sb!xc:typep #\x data-type) + #\x) + (t + nil))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. (and *loop-source-code* ; Don't get confused by NILs.. (let ((z (car *loop-source-code*))) - (cond ((loop-tequal z 'of-type) - ;; This is the syntactically unambigous form in that - ;; the form of the type specifier does not matter. - ;; Also, it is assumed that the type specifier is - ;; unambiguously, and without need of translation, a - ;; common lisp type specifier or pattern (matching the - ;; variable) thereof. - (loop-pop-source) - (loop-pop-source)) - - ((symbolp z) - ;; This is the (sort of) "old" syntax, even though we - ;; didn't used to support all of these type symbols. - (let ((type-spec (or (gethash z - (loop-universe-type-symbols - *loop-universe*)) - (gethash (symbol-name z) - (loop-universe-type-keywords - *loop-universe*))))) - (when type-spec - (loop-pop-source) - type-spec))) - (t - ;; This is our sort-of old syntax. But this is only - ;; valid for when we are destructuring, so we will be - ;; compulsive (should we really be?) and require that - ;; we in fact be doing variable destructuring here. We - ;; must translate the old keyword pattern typespec - ;; into a fully-specified pattern of real type - ;; specifiers here. - (if (consp variable) - (unless (consp z) - (loop-error - "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected" - z)) - (loop-error "~S found where a LOOP keyword or LOOP type keyword expected" z)) - (loop-pop-source) - (labels ((translate (k v) - (cond ((null k) nil) - ((atom k) - (replicate - (or (gethash k - (loop-universe-type-symbols - *loop-universe*)) - (gethash (symbol-name k) - (loop-universe-type-keywords - *loop-universe*)) - (loop-error - "The destructuring type pattern ~S contains the unrecognized type keyword ~S." - z k)) - v)) - ((atom v) - (loop-error - "The destructuring type pattern ~S doesn't match the variable pattern ~S." - z variable)) - (t (cons (translate (car k) (car v)) - (translate (cdr k) (cdr v)))))) - (replicate (typ v) - (if (atom v) - typ - (cons (replicate typ (car v)) - (replicate typ (cdr v)))))) - (translate z variable))))))) + (cond ((loop-tequal z 'of-type) + ;; This is the syntactically unambigous form in that + ;; the form of the type specifier does not matter. + ;; Also, it is assumed that the type specifier is + ;; unambiguously, and without need of translation, a + ;; common lisp type specifier or pattern (matching the + ;; variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;; This is the (sort of) "old" syntax, even though we + ;; didn't used to support all of these type symbols. + (let ((type-spec (or (gethash z + (loop-universe-type-symbols + *loop-universe*)) + (gethash (symbol-name z) + (loop-universe-type-keywords + *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;; This is our sort-of old syntax. But this is only + ;; valid for when we are destructuring, so we will be + ;; compulsive (should we really be?) and require that + ;; we in fact be doing variable destructuring here. We + ;; must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type + ;; specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected" + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected" z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k + (loop-universe-type-symbols + *loop-universe*)) + (gethash (symbol-name k) + (loop-universe-type-keywords + *loop-universe*)) + (loop-error + "The destructuring type pattern ~S contains the unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "The destructuring type pattern ~S doesn't match the variable pattern ~S." + z variable)) + (t (cons (translate (car k) (car v)) + (translate (cdr k) (cdr v)))))) + (replicate (typ v) + (if (atom v) + typ + (cons (replicate typ (car v)) + (replicate typ (cdr v)))))) + (translate z variable))))))) ;;;; loop variables (defun loop-bind-block () (when (or *loop-vars* *loop-declarations* *loop-wrappers*) (push (list (nreverse *loop-vars*) - *loop-declarations* - *loop-desetq-crocks* - *loop-wrappers*) - *loop-bind-stack*) + *loop-declarations* + *loop-desetq-crocks* + *loop-wrappers*) + *loop-bind-stack*) (setq *loop-vars* nil - *loop-declarations* nil - *loop-desetq-crocks* nil - *loop-wrappers* nil))) - -(defun loop-make-var (name initialization dtype &optional iteration-var-p) + *loop-declarations* nil + *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 step-var-p) (cond ((null name) - (cond ((not (null initialization)) - (push (list (setq name (gensym "LOOP-IGNORE-")) - initialization) - *loop-vars*) - (push `(ignore ,name) *loop-declarations*)))) - ((atom name) - (cond (iteration-var-p - (if (member name *loop-iteration-vars*) - (loop-error "duplicated LOOP iteration variable ~S" name) - (push name *loop-iteration-vars*))) - ((assoc name *loop-vars*) - (loop-error "duplicated variable ~S in LOOP parallel binding" - name))) - (unless (symbolp name) - (loop-error "bad variable ~S somewhere in LOOP" name)) - (loop-declare-var name dtype) - ;; We use ASSOC on this list to check for duplications (above), - ;; so don't optimize out this list: - (push (list name (or initialization (loop-typed-init dtype))) - *loop-vars*)) - (initialization - (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) + (setq name (gensym "LOOP-IGNORE-")) + (push (list name initialization) *loop-vars*) + (push `(ignore ,name) *loop-declarations*) + (loop-declare-var name dtype)) + ((atom name) + (when (or (assoc name *loop-vars*) + (loop-var-p name)) + (loop-error "duplicated variable ~S in a LOOP binding" name)) + (unless (symbolp name) + (loop-error "bad variable ~S somewhere in LOOP" name)) + (loop-declare-var name dtype step-var-p initialization) + ;; We use ASSOC on this list to check for duplications (above), + ;; so don't optimize out this list: + (push (list name (or initialization (loop-typed-init dtype step-var-p))) + *loop-vars*)) + (initialization + (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) (loop-declare-var name dtype) (push (list newvar initialization) *loop-vars*) ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. (setq *loop-desetq-crocks* (list* name newvar *loop-desetq-crocks*)))) - (t (let ((tcar nil) (tcdr nil)) - (if (atom dtype) (setq tcar (setq tcdr dtype)) - (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-var (car name) nil tcar iteration-var-p) - (loop-make-var (cdr name) nil tcdr iteration-var-p)))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-var (car name) nil tcar) + (loop-make-var (cdr name) nil tcdr)))) name) -(defun loop-make-iteration-var (name initialization dtype) - (loop-make-var name initialization dtype t)) - -(defun loop-declare-var (name dtype) +(defun loop-declare-var (name dtype &optional step-var-p initialization) (cond ((or (null name) (null dtype) (eq dtype t)) nil) - ((symbolp name) - (unless (sb!xc:subtypep t dtype) - (let ((dtype (let ((init (loop-typed-init dtype))) - (if (sb!xc:typep init dtype) - dtype - `(or (member ,init) ,dtype))))) - (push `(type ,dtype ,name) *loop-declarations*)))) - ((consp name) - (cond ((consp dtype) - (loop-declare-var (car name) (car dtype)) - (loop-declare-var (cdr name) (cdr dtype))) - (t (loop-declare-var (car name) dtype) - (loop-declare-var (cdr name) dtype)))) - (t (error "invalid LOOP variable passed in: ~S" name)))) + ((symbolp name) + (unless (or (sb!xc:subtypep t dtype) + (and (eq (find-package :cl) (symbol-package name)) + (eq :special (sb!int:info :variable :kind name)))) + (let ((dtype (if initialization + dtype + (let ((init (loop-typed-init dtype step-var-p))) + (if (sb!xc:typep init dtype) + dtype + `(or ,(type-of init) ,dtype)))))) + (push `(type ,dtype ,name) *loop-declarations*)))) + ((consp name) + (cond ((consp dtype) + (loop-declare-var (car name) (car dtype)) + (loop-declare-var (cdr name) (cdr dtype))) + (t (loop-declare-var (car name) dtype) + (loop-declare-var (cdr name) dtype)))) + (t (error "invalid LOOP variable passed in: ~S" name)))) (defun loop-maybe-bind-form (form data-type) - (if (loop-constantp form) + (if (constantp form) form (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) - (cond ((not (symbolp key)) - (loop-error - "~S found where keyword expected getting LOOP clause after ~S" - key for)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (when (loop-tequal (car *loop-source-code*) 'it) - (setq *loop-source-code* - (cons (or it-p - (setq it-p - (loop-when-it-var))) - (cdr *loop-source-code*)))) - (cond ((or (not (setq data (loop-lookup-keyword - key (loop-universe-keywords *loop-universe*)))) - (progn (apply (symbol-function (car data)) - (cdr data)) - (null *loop-body*))) - (loop-error - "~S does not introduce a LOOP clause that can follow ~S." - key for)) - (t (setq body (nreconc *loop-body* body))))))) - (if (loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (return (if (cdr body) - `(progn ,@(nreverse body)) - (car body))))))) + (do ((body nil)) (nil) + (let ((key (car *loop-source-code*)) (*loop-body* nil) data) + (cond ((not (symbolp key)) + (loop-error + "~S found where keyword expected getting LOOP clause after ~S" + key for)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (when (and (loop-tequal (car *loop-source-code*) 'it) + first-clause-p) + (setq *loop-source-code* + (cons (or it-p + (setq it-p + (loop-when-it-var))) + (cdr *loop-source-code*)))) + (cond ((or (not (setq data (loop-lookup-keyword + key (loop-universe-keywords *loop-universe*)))) + (progn (apply (symbol-function (car data)) + (cdr data)) + (null *loop-body*))) + (loop-error + "~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) + `(progn ,@(nreverse body)) + (car body))))))) (let ((then (get-clause for)) - (else (when (loop-tequal (car *loop-source-code*) :else) - (loop-pop-source) - (list (get-clause :else))))) - (when (loop-tequal (car *loop-source-code*) :end) - (loop-pop-source)) - (when it-p (setq form `(setq ,it-p ,form))) - (loop-pseudo-body - `(if ,(if negatep `(not ,form) form) - ,then - ,@else)))))) + (else (when (loop-tequal (car *loop-source-code*) :else) + (loop-pop-source) + (list (get-clause :else))))) + (when (loop-tequal (car *loop-source-code*) :end) + (loop-pop-source)) + (when it-p (setq form `(setq ,it-p ,form))) + (loop-pseudo-body + `(if ,(if negatep `(not ,form) form) + ,then + ,@else)))))) (defun loop-do-initially () (loop-disallow-conditional :initially) @@ -1109,17 +958,17 @@ code to be loaded. (loop-error "The NAMED ~S clause occurs too late." name)) (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)))) + (car *loop-names*) name)) + (setq *loop-names* (list name)))) (defun loop-do-return () - (loop-pseudo-body (loop-construct-return (loop-get-form)))) + (loop-emit-body (loop-construct-return (loop-get-form)))) ;;;; value accumulation: LIST (defstruct (loop-collector - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) name class (history nil) @@ -1129,55 +978,57 @@ code to be loaded. (defun loop-get-collection-info (collector class default-type) (let ((form (loop-get-form)) - (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) - (name (when (loop-tequal (car *loop-source-code*) 'into) - (loop-pop-source) - (loop-pop-source)))) + (name (when (loop-tequal (car *loop-source-code*) 'into) + (loop-pop-source) + (loop-pop-source)))) (when (not (symbolp name)) (loop-error "The value accumulation recipient name, ~S, is not a symbol." name)) - (unless dtype - (setq dtype (or (loop-optional-type) default-type))) - (let ((cruft (find (the symbol name) *loop-collection-cruft* - :key #'loop-collector-name))) + (unless name + (loop-disallow-aggregate-booleans)) + (let ((dtype (or (loop-optional-type) default-type)) + (cruft (find (the symbol name) *loop-collection-cruft* + :key #'loop-collector-name))) (cond ((not cruft) - (push (setq cruft (make-loop-collector - :name name :class class - :history (list collector) :dtype dtype)) - *loop-collection-cruft*)) - (t (unless (eq (loop-collector-class cruft) class) - (loop-error - "incompatible kinds of LOOP value accumulation specified for collecting~@ - ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" - name (car (loop-collector-history cruft)) collector)) - (unless (equal dtype (loop-collector-dtype cruft)) - (loop-warn - "unequal datatypes specified in different LOOP value accumulations~@ - into ~S: ~S and ~S" - name dtype (loop-collector-dtype cruft)) - (when (eq (loop-collector-dtype cruft) t) - (setf (loop-collector-dtype cruft) dtype))) - (push collector (loop-collector-history 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)) + *loop-collection-cruft*)) + (t (unless (eq (loop-collector-class cruft) class) + (loop-error + "incompatible kinds of LOOP value accumulation specified for collecting~@ + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" + name (car (loop-collector-history cruft)) collector)) + (unless (equal dtype (loop-collector-dtype cruft)) + (loop-warn + "unequal datatypes specified in different LOOP value accumulations~@ + into ~S: ~S and ~S" + name dtype (loop-collector-dtype cruft)) + (when (eq (loop-collector-dtype cruft) t) + (setf (loop-collector-dtype cruft) dtype))) + (push collector (loop-collector-history cruft)))) (values cruft form)))) -(defun loop-list-collection (specifically) ; NCONC, LIST, or APPEND +(defun loop-list-collection (specifically) ; NCONC, LIST, or APPEND (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list* (gensym "LOOP-LIST-HEAD-") - (gensym "LOOP-LIST-TAIL-") - (and (loop-collector-name lc) - (list (loop-collector-name lc)))))) - (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) - (unless (loop-collector-name lc) - (loop-emit-final-value `(loop-collect-answer ,(car tempvars) - ,@(cddr tempvars))))) + (setf (loop-collector-tempvars lc) + (setq tempvars (list* (gensym "LOOP-LIST-HEAD-") + (gensym "LOOP-LIST-TAIL-") + (and (loop-collector-name lc) + (list (loop-collector-name lc)))))) + (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) + (unless (loop-collector-name lc) + (loop-emit-final-value `(loop-collect-answer ,(car tempvars) + ,@(cddr tempvars))))) (ecase specifically - (list (setq form `(list ,form))) - (nconc nil) - (append (unless (and (consp form) (eq (car form) 'list)) - (setq form `(copy-list ,form))))) + (list (setq form `(list ,form))) + (nconc nil) + (append (unless (and (consp form) (eq (car form) 'list)) + (setq form `(copy-list ,form))))) (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) ;;;; value accumulation: MAX, MIN, SUM, COUNT @@ -1188,21 +1039,21 @@ code to be loaded. (loop-check-data-type (loop-collector-dtype lc) required-type) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list (loop-make-var - (or (loop-collector-name lc) - (gensym "LOOP-SUM-")) - nil (loop-collector-dtype lc))))) - (unless (loop-collector-name lc) - (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (setf (loop-collector-tempvars lc) + (setq tempvars (list (loop-make-var + (or (loop-collector-name lc) + (gensym "LOOP-SUM-")) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) (loop-emit-body - (if (eq specifically 'count) - `(when ,form - (setq ,(car tempvars) - (1+ ,(car tempvars)))) - `(setq ,(car tempvars) - (+ ,(car tempvars) - ,form))))))) + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + (1+ ,(car tempvars)))) + `(setq ,(car tempvars) + (+ ,(car tempvars) + ,form))))))) (defun loop-maxmin-collection (specifically) (multiple-value-bind (lc form) @@ -1210,18 +1061,18 @@ code to be loaded. (loop-check-data-type (loop-collector-dtype lc) 'real) (let ((data (loop-collector-data lc))) (unless data - (setf (loop-collector-data lc) - (setq data (make-loop-minimax - (or (loop-collector-name lc) - (gensym "LOOP-MAXMIN-")) - (loop-collector-dtype lc)))) - (unless (loop-collector-name lc) - (loop-emit-final-value (loop-minimax-answer-variable data)))) + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) + (gensym "LOOP-MAXMIN-")) + (loop-collector-dtype lc)))) + (unless (loop-collector-name lc) + (loop-emit-final-value (loop-minimax-answer-variable data)))) (loop-note-minimax-operation specifically data) (push `(with-minimax-value ,data) *loop-wrappers*) (loop-emit-body `(loop-accumulate-minimax-value ,data - ,specifically - ,form))))) + ,specifically + ,form))))) ;;;; value accumulation: aggregate booleans @@ -1231,8 +1082,9 @@ 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-construct-return nil))) (loop-emit-final-value t))) ;;; handling the THEREIS loop keyword @@ -1240,136 +1092,130 @@ 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) + (do ((var) (val) (dtype)) + (nil) (setq var (loop-pop-source) - dtype (loop-optional-type var) - val (cond ((loop-tequal (car *loop-source-code*) :=) - (loop-pop-source) - (loop-get-form)) - (t nil))) + dtype (loop-optional-type var) + val (cond ((loop-tequal (car *loop-source-code*) :=) + (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) - (return (loop-bind-block))))) + (loop-pop-source) + (return (loop-bind-block))))) ;;;; the iteration driver (defun loop-hack-iteration (entry) (flet ((make-endtest (list-of-forms) - (cond ((null list-of-forms) nil) - ((member t list-of-forms) '(go end-loop)) - (t `(when ,(if (null (cdr (setq list-of-forms - (nreverse list-of-forms)))) - (car list-of-forms) - (cons 'or list-of-forms)) - (go end-loop)))))) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms + (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) (do ((pre-step-tests nil) - (steps nil) - (post-step-tests nil) - (pseudo-steps nil) - (pre-loop-pre-step-tests nil) - (pre-loop-steps nil) - (pre-loop-post-step-tests nil) - (pre-loop-pseudo-steps nil) - (tem) (data)) - (nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) ;; Note that we collect endtests in reverse order, but steps in correct ;; order. MAKE-ENDTEST does the nreverse for us. (setq tem (setq data - (apply (symbol-function (first entry)) (rest entry)))) + (apply (symbol-function (first entry)) (rest entry)))) (and (car tem) (push (car tem) pre-step-tests)) (setq steps (nconc steps (copy-list (car (setq tem (cdr tem)))))) (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) (setq pseudo-steps - (nconc pseudo-steps (copy-list (car (setq tem (cdr tem)))))) + (nconc pseudo-steps (copy-list (car (setq tem (cdr tem)))))) (setq tem (cdr tem)) (when *loop-emitted-body* - (loop-error "iteration in LOOP follows body code")) + (loop-error "iteration in LOOP follows body code")) (unless tem (setq tem data)) (when (car tem) (push (car tem) pre-loop-pre-step-tests)) ;; FIXME: This (SETF FOO (NCONC FOO BAR)) idiom appears often enough ;; that it might be worth making it into an NCONCF macro. (setq pre-loop-steps - (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem)))))) + (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem)))))) (when (car (setq tem (cdr tem))) - (push (car tem) pre-loop-post-step-tests)) + (push (car tem) pre-loop-post-step-tests)) (setq pre-loop-pseudo-steps - (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) + (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) (unless (loop-tequal (car *loop-source-code*) :and) - (setq *loop-before-loop* - (list* (loop-make-desetq pre-loop-pseudo-steps) - (make-endtest pre-loop-post-step-tests) - (loop-make-psetq pre-loop-steps) - (make-endtest pre-loop-pre-step-tests) - *loop-before-loop*)) - (setq *loop-after-body* - (list* (loop-make-desetq pseudo-steps) - (make-endtest post-step-tests) - (loop-make-psetq steps) - (make-endtest pre-step-tests) - *loop-after-body*)) - (loop-bind-block) - (return nil)) - (loop-pop-source) ; Flush the "AND". - (when (and (not (loop-universe-implicit-for-required *loop-universe*)) - (setq tem - (loop-lookup-keyword - (car *loop-source-code*) - (loop-universe-iteration-keywords *loop-universe*)))) - ;; The latest ANSI clarification is that the FOR/AS after the AND must - ;; NOT be supplied. - (loop-pop-source) - (setq entry tem))))) + (setq *loop-before-loop* + (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*)) + (setq *loop-after-body* + (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source)))) ; Flush the "AND". ;;;; main iteration drivers ;;; FOR variable keyword ..args.. (defun loop-do-for () (let* ((var (loop-pop-source)) - (data-type (loop-optional-type var)) - (keyword (loop-pop-source)) - (first-arg nil) - (tem nil)) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) (setq first-arg (loop-get-form)) (unless (and (symbolp keyword) - (setq tem (loop-lookup-keyword - keyword - (loop-universe-for-keywords *loop-universe*)))) + (setq tem (loop-lookup-keyword + keyword + (loop-universe-for-keywords *loop-universe*)))) (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." - keyword)) + 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* - (loop-make-var (gensym "LOOP-IT-") nil nil)))) + (loop-make-var (gensym "LOOP-IT-") nil nil)))) ;;;; various FOR/AS subdispatches @@ -1379,46 +1225,46 @@ code to be loaded. ;;; is present. I.e., the first initialization occurs in the loop body ;;; (first-step), not in the variable binding phase. (defun loop-ansi-for-equals (var val data-type) - (loop-make-iteration-var var nil data-type) + (loop-make-var var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) - ;; Then we are the same as "FOR x FIRST y THEN z". - (loop-pop-source) - `(() (,var ,(loop-get-form)) () () - () (,var ,val) () ())) - (t ;; We are the same as "FOR x = y". - `(() (,var ,val) () ())))) + ;; Then we are the same as "FOR x FIRST y THEN z". + (loop-pop-source) + `(() (,var ,(loop-get-form)) () () + () (,var ,val) () ())) + (t ;; We are the same as "FOR x = y". + `(() (,var ,val) () ())))) (defun loop-for-across (var val data-type) - (loop-make-iteration-var var nil data-type) + (loop-make-var var nil data-type) (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-")) - (index-var (gensym "LOOP-ACROSS-INDEX-"))) + (index-var (gensym "LOOP-ACROSS-INDEX-"))) (multiple-value-bind (vector-form constantp vector-value) - (loop-constant-fold-if-possible val 'vector) + (loop-constant-fold-if-possible val 'vector) (loop-make-var - vector-var vector-form - (if (and (consp vector-form) (eq (car vector-form) 'the)) - (cadr vector-form) - 'vector)) + vector-var vector-form + (if (and (consp vector-form) (eq (car vector-form) 'the)) + (cadr vector-form) + 'vector)) (loop-make-var index-var 0 'fixnum) (let* ((length 0) - (length-form (cond ((not constantp) - (let ((v (gensym "LOOP-ACROSS-LIMIT-"))) - (push `(setq ,v (length ,vector-var)) - *loop-prologue*) - (loop-make-var v 0 'fixnum))) - (t (setq length (length vector-value))))) - (first-test `(>= ,index-var ,length-form)) - (other-test first-test) - (step `(,var (aref ,vector-var ,index-var))) - (pstep `(,index-var (1+ ,index-var)))) - (declare (fixnum length)) - (when constantp - (setq first-test (= length 0)) - (when (<= length 1) - (setq other-test t))) - `(,other-test ,step () ,pstep - ,@(and (not (eq first-test other-test)) - `(,first-test ,step () ,pstep))))))) + (length-form (cond ((not constantp) + (let ((v (gensym "LOOP-ACROSS-LIMIT-"))) + (push `(setq ,v (length ,vector-var)) + *loop-prologue*) + (loop-make-var v 0 'fixnum))) + (t (setq length (length vector-value))))) + (first-test `(>= ,index-var ,length-form)) + (other-test first-test) + (step `(,var (aref ,vector-var ,index-var))) + (pstep `(,index-var (1+ ,index-var)))) + (declare (fixnum length)) + (when constantp + (setq first-test (= length 0)) + (when (<= length 1) + (setq other-test t))) + `(,other-test ,step () ,pstep + ,@(and (not (eq first-test other-test)) + `(,first-test ,step () ,pstep))))))) ;;;; list iteration @@ -1431,68 +1277,69 @@ code to be loaded. ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP ;; optimizations. (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) - (loop-pop-source) - (loop-get-form)) - (t '(function cdr))))) + (loop-pop-source) + (loop-get-form)) + (t '(function cdr))))) (cond ((and (consp stepper) (eq (car stepper) 'quote)) - (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") - `(funcall ,stepper ,listvar)) - ((and (consp stepper) (eq (car stepper) 'function)) - (list (cadr stepper) listvar)) - (t - `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) - ,listvar))))) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + `(funcall ,stepper ,listvar)) + ((and (consp stepper) (eq (car stepper) 'function)) + (list (cadr stepper) listvar)) + (t + `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) + ,listvar))))) (defun loop-for-on (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) - (loop-make-iteration-var var list data-type)) - (t (loop-make-var (setq listvar (gensym)) list 'list) - (loop-make-iteration-var var nil data-type))) + (loop-make-var var list data-type)) + (t + (loop-make-var (setq listvar (gensym)) list 't) + (loop-make-var var nil data-type))) (let ((list-step (loop-list-step listvar))) - (let* ((first-endtest - ;; mysterious comment from original CMU CL sources: - ;; the following should use `atom' instead of `endp', - ;; per [bug2428] - `(atom ,listvar)) - (other-endtest first-endtest)) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - (cond ((eq var listvar) - ;; The contour of the loop is different because we - ;; use the user's variable... - `(() (,listvar ,list-step) - ,other-endtest () () () ,first-endtest ())) - (t (let ((step `(,var ,listvar)) - (pseudo `(,listvar ,list-step))) - `(,other-endtest ,step () ,pseudo - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo))))))))))) + (let* ((first-endtest + ;; mysterious comment from original CMU CL sources: + ;; the following should use `atom' instead of `endp', + ;; per [bug2428] + `(atom ,listvar)) + (other-endtest first-endtest)) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + (cond ((eq var listvar) + ;; The contour of the loop is different because we + ;; use the user's variable... + `(() (,listvar ,list-step) + ,other-endtest () () () ,first-endtest ())) + (t (let ((step `(,var ,listvar)) + (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) (defun loop-for-in (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar (gensym "LOOP-LIST-"))) - (loop-make-iteration-var var nil data-type) + (loop-make-var var nil data-type) (loop-make-var listvar list 'list) (let ((list-step (loop-list-step listvar))) - (let* ((first-endtest `(endp ,listvar)) - (other-endtest first-endtest) - (step `(,var (car ,listvar))) - (pseudo-step `(,listvar ,list-step))) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - `(,other-endtest ,step () ,pseudo-step - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo-step)))))))) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) ;;;; iteration paths (defstruct (loop-path - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) names preposition-groups inclusive-permitted @@ -1500,19 +1347,19 @@ code to be loaded. user-data) (defun add-loop-path (names function universe - &key preposition-groups inclusive-permitted user-data) + &key preposition-groups inclusive-permitted user-data) (declare (type loop-universe universe)) (unless (listp names) (setq names (list names))) (let ((ht (loop-universe-path-keywords universe)) - (lp (make-loop-path - :names (mapcar #'symbol-name names) - :function function - :user-data user-data - :preposition-groups (mapcar (lambda (x) - (if (listp x) x (list x))) - preposition-groups) - :inclusive-permitted inclusive-permitted))) + (lp (make-loop-path + :names (mapcar #'symbol-name names) + :function function + :user-data user-data + :preposition-groups (mapcar (lambda (x) + (if (listp x) x (list x))) + preposition-groups) + :inclusive-permitted inclusive-permitted))) (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) lp)) @@ -1523,51 +1370,51 @@ code to be loaded. ;; FOR var BEING each/the pathname prep-phrases using-stuff... each/the = ;; EACH or THE. Not clear if it is optional, so I guess we'll warn. (let ((path nil) - (data nil) - (inclusive nil) - (stuff nil) - (initial-prepositions nil)) + (data nil) + (inclusive nil) + (stuff nil) + (initial-prepositions nil)) (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) - ((loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (setq inclusive t) - (unless (loop-tmember (car *loop-source-code*) - '(:its :each :his :her)) - (loop-error "~S was found where ITS or EACH expected in LOOP iteration path syntax." - (car *loop-source-code*))) - (loop-pop-source) - (setq path (loop-pop-source)) - (setq initial-prepositions `((:in ,val)))) - (t (loop-error "unrecognizable LOOP iteration path syntax: missing EACH or THE?"))) + ((loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (setq inclusive t) + (unless (loop-tmember (car *loop-source-code*) + '(:its :each :his :her)) + (loop-error "~S was found where ITS or EACH expected in LOOP iteration path syntax." + (car *loop-source-code*))) + (loop-pop-source) + (setq path (loop-pop-source)) + (setq initial-prepositions `((:in ,val)))) + (t (loop-error "unrecognizable LOOP iteration path syntax: missing EACH or THE?"))) (cond ((not (symbolp path)) - (loop-error - "~S was found where a LOOP iteration path name was expected." - path)) - ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) - (loop-error "~S is not the name of a LOOP iteration path." path)) - ((and inclusive (not (loop-path-inclusive-permitted data))) - (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) + (loop-error + "~S was found where a LOOP iteration path name was expected." + path)) + ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) + (loop-error "~S is not the name of a LOOP iteration path." path)) + ((and inclusive (not (loop-path-inclusive-permitted data))) + (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) (let ((fun (loop-path-function data)) - (preps (nconc initial-prepositions - (loop-collect-prepositional-phrases - (loop-path-preposition-groups data) - t))) - (user-data (loop-path-user-data data))) + (preps (nconc initial-prepositions + (loop-collect-prepositional-phrases + (loop-path-preposition-groups data) + t))) + (user-data (loop-path-user-data data))) (when (symbolp fun) (setq fun (symbol-function fun))) (setq stuff (if inclusive - (apply fun var data-type preps :inclusive t user-data) - (apply fun var data-type preps user-data)))) + (apply fun var data-type preps :inclusive t user-data) + (apply fun var data-type preps user-data)))) (when *loop-named-vars* (loop-error "Unused USING vars: ~S." *loop-named-vars*)) ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). ;; Protect the system from the user and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." - path)) + path)) (do ((l (car stuff) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) - (loop-make-iteration-var x nil nil) - (loop-make-iteration-var (car x) (cadr x) (caddr x)))) + (loop-make-var x nil nil) + (loop-make-var (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) @@ -1575,199 +1422,232 @@ code to be loaded. (let ((tem (loop-tassoc name *loop-named-vars*))) (declare (list tem)) (cond ((null tem) (values (gensym) nil)) - (t (setq *loop-named-vars* (delete tem *loop-named-vars*)) - (values (cdr tem) t))))) + (t (setq *loop-named-vars* (delete tem *loop-named-vars*)) + (values (cdr tem) t))))) (defun loop-collect-prepositional-phrases (preposition-groups - &optional - using-allowed - initial-phrases) + &optional + using-allowed + initial-phrases) (flet ((in-group-p (x group) (car (loop-tmember x group)))) (do ((token nil) - (prepositional-phrases initial-phrases) - (this-group nil nil) - (this-prep nil nil) - (disallowed-prepositions - (mapcan (lambda (x) - (copy-list - (find (car x) preposition-groups :test #'in-group-p))) - initial-phrases)) - (used-prepositions (mapcar #'car initial-phrases))) - ((null *loop-source-code*) (nreverse prepositional-phrases)) + (prepositional-phrases initial-phrases) + (this-group nil nil) + (this-prep nil nil) + (disallowed-prepositions + (mapcan (lambda (x) + (copy-list + (find (car x) preposition-groups :test #'in-group-p))) + initial-phrases)) + (used-prepositions (mapcar #'car initial-phrases))) + ((null *loop-source-code*) (nreverse prepositional-phrases)) (declare (symbol this-prep)) (setq token (car *loop-source-code*)) (dolist (group preposition-groups) - (when (setq this-prep (in-group-p token group)) - (return (setq this-group group)))) + (when (setq this-prep (in-group-p token group)) + (return (setq this-group group)))) (cond (this-group - (when (member this-prep disallowed-prepositions) - (loop-error - (if (member this-prep used-prepositions) - "A ~S prepositional phrase occurs multiply for some LOOP clause." - "Preposition ~S was used when some other preposition has subsumed it.") - token)) - (setq used-prepositions (if (listp this-group) - (append this-group used-prepositions) - (cons this-group used-prepositions))) - (loop-pop-source) - (push (list this-prep (loop-get-form)) prepositional-phrases)) - ((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 - "The variable substitution for ~S occurs twice in a USING phrase,~@ - with ~S and ~S." - (car z) (cadr z) (cadr tem)) - (push (cons (car z) (cadr z)) *loop-named-vars*))) - (when (or (null *loop-source-code*) - (symbolp (car *loop-source-code*))) - (return nil)))) - (t (return (nreverse prepositional-phrases))))))) + (when (member this-prep disallowed-prepositions) + (loop-error + (if (member this-prep used-prepositions) + "A ~S prepositional phrase occurs multiply for some LOOP clause." + "Preposition ~S was used when some other preposition has subsumed it.") + token)) + (setq used-prepositions (if (listp this-group) + (append this-group used-prepositions) + (cons this-group used-prepositions))) + (loop-pop-source) + (push (list this-prep (loop-get-form)) prepositional-phrases)) + ((and using-allowed (loop-tequal token 'using)) + (loop-pop-source) + (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) + (when (cadr z) + (if (setq tem (loop-tassoc (car z) *loop-named-vars*)) + (loop-error + "The variable substitution for ~S occurs twice in a USING phrase,~@ + with ~S and ~S." + (car z) (cadr z) (cadr tem)) + (push (cons (car z) (cadr z)) *loop-named-vars*))) + (when (or (null *loop-source-code*) + (symbolp (car *loop-source-code*))) + (return nil)))) + (t (return (nreverse prepositional-phrases))))))) ;;;; master sequencer function -(defun loop-sequencer (indexv indexv-type - variable variable-type - sequence-variable sequence-type - step-hack default-top - prep-phrases) +(defun loop-sequencer (indexv indexv-type + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) (let ((endform nil) ; form (constant or variable) with limit value - (sequencep nil) ; T if sequence arg has been provided - (testfn nil) ; endtest function - (test nil) ; endtest form - (stepby (1+ (or (loop-typed-init indexv-type) 0))) ; our increment - (stepby-constantp t) - (step nil) ; step form - (dir nil) ; direction of stepping: NIL, :UP, :DOWN - (inclusive-iteration nil) ; T if include last index - (start-given nil) ; T when prep phrase has specified start - (start-value nil) - (start-constantp nil) - (limit-given nil) ; T when prep phrase has specified end - (limit-constantp nil) - (limit-value nil) - ) - (when variable (loop-make-iteration-var variable nil variable-type)) - (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) - (setq prep (caar l) form (cadar l)) - (case prep - ((:of :in) - (setq sequencep t) - (loop-make-var sequence-variable form sequence-type)) - ((:from :downfrom :upfrom) - (setq start-given t) - (cond ((eq prep :downfrom) (setq dir ':down)) - ((eq prep :upfrom) (setq dir ':up))) - (multiple-value-setq (form start-constantp start-value) - (loop-constant-fold-if-possible form indexv-type)) - (loop-make-iteration-var indexv form indexv-type)) - ((:upto :to :downto :above :below) - (cond ((loop-tequal prep :upto) (setq inclusive-iteration - (setq dir ':up))) - ((loop-tequal prep :to) (setq inclusive-iteration t)) - ((loop-tequal prep :downto) (setq inclusive-iteration - (setq dir ':down))) - ((loop-tequal prep :above) (setq dir ':down)) - ((loop-tequal prep :below) (setq dir ':up))) - (setq limit-given t) - (multiple-value-setq (form limit-constantp limit-value) - (loop-constant-fold-if-possible form indexv-type)) - (setq endform (if limit-constantp - `',limit-value - (loop-make-var - (gensym "LOOP-LIMIT-") form indexv-type)))) - (:by - (multiple-value-setq (form stepby-constantp stepby) - (loop-constant-fold-if-possible form indexv-type)) - (unless stepby-constantp - (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) - form - indexv-type))) - (t (loop-error - "~S invalid preposition in sequencing or sequence path;~@ - maybe invalid prepositions were specified in iteration path descriptor?" - prep))) - (when (and odir dir (not (eq dir odir))) - (loop-error "conflicting stepping directions in LOOP sequencing path")) - (setq odir dir)) - (when (and sequence-variable (not sequencep)) - (loop-error "missing OF or IN phrase in sequence path")) - ;; Now fill in the defaults. - (unless start-given - (loop-make-iteration-var - indexv - (setq start-constantp t - start-value (or (loop-typed-init indexv-type) 0)) - indexv-type)) - (cond ((member dir '(nil :up)) - (when (or limit-given default-top) - (unless limit-given - (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-")) - nil - indexv-type) - (push `(setq ,endform ,default-top) *loop-prologue*)) - (setq testfn (if inclusive-iteration '> '>=))) - (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) - (t (unless start-given - (unless default-top - (loop-error "don't know where to start stepping")) - (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) - (when (and default-top (not endform)) - (setq endform (loop-typed-init indexv-type) - inclusive-iteration t)) - (when endform (setq testfn (if inclusive-iteration '< '<=))) - (setq step - (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) - (when testfn - (setq test - `(,testfn ,indexv ,endform))) - (when step-hack - (setq step-hack - `(,variable ,step-hack))) - (let ((first-test test) (remaining-tests test)) - (when (and stepby-constantp start-constantp limit-constantp) - (when (setq first-test - (funcall (symbol-function testfn) - start-value - limit-value)) - (setq remaining-tests t))) - `(() (,indexv ,step) - ,remaining-tests ,step-hack () () ,first-test ,step-hack)))) + (sequencep nil) ; T if sequence arg has been provided + (testfn nil) ; endtest function + (test nil) ; endtest form + (stepby (1+ (or (loop-typed-init indexv-type) 0))) ; our increment + (stepby-constantp t) + (step nil) ; step form + (dir nil) ; direction of stepping: NIL, :UP, :DOWN + (inclusive-iteration nil) ; T if include last index + (start-given nil) ; T when prep phrase has specified start + (start-value nil) + (start-constantp nil) + (limit-given nil) ; T when prep phrase has specified end + (limit-constantp nil) + (limit-value nil) + ) + (flet ((assert-index-for-arithmetic (index) + (unless (atom index) + (loop-error "Arithmetic index must be an atom.")))) + (when variable (loop-make-var variable nil variable-type)) + (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) + (setq prep (caar l) form (cadar l)) + (case prep + ((:of :in) + (setq sequencep t) + (loop-make-var sequence-variable form sequence-type)) + ((:from :downfrom :upfrom) + (setq start-given t) + (cond ((eq prep :downfrom) (setq dir ':down)) + ((eq prep :upfrom) (setq dir ':up))) + (multiple-value-setq (form start-constantp start-value) + (loop-constant-fold-if-possible form indexv-type)) + (assert-index-for-arithmetic indexv) + ;; KLUDGE: loop-make-var generates a temporary symbol for + ;; indexv if it is NIL. We have to use it to have the index + ;; actually count + (setq indexv (loop-make-var indexv form indexv-type))) + ((:upto :to :downto :above :below) + (cond ((loop-tequal prep :upto) (setq inclusive-iteration + (setq dir ':up))) + ((loop-tequal prep :to) (setq inclusive-iteration t)) + ((loop-tequal prep :downto) (setq inclusive-iteration + (setq dir ':down))) + ((loop-tequal prep :above) (setq dir ':down)) + ((loop-tequal prep :below) (setq dir ':up))) + (setq limit-given t) + (multiple-value-setq (form limit-constantp limit-value) + (loop-constant-fold-if-possible form `(and ,indexv-type real))) + (setq endform (if limit-constantp + `',limit-value + (loop-make-var + (gensym "LOOP-LIMIT-") form + `(and ,indexv-type real))))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form + `(and ,indexv-type (real (0))))) + (unless stepby-constantp + (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) + form + `(and ,indexv-type (real (0))) + t))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path;~@ + maybe invalid prepositions were specified in iteration path descriptor?" + prep))) + (when (and odir dir (not (eq dir odir))) + (loop-error + "conflicting stepping directions in LOOP sequencing path")) + (setq odir dir)) + (when (and sequence-variable (not sequencep)) + (loop-error "missing OF or IN phrase in sequence path")) + ;; Now fill in the defaults. + (if start-given + (when limit-given + ;; if both start and limit are given, they had better both + ;; be REAL. We already enforce the REALness of LIMIT, + ;; above; here's the KLUDGE to enforce the type of START. + (flet ((type-declaration-of (x) + (and (eq (car x) 'type) (caddr x)))) + (let ((decl (find indexv *loop-declarations* + :key #'type-declaration-of)) + (%decl (find indexv *loop-declarations* + :key #'type-declaration-of + :from-end t))) + (sb!int:aver (eq decl %decl)) + (when decl + (setf (cadr decl) + `(and real ,(cadr decl))))))) + ;; default start + ;; DUPLICATE KLUDGE: loop-make-var generates a temporary + ;; symbol for indexv if it is NIL. See also the comment in + ;; the (:from :downfrom :upfrom) case + (progn + (assert-index-for-arithmetic indexv) + (setq indexv + (loop-make-var + indexv + (setq start-constantp t + start-value (or (loop-typed-init indexv-type) 0)) + `(and ,indexv-type real))))) + (cond ((member dir '(nil :up)) + (when (or limit-given default-top) + (unless limit-given + (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-")) + nil + indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "don't know where to start stepping")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) + inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step + (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when testfn + (setq test + `(,testfn ,indexv ,endform))) + (when step-hack + (setq step-hack + `(,variable ,step-hack))) + (let ((first-test test) (remaining-tests test)) + ;; As far as I can tell, the effect of the following code is + ;; to detect cases where we know statically whether the first + ;; iteration of the loop will be executed. Depending on the + ;; situation, we can either: + ;; a) save one jump and one comparison per loop (not per iteration) + ;; when it will get executed + ;; b) remove the loop body completely when it won't be executed + ;; + ;; Noble goals. However, the code generated in case a) will + ;; fool the loop induction variable detection, and cause + ;; code like (LOOP FOR I TO 10 ...) to use generic addition + ;; (bug #278a). + ;; + ;; Since the gain in case a) is rather minimal and Python is + ;; generally smart enough to handle b) without any extra + ;; support from the loop macro, I've disabled this code for + ;; now. The code and the comment left here in case somebody + ;; extends the induction variable bound detection to work + ;; with code where the stepping precedes the test. + ;; -- JES 2005-11-30 + #+nil + (when (and stepby-constantp start-constantp limit-constantp + (realp start-value) (realp limit-value)) + (when (setq first-test + (funcall (symbol-function testfn) + start-value + limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,step) + ,remaining-tests ,step-hack () () ,first-test ,step-hack))))) ;;;; interfaces to the master sequencer (defun loop-for-arithmetic (var val data-type kwd) (loop-sequencer - var (loop-check-data-type data-type 'real) + var (loop-check-data-type data-type 'number) nil nil nil nil nil nil (loop-collect-prepositional-phrases '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) nil (list (list kwd val))))) -(defun loop-sequence-elements-path (variable data-type prep-phrases - &key - fetch-function - size-function - sequence-type - element-type) - (multiple-value-bind (indexv) (loop-named-var 'index) - (let ((sequencev (named-var 'sequence))) - (list* nil nil ; dummy bindings and prologue - (loop-sequencer - indexv 'fixnum - variable (or data-type element-type) - sequencev sequence-type - `(,fetch-function ,sequencev ,indexv) - `(,size-function ,sequencev) - prep-phrases))))) ;;;; builtin LOOP iteration paths @@ -1779,177 +1659,179 @@ 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!")) - ((null prep-phrases) - (loop-error "missing OF or IN in ~S iteration path"))) + (loop-error "too many prepositions!")) + ((null prep-phrases) + (loop-error "missing OF or IN in ~S iteration path"))) (let ((ht-var (gensym "LOOP-HASHTAB-")) - (next-fn (gensym "LOOP-HASHTAB-NEXT-")) - (dummy-predicate-var nil) - (post-steps nil)) + (next-fn (gensym "LOOP-HASHTAB-NEXT-")) + (dummy-predicate-var nil) + (post-steps nil)) (multiple-value-bind (other-var other-p) - (loop-named-var (ecase which - (:hash-key 'hash-value) - (:hash-value 'hash-key))) + (loop-named-var (ecase which + (:hash-key 'hash-value) + (:hash-value 'hash-key))) ;; @@@@ LOOP-NAMED-VAR returns a second value of T if the name ;; was actually specified, so clever code can throw away the ;; GENSYM'ed-up variable if it isn't really needed. The ;; following is for those implementations in which we cannot put ;; 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)))))) - (ecase which - (:hash-key (setq key-var variable - val-var (and other-p other-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 - (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) - (,next-fn))) ;post-test - ,post-steps))))) + dummy-predicate-var (loop-when-it-var)) + (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))) + (: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 (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 + ,post-steps))))) (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)))) - (loop-error "Too many prepositions!")) - ((null prep-phrases) - (loop-error "missing OF or IN in ~S iteration path"))) + &key symbol-types) + (cond ((and prep-phrases (cdr prep-phrases)) + (loop-error "Too many prepositions!")) + ((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))) + *loop-wrappers*) + `(((,variable nil ,data-type) (,pkg-var ,package)) () () () (not (multiple-value-setq (,(loop-when-it-var) - ,variable) - (,next-fn))) + ,variable) + (,next-fn))) ()))) ;;;; ANSI LOOP -(defun make-ansi-loop-universe (extended-p) +(defun make-ansi-loop-universe () (let ((w (make-standard-loop-universe - :keywords '((named (loop-do-named)) - (initially (loop-do-initially)) - (finally (loop-do-finally)) - (do (loop-do-do)) - (doing (loop-do-do)) - (return (loop-do-return)) - (collect (loop-list-collection list)) - (collecting (loop-list-collection list)) - (append (loop-list-collection append)) - (appending (loop-list-collection append)) - (nconc (loop-list-collection nconc)) - (nconcing (loop-list-collection nconc)) - (count (loop-sum-collection count - real - fixnum)) - (counting (loop-sum-collection count - real - fixnum)) - (sum (loop-sum-collection sum number number)) - (summing (loop-sum-collection sum number number)) - (maximize (loop-maxmin-collection max)) - (minimize (loop-maxmin-collection min)) - (maximizing (loop-maxmin-collection max)) - (minimizing (loop-maxmin-collection min)) - (always (loop-do-always t nil)) ; Normal, do always - (never (loop-do-always t t)) ; Negate test on always. - (thereis (loop-do-thereis t)) - (while (loop-do-while nil :while)) ; Normal, do while - (until (loop-do-while t :until)) ;Negate test on while - (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))) - :for-keywords '((= (loop-ansi-for-equals)) - (across (loop-for-across)) - (in (loop-for-in)) - (on (loop-for-on)) - (from (loop-for-arithmetic :from)) - (downfrom (loop-for-arithmetic :downfrom)) - (upfrom (loop-for-arithmetic :upfrom)) - (below (loop-for-arithmetic :below)) + :keywords '((named (loop-do-named)) + (initially (loop-do-initially)) + (finally (loop-do-finally)) + (do (loop-do-do)) + (doing (loop-do-do)) + (return (loop-do-return)) + (collect (loop-list-collection list)) + (collecting (loop-list-collection list)) + (append (loop-list-collection append)) + (appending (loop-list-collection append)) + (nconc (loop-list-collection nconc)) + (nconcing (loop-list-collection nconc)) + (count (loop-sum-collection count + real + fixnum)) + (counting (loop-sum-collection count + real + fixnum)) + (sum (loop-sum-collection sum number number)) + (summing (loop-sum-collection sum number number)) + (maximize (loop-maxmin-collection max)) + (minimize (loop-maxmin-collection min)) + (maximizing (loop-maxmin-collection max)) + (minimizing (loop-maxmin-collection min)) + (always (loop-do-always t nil)) ; Normal, do always + (never (loop-do-always t t)) ; Negate test on always. + (thereis (loop-do-thereis t)) + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ;Negate test on while + (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)) + (repeat (loop-do-repeat))) + :for-keywords '((= (loop-ansi-for-equals)) + (across (loop-for-across)) + (in (loop-for-in)) + (on (loop-for-on)) + (from (loop-for-arithmetic :from)) + (downfrom (loop-for-arithmetic :downfrom)) + (upfrom (loop-for-arithmetic :upfrom)) + (below (loop-for-arithmetic :below)) (above (loop-for-arithmetic :above)) - (to (loop-for-arithmetic :to)) - (upto (loop-for-arithmetic :upto)) - (downto (loop-for-arithmetic :downto)) - (by (loop-for-arithmetic :by)) - (being (loop-for-being))) - :iteration-keywords '((for (loop-do-for)) - (as (loop-do-for)) - (repeat (loop-do-repeat))) - :type-symbols '(array atom bignum bit bit-vector character - compiled-function complex cons double-float - fixnum float function hash-table integer - keyword list long-float nil null number - package pathname random-state ratio rational - readtable sequence short-float simple-array - simple-bit-vector simple-string simple-vector - single-float standard-char stream string - base-char symbol t vector) - :type-keywords nil - :ansi (if extended-p :extended t)))) + (to (loop-for-arithmetic :to)) + (upto (loop-for-arithmetic :upto)) + (downto (loop-for-arithmetic :downto)) + (by (loop-for-arithmetic :by)) + (being (loop-for-being))) + :iteration-keywords '((for (loop-do-for)) + (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 + keyword list long-float nil null number + package pathname random-state ratio rational + readtable sequence short-float simple-array + simple-bit-vector simple-string simple-vector + single-float standard-char stream string + base-char symbol t vector) + :type-keywords nil))) (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:which :hash-key)) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which :hash-key)) (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:which :hash-value)) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which :hash-value)) (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:internal - :external - :inherited))) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal + :external + :inherited))) (add-loop-path '(external-symbol external-symbols) - 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:external))) + 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:external))) (add-loop-path '(present-symbol present-symbols) - 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:internal - :external))) + 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal + :external))) w)) (defparameter *loop-ansi-universe* - (make-ansi-loop-universe nil)) + (make-ansi-loop-universe)) (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*))