1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; FIXME: It'd be nice to get rid of all 750 lines of code in this
5 ;;;; file, plus miscellaneous cruft elsewhere (e.g. the definition of
6 ;;;; the SB-ITERATE package). There are only 20 calls to this ITERATE
7 ;;;; macro in the PCL code. (There's another ITERATE macro used in the
8 ;;;; classic CMU CL code, but that's different.) Most if not all of
9 ;;;; them would be easy to replace with ANSI LOOP or simpler standard
10 ;;;; iteration constructs.
12 ;;;; This software is derived from software originally released by Xerox
13 ;;;; Corporation. Copyright and release statements follow. Later modifications
14 ;;;; to the software are in the public domain and are provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
18 ;;;; copyright information from original PCL sources:
20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
21 ;;;; All rights reserved.
23 ;;;; Use and copying of this software and preparation of derivative works based
24 ;;;; upon this software are permitted. Any distribution of this software or
25 ;;;; derivative works must comply with all applicable United States export
28 ;;;; This software is made available AS IS, and Xerox Corporation makes no
29 ;;;; warranty about the software, its performance or its conformity to any
32 (in-package "SB-ITERATE")
34 ;;; Are warnings to be issued for iterate/gather forms that aren't
37 ;;; :USER => those resulting from user code
38 ;;; T => always, even if it's the iteration macro that's suboptimal.
39 (defvar *iterate-warnings* :any)
42 (defmacro iterate (clauses &body body &environment env)
43 (optimize-iterate-form clauses body env))
45 ;;; temporary variable names used by ITERATE expansions
46 (defparameter *iterate-temp-vars-list*
47 '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4
48 iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8))
52 (clauses body iterate-env)
54 ((temp-vars *iterate-temp-vars-list*)
56 (finish-form `(return-from ,block-name))
57 (bound-vars (mapcan #'(lambda (clause)
58 (let ((names (first clause)))
63 iterate-decls generator-decls update-forms bindings leftover-body)
64 (do ((tail bound-vars (cdr tail)))
66 ;; Check for duplicates
67 (when (member (car tail)
69 (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
71 ((get-iterate-temp nil
73 ;; Make temporary var. Note that it is ok to re-use these symbols
74 ;; in each iterate, because they are not used within BODY.
77 (dolist (clause clauses)
79 ((or (not (consp clause))
80 (not (consp (cdr clause))))
81 (warn "bad syntax in ITERATE: clause not of form (var iterator): ~S"
84 (unless (null (cddr clause))
86 "probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
89 (let-body binding-type let-bindings localdecls otherdecls extra-body)
90 (expand-into-let (second clause)
93 ;; We have expanded the generator clause and parsed it into
96 ((vars (first clause))
97 gen-args renamed-vars)
98 (setq vars (if (listp vars)
101 ; VARS is now a (fresh) list of
102 ; all iteration vars bound in
105 ((eq let-body :abort)
106 ; Already issued a warning
107 ; about malformedness
109 ((null (setq let-body (function-lambda-p let-body 1)))
110 ; Not of the expected form
111 (let ((generator (second clause)))
112 (cond ((and (consp generator)
113 (fboundp (car generator)))
114 ; It looks ok--a macro or
115 ; function here--so the guy who
116 ; wrote it just didn't do it in
118 (maybe-warn :definition "could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
120 (t ; Perhaps it's just a
121 ; misspelling? Probably user
124 "Iterate operator in clause ~S is not fboundp."
126 (setq let-body :abort)))
129 ;; We have something of the form #'(LAMBDA (finisharg) ...),
130 ;; possibly with some LET bindings around it. LET-BODY =
131 ;; ((finisharg) ...).
132 (setq let-body (cdr let-body))
133 (setq gen-args (pop let-body))
136 ;; The first transformation we want to perform is
137 ;; "LET-eversion": turn (let* ((generator (let (..bindings..)
138 ;; #'(lambda ...)))) ..body..) into (let* (..bindings..
139 ;; (generator #'(lambda ...))) ..body..). This
140 ;; transformation is valid if nothing in body refers to any
141 ;; of the bindings, something we can ensure by
142 ;; alpha-converting the inner let (substituting new names for
143 ;; each var). Of course, none of those vars can be special,
144 ;; but we already checked for that above.
145 (multiple-value-setq (let-bindings renamed-vars)
146 (rename-let-bindings let-bindings binding-type
147 iterate-env leftover-body #'get-iterate-temp))
148 (setq leftover-body nil)
149 ; If there was any leftover
150 ; from previous, it is now
154 ;; The second transformation is substituting the body of the
155 ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance
156 ;; in the update form (funcall generator #'(lambda ()
157 ;; finish-form)), then simplifying that form. The requirement
158 ;; for this part is that the generator body not refer to any
159 ;; variables that are bound between the generator binding and the
160 ;; appearance in the loop body. The only variables bound in that
161 ;; interval are generator temporaries, which have unique names so
162 ;; are no problem, and the iteration variables remaining for
163 ;; subsequent clauses. We'll discover the story as we walk the
165 (multiple-value-bind (finishdecl other rest)
166 (parse-declarations let-body gen-args)
167 (declare (ignore finishdecl))
168 ; Pull out declares, if any,
169 ; separating out the one(s)
170 ; referring to the finish arg,
171 ; which we will throw away.
173 ; Combine remaining decls with
174 ; decls extracted from the LET,
176 (setq otherdecls (nconc otherdecls other)))
179 ; There are interesting
180 ; declarations, so have to keep
182 `(let nil (declare ,@otherdecls)
187 (t `(progn ,@rest)))))
188 (unless (eq (setq let-body (iterate-transform-body let-body
189 iterate-env renamed-vars
191 finish-form bound-vars clause))
194 ;; Skip the rest if transformation failed. Warning has
195 ;; already been issued.
197 ;; Note possible further optimization: if LET-BODY expanded
198 ;; into (prog1 oldvalue prepare-for-next-iteration), as so
199 ;; many do, then we could in most cases split the PROG1 into
200 ;; two pieces: do the (setq var oldvalue) here, and do the
201 ;; prepare-for-next-iteration at the bottom of the loop.
202 ;; This does a slight optimization of the PROG1 and also
203 ;; rearranges the code in a way that a reasonably clever
204 ;; compiler might detect how to get rid of redundant
205 ;; variables altogether (such as happens with INTERVAL and
206 ;; LIST-TAILS); that would make the whole thing closer to
207 ;; what you might have coded by hand. However, to do this
208 ;; optimization, we need to ensure that (a) the
209 ;; prepare-for-next-iteration refers freely to no vars other
210 ;; than the internal vars we have extracted from the LET, and
211 ;; (b) that the code has no side effects. These are both
212 ;; true for all the iterators defined by this module, but how
213 ;; shall we represent side-effect info and/or tap into the
214 ;; compiler's knowledge of same?
216 ; There were declarations for
217 ; the generator locals--have to
218 ; keep them for later, and
219 ; rename the vars mentioned
227 (let ((head (car decl)))
228 (cons head (if (eq head 'type)
236 ;; Finished analyzing clause now. LET-BODY is the form which, when
237 ;; evaluated, returns updated values for the iteration variable(s)
239 (when (eq let-body :abort)
241 ;; Some punt case: go with the formal semantics: bind a var to
242 ;; the generator, then call it in the update section
244 ((gvar (get-iterate-temp))
245 (generator (second clause)))
250 ;; FIXME: This conditional was here with this
251 ;; comment in old CMU CL PCL. Does Python really
252 ;; think it's unreachable?
253 ;;#-cmu ; Python thinks this is unreachable.
255 ; Have to use this up
256 `(progn ,@(prog1 leftover-body (setq
261 (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form)))))
262 (push (mv-setq (copy-list vars)
267 ;; Pop off the vars we have now bound from the list of vars to
268 ;; watch out for -- we'll bind them right now.
271 (nconc bindings let-bindings
273 ;; There was some computation to do after the
274 ;; bindings--here's our chance.
275 (cons (list (first vars)
276 `(progn ,@extra-body nil))
279 (do ((tail body (cdr tail)))
280 ((not (and (consp tail)
285 ;; TAIL now points at first non-declaration. If there were
286 ;; declarations, pop them off so they appear in the right place
287 (unless (eq tail body)
288 (setq iterate-decls (ldiff body tail))
291 (let* ,bindings ,@(and generator-decls
292 `((declare ,@generator-decls)))
295 (loop ,@(nreverse update-forms)
298 (defun expand-into-let (clause parent-name env)
300 ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra
301 ;; body, where BODY is a single form. If multiple forms in a LET, the
302 ;; preceding forms are returned as extra body. Returns :ABORT if it
303 ;; issued a punt warning.
304 (prog ((expansion clause)
305 expandedp binding-type let-bindings let-body)
307 (multiple-value-setq (expansion expandedp)
308 (macroexpand-1 expansion env))
309 (cond ((not (consp expansion))
312 ((symbolp (setq binding-type (first expansion)))
315 (setq let-bindings (second expansion))
316 ; List of variable bindings
317 (setq let-body (cddr expansion))
319 ((and (consp binding-type)
320 (eq (car binding-type)
322 (not (find-if #'(lambda (x)
323 (member x lambda-list-keywords)
325 (setq let-bindings (second binding-type)))
327 (eql (length (second expansion))
328 (length let-bindings))
329 (null (cddr expansion)))
330 ; A simple LAMBDA form can be
332 (setq let-body (cddr binding-type))
333 (setq let-bindings (mapcar #'list let-bindings (second
336 (setq binding-type 'let)
339 ;; Fall thru if not a LET
340 (cond (expandedp ; try expanding again
342 (t ; Boring--return form as the
346 (return (let ((locals (variables-from-let let-bindings))
348 (multiple-value-bind (localdecls otherdecls let-body)
349 (parse-declarations let-body locals)
350 (cond ((setq specials (extract-special-bindings
352 (maybe-warn (cond ((find-if
353 #'var-globally-special-p
361 "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
362 parent-name clause specials)
364 (t (values (cond ((not (consp let-body))
366 ; Null body of LET? unlikely,
367 ; but someone else will likely
370 ((null (cdr let-body))
372 ; A single expression, which we
378 ;; More than one expression. These are forms to
379 ;; evaluate after the bindings but before the
380 ;; generator form is returned. Save them to
381 ;; evaluate in the next convenient place. Note that
382 ;; this is ok, as there is no construct that can
383 ;; cause a LET to return prematurely (without
384 ;; returning also from some surrounding construct).
387 (car (last let-body))))
388 binding-type let-bindings localdecls
389 otherdecls extra-body))))))))
391 (defun variables-from-let (bindings)
393 ;; Return a list of the variables bound in the first argument to LET[*].
394 (mapcar #'(lambda (binding)
400 (defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg
401 finish-form bound-vars clause)
403 ;;; This is the second major transformation for a single iterate clause.
404 ;;; LET-BODY is the body of the iterator after we have extracted its local
405 ;;; variables and declarations. We have two main tasks: (1) Substitute
406 ;;; internal temporaries for occurrences of the LET variables; the alist
407 ;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of
408 ;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we
409 ;;; check for forms that would invalidate these transformations: occurrence of
410 ;;; FINISH-ARG outside of a funcall, and free reference to any element of
411 ;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type
412 ;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we
413 ;;; return the transformed body; on failure, :ABORT.
418 (lambda (form context env)
419 (declare (ignore context))
421 ;; We need to substitute RENAMED-VARS, as well as turn
422 ;; (FUNCALL finish-arg) into the finish form.
423 (cond ((symbolp form)
425 (cond ((and (eq form finish-arg)
426 (var-same-p form env iterate-env))
427 ;; an occurrence of the finish arg outside
428 ;; of FUNCALL context: I can't handle this!
429 (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
431 (return-from iterate-transform-body
433 ((and (setq renaming (assoc form renamed-vars))
434 (var-same-p form env iterate-env))
435 ;; Reference to one of the vars
438 ((and (member form bound-vars)
439 (var-same-p form env iterate-env))
440 ;; FORM is a var that is bound in this same
441 ;; ITERATE, or bound later in this ITERATE*.
442 ;; This is a conflict.
443 (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
446 (return-from iterate-transform-body
454 (var-same-p (second form) env
456 ;; (FUNCALL finish-arg) => finish-form
457 (unless (null (cddr form))
458 (maybe-warn :definition
459 "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
469 ;; Extract the declarations from the head of TAIL and divide them into 2
470 ;; classes: declares about variables in the list LOCALS, and all other
471 ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL.
473 (localdecls otherdecls form)
475 (unless (and tail (consp (setq form (car tail)))
478 (return (values localdecls otherdecls tail)))
483 ((inline notinline optimize)
484 ; These don't talk about vars
485 (push decl otherdecls))
486 (t ; Assume all other kinds are
488 (let* ((vars (if (eq (first decl)
492 (l (intersection locals vars))
496 ; None talk about LOCALS
497 (push decl otherdecls))
498 ((null (setq other (set-difference vars l)))
499 ; All talk about LOCALS
500 (push decl localdecls))
502 (let ((head (cons 'type (and (eq (first decl)
504 (list (second decl))))))
505 (push (append head other)
507 (push (append head l)
512 (defun extract-special-bindings (vars decls)
514 ;; Return the subset of VARS that are special, either globally or
515 ;; because of a declaration in DECLS
516 (let ((specials (remove-if-not #'var-globally-special-p vars)))
520 (setq specials (union specials (intersection vars
524 (defun function-lambda-p (form &optional nargs)
526 ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length
527 ;; NARGS, return the lambda expression
532 (consp (setq form (cdr form)))
534 (consp (setq form (car form)))
537 (consp (setq body (cdr form)))
538 (listp (setq args (car body)))
546 (let-bindings binding-type env leftover-body &optional tempvarfn)
548 ;; Perform the alpha conversion required for "LET eversion" of
549 ;; (LET[*] LET-BINDINGS . body)--rename each of the variables to an
550 ;; internal name. Returns 2 values: a new set of LET bindings and the
551 ;; alist of old var names to new (so caller can walk the body doing
552 ;; the rest of the renaming). BINDING-TYPE is one of LET or LET*.
553 ;; LEFTOVER-BODY is optional list of forms that must be eval'ed
554 ;; before the first binding happens. ENV is the macro expansion
555 ;; environment, in case we have to walk a LET*. TEMPVARFN is a
556 ;; function of no args to return a temporary var; if omitted, we use
560 (values (mapcar #'(lambda (binding)
561 (let ((valueform (cond ((not (consp binding))
565 ((or (eq binding-type
569 ; All bindings are in parallel,
570 ; so none can refer to others
573 ; In a LET*, have to substitute
574 ; vars in the 2nd and
575 ; subsequent initialization
580 (newvar (if tempvarfn
583 (push (cons (if (consp binding)
588 ; Add new variable to the list
589 ; AFTER we have walked the
592 ;; Previous clause had some computation to do
593 ;; after its bindings. Here is the first
594 ;; opportunity to do it
595 (setq valueform `(progn ,@leftover-body
597 (setq leftover-body nil))
598 (list newvar valueform)))
602 (defun rename-variables (form alist env)
604 ;; Walks FORM, renaming occurrences of the key variables in ALIST with
605 ;; their corresponding values. ENV is FORM's environment, so we can
606 ;; make sure we are talking about the same variables.
608 #'(lambda (form context subenv)
609 (declare (ignore context))
611 (cond ((and (symbolp form)
612 (setq pair (assoc form alist))
613 (var-same-p form subenv env))
621 ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some
622 ;; of the simple cases for benefit of compilers that don't, and I don't care
623 ;; what the value is, and I know that the variables need not be set in
624 ;; parallel, since they can't be used free in EXPR
627 ; EXPR is a side-effect
630 ; This is an error, but I'll
631 ; let MULTIPLE-VALUE-SETQ
633 `(multiple-value-setq ,vars ,expr))
638 ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq
639 ;; (psetq returns nil, but I don't care about returned value). Do this
640 ;; even for the single variable case so that we catch (mv-setq (a) (values
644 `(setq ,@(mapcon #'(lambda (tail)
646 (cond ((or (cdr tail)
648 ; One result expression for
651 (t ; More expressions than vars,
652 ; so arrange to evaluate all
654 (cons 'prog1 expr)))))
657 ; Simple one variable case
660 (t ; General case--I know nothing
661 `(multiple-value-setq ,vars ,expr))))
663 (defun var-same-p (var env1 env2)
664 (eq (var-lexical-p var env1)
665 (var-lexical-p var env2)))
667 (defun maybe-warn (type &rest warn-args)
669 ;; Issue a warning about not being able to optimize this thing. TYPE
670 ;; is one of :DEFINITION, meaning the definition is at fault, and
671 ;; :USER, meaning the user's code is at fault.
672 (when (case *iterate-warnings*
674 ((:user) (eq type :user))
676 (apply #'warn warn-args)))
680 ;;; FIXME: If they're only samples, can they be commented out?
684 (&whole whole &key from downfrom to downto above below by type)
687 (error "Can't use both FROM and DOWNFROM in ~S" whole))
688 ((cdr (remove nil (list to downto above below)))
689 (error "Can't use more than one limit keyword in ~S" whole))
692 ((down (or downfrom downto above))
693 (limit (or to downto above below))
694 (inc (cond ((null by)
697 ; Can inline this increment
700 ((from ,(or from downfrom 0))
701 ,@(and limit `((to ,limit)))
704 ,@(and type `((declare (type ,type from ,@(and limit '(to))
709 ,@(cond ((null limit)
710 ; We won't use the FINISH arg.
711 '((declare (ignore finish)))))
712 (prog1 ,(cond (limit ; Test the limit. If ok,
713 ; return current value and
714 ; increment, else quit
715 `(if (,(cond (above '>)
724 (setq from (,(if down
728 ,(or inc 'by))))))))))
730 (defmacro list-elements (list &key (by '#'cdr))
733 (prog1 (if (endp tail)
736 (setq tail (funcall ,by tail))))))
738 (defmacro list-tails (list &key (by '#'cdr))
741 (prog1 (if (endp tail)
744 (setq tail (funcall ,by tail))))))
749 "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type."
751 ((type (and (consp sequence)
756 (sequence-accessor type)
758 (listp (eq type 'list)))
760 ;; If type is given via THE, we may be able to generate a good accessor here
761 ;; for the benefit of implementations that aren't smart about (ELT (THE
762 ;; STRING FOO)). I'm not bothering to keep the THE inside the body,
763 ;; however, since I assume any compiler that would understand (AREF (THE
764 ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I
765 ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it.
767 ;; If sequence is declared to be a list, it's better to cdr down it, so we
768 ;; have some extra cases here. Normally folks would write LIST-ELEMENTS,
769 ;; but maybe they wanted to get the index for free...
773 '((size (length s)))))
775 (values (cond ,(if listp
779 (,accessor s index)))
780 (t (funcall finish)))
782 (setq index (1+ index))))))))
787 "Generates each time 2 items, the indicator and the value."
788 `(let ((tail ,plist))
790 (values (if (endp tail)
793 (prog1 (if (endp (setq tail (cdr tail)))
796 (setq tail (cdr tail)))))))
798 (defun sequence-accessor (type)
800 ;; returns the function with which most efficiently to make accesses to
801 ;; a sequence of type TYPE.
802 (case (if (consp type)
803 ; e.g., (VECTOR FLOAT *)
806 ((array simple-array vector) 'aref)
807 (simple-vector 'svref)
809 (simple-string 'schar)
811 (simple-bit-vector 'sbit)
814 ;; These "iterators" may be withdrawn
816 (defmacro eachtime (expr)
818 (declare (ignore finish))
821 (defmacro while (expr)
823 (unless ,expr (funcall finish))))
825 (defmacro until (expr)
827 (when ,expr (funcall finish))))
831 (defmacro gathering (clauses &body body &environment env)
832 (or (optimize-gathering-form clauses body env)
833 (simple-expand-gathering-form clauses body env)))
835 (defmacro with-gathering (clauses gather-body &body use-body)
836 "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
838 ;; We may optimize this a little better later for those compilers that
839 ;; don't do a good job on (m-v-bind vars (... (values ...)) ...).
840 `(multiple-value-bind ,(mapcar #'car clauses)
841 (gathering ,clauses ,gather-body)
845 simple-expand-gathering-form
847 (declare (ignore env))
849 ;; The "formal semantics" of GATHERING. We use this only in cases that can't
852 ((acc-names (mapcar #'first (if (symbolp clauses)
853 ; Shorthand using anonymous
855 (setq clauses `((*anonymous-gathering-site*
858 (realizer-names (mapcar #'(lambda (binding)
859 (declare (ignore binding))
862 `(multiple-value-call
864 ,(mapcan #'list acc-names realizer-names)
865 (flet ((gather (value &optional (accumulator *anonymous-gathering-site*)
867 (funcall accumulator value)))
869 (values ,@(mapcar #'(lambda (rname)
872 ,@(mapcar #'second clauses))))
874 (defvar *active-gatherers* nil
875 "List of GATHERING bindings currently active during macro expansion)")
877 (defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site).")
879 (defun optimize-gathering-form (clauses body gathering-env)
881 (acc-info leftover-body top-bindings finish-forms top-decls)
882 (dolist (clause (if (symbolp clauses)
884 `((*anonymous-gathering-site* (,clauses)))
887 (let-body binding-type let-bindings localdecls otherdecls extra-body)
888 (expand-into-let (second clause)
889 'gathering gathering-env)
891 ((acc-var (first clause))
892 renamed-vars accumulator realizer)
893 (when (and (consp let-body)
896 (consp (setq let-body (cdr let-body)))
897 (setq accumulator (function-lambda-p (car let-body)))
898 (consp (setq let-body (cdr let-body)))
899 (setq realizer (function-lambda-p (car let-body)
901 (null (cdr let-body)))
903 ;; Macro returned something of the form
904 ;; (VALUES #'(lambda (value) ...)
905 ;; #'(lambda () ...)),
906 ;; a function to accumulate values and a function to realize the
910 ;; Gatherer expanded into a LET
911 (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
913 `(declare ,@otherdecls))
917 ;; The first transformation we want to perform is a
918 ;; variant of "LET-eversion": turn
921 ;; (let (..bindings..)
922 ;; (values #'(lambda ...)
926 ;; (let* (..bindings..
927 ;; (acc #'(lambda ...))
928 ;; (real #'(lambda ...)))
930 ;; This transformation is valid if nothing in body refers
931 ;; to any of the bindings, something we can ensure by
932 ;; alpha-converting the inner let (substituting new names
933 ;; for each var). Of course, none of those vars can be
934 ;; special, but we already checked for that above.
935 (multiple-value-setq (let-bindings renamed-vars)
936 (rename-let-bindings let-bindings binding-type
937 gathering-env leftover-body))
938 (setq top-bindings (nconc top-bindings let-bindings))
939 (setq leftover-body nil)
940 ; If there was any leftover
941 ; from previous, it is now
944 (setq leftover-body (nconc leftover-body extra-body))
945 ; Computation to do after these
947 (push (cons acc-var (rename-and-capture-variables accumulator
948 renamed-vars gathering-env))
950 (setq realizer (rename-variables realizer renamed-vars
952 (push (cond ((null (cdddr realizer))
953 ; Simple (LAMBDA () expr) =>
956 (t ; There could be declarations
957 ; or something, so leave as a
959 (cons 'let (cdr realizer))))
961 (unless (null localdecls)
962 ; Declarations about the LET
963 ; variables also has to
965 (setq top-decls (nconc top-decls (sublis renamed-vars
968 (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
973 (expansion `(multiple-value-list ,(second clause))))
974 ; Slow way--bind gensym to the
975 ; macro expansion, and we will
976 ; funcall it in the body
977 (push (list acc-var gs)
979 (push `(funcall (cadr ,gs))
985 (list (list gs (cond (leftover-body
986 `(progn ,@(prog1 leftover-body
987 (setq leftover-body nil))
989 (t expansion))))))))))
990 (setq body (walk-gathering-body body gathering-env acc-info))
991 (cond ((eq body :abort)
992 ; Couldn't finish expansion
994 (t `(let* ,top-bindings
995 ,@(and top-decls `((declare ,@top-decls)))
997 ,(cond ((null (cdr finish-forms))
998 ; just a single value
1000 (t `(values ,@(reverse finish-forms)))))))))
1002 (defun rename-and-capture-variables (form alist env)
1004 ;; Walks FORM, renaming occurrences of the key variables in ALIST with
1005 ;; their corresponding values, and capturing any other free variables.
1006 ;; Returns a list of the new form and the list of other closed-over
1007 ;; vars. ENV is FORM's environment, so we can make sure we are talking
1008 ;; about the same variables.
1012 #'(lambda (form context subenv)
1013 (declare (ignore context))
1015 (cond ((or (not (symbolp form))
1016 (not (var-same-p form subenv env)))
1017 ; non-variable or one that has
1020 ((setq pair (assoc form alist))
1024 (pushnew form closed)
1030 (body gathering-env acc-info)
1032 ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV.
1033 ;; ACC-INFO is a list of information about each of the gathering "bindings"
1034 ;; in the form, in the form (var gatheringfn freevars env)
1036 ((*active-gatherers* (nconc (mapcar #'car acc-info)
1037 *active-gatherers*)))
1039 ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER
1040 ;; targets. This is so that when we encounter a GATHER not belonging to us
1041 ;; we can know whether to warn about it.
1047 (declare (ignore context))
1051 ((not (eq (car form)
1053 ; We only care about GATHER
1054 (when (and (eq (car form)
1058 ; Passed as functional--can't
1061 "Can't optimize GATHERING because of reference to #'GATHER."
1063 (return-from walk-gathering-body :abort))
1065 ((setq info (assoc (setq site (if (null (cddr form))
1068 *anonymous-gathering-site*
1071 ; One of ours--expand (GATHER
1072 ; value var). INFO = (var
1073 ; gatheringfn freevars env)
1074 (unless (null (cdddr form))
1075 (warn "Extra arguments (> 2) in ~S discarded." form)
1077 (let ((fn (second info)))
1079 ; Unoptimized case--just call
1080 ; the gatherer. FN is the
1081 ; gensym that we bound to the
1082 ; list of two values returned
1083 ; from the gatherer.
1086 (t ; FN = (lambda (value) ...)
1087 (dolist (s (third info))
1088 (unless (or (var-same-p s env
1095 ;; Some var used free in the LAMBDA form has been
1096 ;; rebound between here and the parent GATHERING
1097 ;; form, so can't substitute the lambda. Ok if it's
1098 ;; a special reference both here and in the LAMBDA,
1099 ;; because then it's not closed over.
1100 (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
1102 (return-from walk-gathering-body
1105 ;; Return ((lambda (value) ...) actual-value). In
1106 ;; many cases we could simplify this further by
1107 ;; substitution, but we'd have to be careful (for
1108 ;; example, we would need to alpha-convert any LET
1109 ;; we found inside). Any decent compiler will do it
1111 (list fn (second form))))))
1112 ((and (setq info (member site *active-gatherers*))
1113 (or (eq site '*anonymous-gathering-site*)
1114 (var-same-p site env (fourth info))))
1115 ; Some other GATHERING will
1116 ; take care of this form, so
1117 ; pass it up for now.
1118 ; Environment check is to make
1119 ; sure nobody shadowed it
1120 ; between here and there
1122 (t ; Nobody's going to handle it
1123 (if (eq site '*anonymous-gathering-site*)
1124 ; More likely that she forgot
1125 ; to mention the site than
1126 ; forget to write an anonymous
1128 (warn "There is no gathering site specified in ~S."
1131 "The site ~S in ~S is not defined in an enclosing GATHERING form."
1133 ; Turn it into something else
1134 ; so we don't warn twice in the
1136 `(%orphaned-gather ,@(cdr form)))))
1137 ((and (symbolp form)
1138 (setq info (assoc form acc-info))
1139 (var-same-p form env gathering-env))
1140 ; A variable reference to a
1141 ; gather binding from
1143 (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
1145 (return-from walk-gathering-body :abort))
1150 ;; FIXME: If these are only samples, can we delete them?
1154 (&key initial-value)
1155 `(let* ((head ,initial-value)
1156 (tail ,(and initial-value `(last head))))
1157 (values #'(lambda (value)
1159 (setq head (setq tail (list value)))
1160 (setq tail (cdr (rplacd tail (list value))))))
1161 #'(lambda nil head))))
1163 (defmacro joining (&key initial-value)
1164 `(let ((result ,initial-value))
1165 (values #'(lambda (value)
1166 (setq result (nconc result value)))
1167 #'(lambda nil result))))
1171 (&key initial-value)
1172 `(let ((result ,initial-value))
1175 (when ,(cond ((and (constantp initial-value)
1176 (not (null (eval initial-value))))
1177 ; Initial value is given and we
1178 ; know it's not NIL, so leave
1179 ; out the null check
1181 (t '(or (null result)
1183 (setq result value)))
1184 #'(lambda nil result))))
1188 (&key initial-value)
1189 `(let ((result ,initial-value))
1192 (when ,(cond ((and (constantp initial-value)
1193 (not (null (eval initial-value))))
1194 ; Initial value is given and we
1195 ; know it's not NIL, so leave
1196 ; out the null check
1198 (t '(or (null result)
1200 (setq result value)))
1201 #'(lambda nil result))))
1203 (defmacro summing (&key (initial-value 0))
1204 `(let ((sum ,initial-value))
1205 (values #'(lambda (value)
1206 (setq sum (+ sum value)))
1207 #'(lambda nil sum))))
1209 ;;; It's easier to read expanded code if PROG1 gets left alone.
1210 (define-walker-template prog1 (nil return sb-walker::repeat (eval)))