1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
24 (in-package "SB-ITERATE")
29 ;;; Are warnings to be issued for iterate/gather forms that aren't optimized?
31 ;;; :USER => those resulting from user code
32 ;;; T => always, even if it's the iteration macro that's suboptimal.
33 (defvar *iterate-warnings* :any)
36 (defmacro iterate (clauses &body body &environment env)
37 (optimize-iterate-form clauses body env))
40 simple-expand-iterate-form
43 ;; Expand ITERATE. This is the "formal semantics" expansion, which we never
46 ((block-name (gensym))
47 (bound-var-lists (mapcar #'(lambda (clause)
48 (let ((names (first clause)))
53 (generator-vars (mapcar #'(lambda (clause)
54 (declare (ignore clause))
59 ,(mapcan #'(lambda (gvar clause var-list)
60 ;; For each clause, bind a generator temp to the clause,
61 ;; then bind the specified var(s).
62 (cons (list gvar (second clause))
63 (copy-list var-list)))
64 generator-vars clauses bound-var-lists)
66 ;; Note bug in formal semantics: there can be declarations in the head
67 ;; of BODY; they go here, rather than inside loop.
70 #'(lambda (var-list gen-var)
71 ;; Set each bound variable (or set of vars) to the result of
72 ;; calling the corresponding generator.
73 `(multiple-value-setq ,var-list
74 (funcall ,gen-var #'(lambda nil (return-from
76 bound-var-lists generator-vars)
79 ;;; temporary variable names used by ITERATE expansions
80 (defparameter *iterate-temp-vars-list*
81 '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4
82 iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8))
86 (clauses body iterate-env)
88 ((temp-vars *iterate-temp-vars-list*)
90 (finish-form `(return-from ,block-name))
91 (bound-vars (mapcan #'(lambda (clause)
92 (let ((names (first clause)))
97 iterate-decls generator-decls update-forms bindings leftover-body)
98 (do ((tail bound-vars (cdr tail)))
100 ;; Check for duplicates
101 (when (member (car tail)
103 (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
105 ((get-iterate-temp nil
107 ;; Make temporary var. Note that it is ok to re-use these symbols
108 ;; in each iterate, because they are not used within BODY.
111 (dolist (clause clauses)
113 ((or (not (consp clause))
114 (not (consp (cdr clause))))
115 (warn "bad syntax in ITERATE: clause not of form (var iterator): ~S"
118 (unless (null (cddr clause))
120 "probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
123 (let-body binding-type let-bindings localdecls otherdecls extra-body)
124 (expand-into-let (second clause)
125 'iterate iterate-env)
127 ;; We have expanded the generator clause and parsed it into
130 ((vars (first clause))
131 gen-args renamed-vars)
132 (setq vars (if (listp vars)
135 ; VARS is now a (fresh) list of
136 ; all iteration vars bound in
139 ((eq let-body :abort)
140 ; Already issued a warning
141 ; about malformedness
143 ((null (setq let-body (function-lambda-p let-body 1)))
144 ; Not of the expected form
145 (let ((generator (second clause)))
146 (cond ((and (consp generator)
147 (fboundp (car generator)))
148 ; It looks ok--a macro or
149 ; function here--so the guy who
150 ; wrote it just didn't do it in
152 (maybe-warn :definition "could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
154 (t ; Perhaps it's just a
155 ; misspelling? Probably user
158 "Iterate operator in clause ~S is not fboundp."
160 (setq let-body :abort)))
163 ;; We have something of the form #'(LAMBDA (finisharg) ...),
164 ;; possibly with some LET bindings around it. LET-BODY =
165 ;; ((finisharg) ...).
166 (setq let-body (cdr let-body))
167 (setq gen-args (pop let-body))
170 ;; The first transformation we want to perform is
171 ;; "LET-eversion": turn (let* ((generator (let (..bindings..)
172 ;; #'(lambda ...)))) ..body..) into (let* (..bindings..
173 ;; (generator #'(lambda ...))) ..body..). This
174 ;; transformation is valid if nothing in body refers to any
175 ;; of the bindings, something we can ensure by
176 ;; alpha-converting the inner let (substituting new names for
177 ;; each var). Of course, none of those vars can be special,
178 ;; but we already checked for that above.
179 (multiple-value-setq (let-bindings renamed-vars)
180 (rename-let-bindings let-bindings binding-type
181 iterate-env leftover-body #'get-iterate-temp))
182 (setq leftover-body nil)
183 ; If there was any leftover
184 ; from previous, it is now
188 ;; The second transformation is substituting the body of the
189 ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance
190 ;; in the update form (funcall generator #'(lambda ()
191 ;; finish-form)), then simplifying that form. The requirement
192 ;; for this part is that the generator body not refer to any
193 ;; variables that are bound between the generator binding and the
194 ;; appearance in the loop body. The only variables bound in that
195 ;; interval are generator temporaries, which have unique names so
196 ;; are no problem, and the iteration variables remaining for
197 ;; subsequent clauses. We'll discover the story as we walk the
199 (multiple-value-bind (finishdecl other rest)
200 (parse-declarations let-body gen-args)
201 (declare (ignore finishdecl))
202 ; Pull out declares, if any,
203 ; separating out the one(s)
204 ; referring to the finish arg,
205 ; which we will throw away.
207 ; Combine remaining decls with
208 ; decls extracted from the LET,
210 (setq otherdecls (nconc otherdecls other)))
213 ; There are interesting
214 ; declarations, so have to keep
216 `(let nil (declare ,@otherdecls)
221 (t `(progn ,@rest)))))
222 (unless (eq (setq let-body (iterate-transform-body let-body
223 iterate-env renamed-vars
225 finish-form bound-vars clause))
228 ;; Skip the rest if transformation failed. Warning has
229 ;; already been issued.
231 ;; Note possible further optimization: if LET-BODY expanded
232 ;; into (prog1 oldvalue prepare-for-next-iteration), as so
233 ;; many do, then we could in most cases split the PROG1 into
234 ;; two pieces: do the (setq var oldvalue) here, and do the
235 ;; prepare-for-next-iteration at the bottom of the loop.
236 ;; This does a slight optimization of the PROG1 and also
237 ;; rearranges the code in a way that a reasonably clever
238 ;; compiler might detect how to get rid of redundant
239 ;; variables altogether (such as happens with INTERVAL and
240 ;; LIST-TAILS); that would make the whole thing closer to
241 ;; what you might have coded by hand. However, to do this
242 ;; optimization, we need to ensure that (a) the
243 ;; prepare-for-next-iteration refers freely to no vars other
244 ;; than the internal vars we have extracted from the LET, and
245 ;; (b) that the code has no side effects. These are both
246 ;; true for all the iterators defined by this module, but how
247 ;; shall we represent side-effect info and/or tap into the
248 ;; compiler's knowledge of same?
250 ; There were declarations for
251 ; the generator locals--have to
252 ; keep them for later, and
253 ; rename the vars mentioned
261 (let ((head (car decl)))
262 (cons head (if (eq head 'type)
270 ;; Finished analyzing clause now. LET-BODY is the form which, when
271 ;; evaluated, returns updated values for the iteration variable(s)
273 (when (eq let-body :abort)
275 ;; Some punt case: go with the formal semantics: bind a var to
276 ;; the generator, then call it in the update section
278 ((gvar (get-iterate-temp))
279 (generator (second clause)))
284 ;; FIXME: This conditional was here with this
285 ;; comment in old CMU CL PCL. Does Python really
286 ;; think it's unreachable?
287 ;;#-cmu ; Python thinks this is unreachable.
289 ; Have to use this up
290 `(progn ,@(prog1 leftover-body (setq
295 (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form)))))
296 (push (mv-setq (copy-list vars)
301 ;; Pop off the vars we have now bound from the list of vars to
302 ;; watch out for -- we'll bind them right now.
305 (nconc bindings let-bindings
307 ;; There was some computation to do after the
308 ;; bindings--here's our chance.
309 (cons (list (first vars)
310 `(progn ,@extra-body nil))
313 (do ((tail body (cdr tail)))
314 ((not (and (consp tail)
319 ;; TAIL now points at first non-declaration. If there were
320 ;; declarations, pop them off so they appear in the right place
321 (unless (eq tail body)
322 (setq iterate-decls (ldiff body tail))
325 (let* ,bindings ,@(and generator-decls
326 `((declare ,@generator-decls)))
329 (loop ,@(nreverse update-forms)
332 (defun expand-into-let (clause parent-name env)
334 ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra
335 ;; body, where BODY is a single form. If multiple forms in a LET, the
336 ;; preceding forms are returned as extra body. Returns :ABORT if it
337 ;; issued a punt warning.
338 (prog ((expansion clause)
339 expandedp binding-type let-bindings let-body)
341 (multiple-value-setq (expansion expandedp)
342 (macroexpand-1 expansion env))
343 (cond ((not (consp expansion))
346 ((symbolp (setq binding-type (first expansion)))
349 (setq let-bindings (second expansion))
350 ; List of variable bindings
351 (setq let-body (cddr expansion))
353 ((and (consp binding-type)
354 (eq (car binding-type)
356 (not (find-if #'(lambda (x)
357 (member x lambda-list-keywords)
359 (setq let-bindings (second binding-type)))
361 (eql (length (second expansion))
362 (length let-bindings))
363 (null (cddr expansion)))
364 ; A simple LAMBDA form can be
366 (setq let-body (cddr binding-type))
367 (setq let-bindings (mapcar #'list let-bindings (second
370 (setq binding-type 'let)
373 ;; Fall thru if not a LET
374 (cond (expandedp ; try expanding again
376 (t ; Boring--return form as the
380 (return (let ((locals (variables-from-let let-bindings))
382 (multiple-value-bind (localdecls otherdecls let-body)
383 (parse-declarations let-body locals)
384 (cond ((setq specials (extract-special-bindings
386 (maybe-warn (cond ((find-if #'variable-globally-special-p
388 ; This could be the fault of a
393 "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
394 parent-name clause specials)
396 (t (values (cond ((not (consp let-body))
398 ; Null body of LET? unlikely,
399 ; but someone else will likely
402 ((null (cdr let-body))
404 ; A single expression, which we
410 ;; More than one expression. These are forms to
411 ;; evaluate after the bindings but before the
412 ;; generator form is returned. Save them to
413 ;; evaluate in the next convenient place. Note that
414 ;; this is ok, as there is no construct that can
415 ;; cause a LET to return prematurely (without
416 ;; returning also from some surrounding construct).
419 (car (last let-body))))
420 binding-type let-bindings localdecls
421 otherdecls extra-body))))))))
423 (defun variables-from-let (bindings)
425 ;; Return a list of the variables bound in the first argument to LET[*].
426 (mapcar #'(lambda (binding)
432 (defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg
433 finish-form bound-vars clause)
435 ;;; This is the second major transformation for a single iterate clause.
436 ;;; LET-BODY is the body of the iterator after we have extracted its local
437 ;;; variables and declarations. We have two main tasks: (1) Substitute
438 ;;; internal temporaries for occurrences of the LET variables; the alist
439 ;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of
440 ;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we
441 ;;; check for forms that would invalidate these transformations: occurrence of
442 ;;; FINISH-ARG outside of a funcall, and free reference to any element of
443 ;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type
444 ;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we
445 ;;; return the transformed body; on failure, :ABORT.
447 (walk-form let-body iterate-env
448 #'(lambda (form context env)
449 (declare (ignore context))
451 ;; Need to substitute RENAMED-VARS, as well as turn
452 ;; (FUNCALL finish-arg) into the finish form
453 (cond ((symbolp form)
455 (cond ((and (eq form finish-arg)
456 (variable-same-p form env
458 ; An occurrence of the finish
459 ; arg outside of FUNCALL
460 ; context--I can't handle this
461 (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
463 (return-from iterate-transform-body
465 ((and (setq renaming (assoc form
468 (variable-same-p form env
470 ; Reference to one of the vars
473 ((and (member form bound-vars)
474 (variable-same-p form env
476 ; FORM is a var that is bound
477 ; in this same ITERATE, or
478 ; bound later in this ITERATE*.
479 ; This is a conflict.
480 (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
483 (return-from iterate-transform-body
491 (variable-same-p (second form)
493 ; (FUNCALL finish-arg) =>
495 (unless (null (cddr form))
496 (maybe-warn :definition
497 "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
507 ;; Extract the declarations from the head of TAIL and divide them into 2
508 ;; classes: declares about variables in the list LOCALS, and all other
509 ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL.
511 (localdecls otherdecls form)
513 (unless (and tail (consp (setq form (car tail)))
516 (return (values localdecls otherdecls tail)))
521 ((inline notinline optimize)
522 ; These don't talk about vars
523 (push decl otherdecls))
524 (t ; Assume all other kinds are
526 (let* ((vars (if (eq (first decl)
530 (l (intersection locals vars))
534 ; None talk about LOCALS
535 (push decl otherdecls))
536 ((null (setq other (set-difference vars l)))
537 ; All talk about LOCALS
538 (push decl localdecls))
540 (let ((head (cons 'type (and (eq (first decl)
542 (list (second decl))))))
543 (push (append head other)
545 (push (append head l)
550 (defun extract-special-bindings (vars decls)
552 ;; Return the subset of VARS that are special, either globally or
553 ;; because of a declaration in DECLS
554 (let ((specials (remove-if-not #'variable-globally-special-p vars)))
558 (setq specials (union specials (intersection vars
562 (defun function-lambda-p (form &optional nargs)
564 ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length
565 ;; NARGS, return the lambda expression
570 (consp (setq form (cdr form)))
572 (consp (setq form (car form)))
575 (consp (setq body (cdr form)))
576 (listp (setq args (car body)))
584 (let-bindings binding-type env leftover-body &optional tempvarfn)
586 ;; Perform the alpha conversion required for "LET eversion" of
587 ;; (LET[*] LET-BINDINGS . body)--rename each of the variables to an
588 ;; internal name. Returns 2 values: a new set of LET bindings and the
589 ;; alist of old var names to new (so caller can walk the body doing
590 ;; the rest of the renaming). BINDING-TYPE is one of LET or LET*.
591 ;; LEFTOVER-BODY is optional list of forms that must be eval'ed
592 ;; before the first binding happens. ENV is the macro expansion
593 ;; environment, in case we have to walk a LET*. TEMPVARFN is a
594 ;; function of no args to return a temporary var; if omitted, we use
598 (values (mapcar #'(lambda (binding)
599 (let ((valueform (cond ((not (consp binding))
603 ((or (eq binding-type
607 ; All bindings are in parallel,
608 ; so none can refer to others
611 ; In a LET*, have to substitute
612 ; vars in the 2nd and
613 ; subsequent initialization
618 (newvar (if tempvarfn
621 (push (cons (if (consp binding)
626 ; Add new variable to the list
627 ; AFTER we have walked the
630 ;; Previous clause had some computation to do
631 ;; after its bindings. Here is the first
632 ;; opportunity to do it
633 (setq valueform `(progn ,@leftover-body
635 (setq leftover-body nil))
636 (list newvar valueform)))
640 (defun rename-variables (form alist env)
642 ;; Walks FORM, renaming occurrences of the key variables in ALIST with
643 ;; their corresponding values. ENV is FORM's environment, so we can
644 ;; make sure we are talking about the same variables.
646 #'(lambda (form context subenv)
647 (declare (ignore context))
649 (cond ((and (symbolp form)
650 (setq pair (assoc form alist))
651 (variable-same-p form subenv env))
659 ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some
660 ;; of the simple cases for benefit of compilers that don't, and I don't care
661 ;; what the value is, and I know that the variables need not be set in
662 ;; parallel, since they can't be used free in EXPR
665 ; EXPR is a side-effect
668 ; This is an error, but I'll
669 ; let MULTIPLE-VALUE-SETQ
671 `(multiple-value-setq ,vars ,expr))
676 ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq
677 ;; (psetq returns nil, but I don't care about returned value). Do this
678 ;; even for the single variable case so that we catch (mv-setq (a) (values
682 `(setq ,@(mapcon #'(lambda (tail)
684 (cond ((or (cdr tail)
686 ; One result expression for
689 (t ; More expressions than vars,
690 ; so arrange to evaluate all
692 (cons 'prog1 expr)))))
695 ; Simple one variable case
698 (t ; General case--I know nothing
699 `(multiple-value-setq ,vars ,expr))))
701 (defun variable-same-p (var env1 env2)
702 (eq (variable-lexical-p var env1)
703 (variable-lexical-p var env2)))
705 (defun maybe-warn (type &rest warn-args)
707 ;; Issue a warning about not being able to optimize this thing. TYPE
708 ;; is one of :DEFINITION, meaning the definition is at fault, and
709 ;; :USER, meaning the user's code is at fault.
710 (when (case *iterate-warnings*
712 ((:user) (eq type :user))
714 (apply #'warn warn-args)))
718 ;;; FIXME: If they're only samples, can they be commented out?
722 (&whole whole &key from downfrom to downto above below by type)
725 (error "Can't use both FROM and DOWNFROM in ~S" whole))
726 ((cdr (remove nil (list to downto above below)))
727 (error "Can't use more than one limit keyword in ~S" whole))
730 ((down (or downfrom downto above))
731 (limit (or to downto above below))
732 (inc (cond ((null by)
735 ; Can inline this increment
738 ((from ,(or from downfrom 0))
739 ,@(and limit `((to ,limit)))
742 ,@(and type `((declare (type ,type from ,@(and limit '(to))
747 ,@(cond ((null limit)
748 ; We won't use the FINISH arg.
749 '((declare (ignore finish)))))
750 (prog1 ,(cond (limit ; Test the limit. If ok,
751 ; return current value and
752 ; increment, else quit
753 `(if (,(cond (above '>)
762 (setq from (,(if down
766 ,(or inc 'by))))))))))
768 (defmacro list-elements (list &key (by '#'cdr))
771 (prog1 (if (endp tail)
774 (setq tail (funcall ,by tail))))))
776 (defmacro list-tails (list &key (by '#'cdr))
779 (prog1 (if (endp tail)
782 (setq tail (funcall ,by tail))))))
787 "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type."
789 ((type (and (consp sequence)
794 (sequence-accessor type)
796 (listp (eq type 'list)))
798 ;; If type is given via THE, we may be able to generate a good accessor here
799 ;; for the benefit of implementations that aren't smart about (ELT (THE
800 ;; STRING FOO)). I'm not bothering to keep the THE inside the body,
801 ;; however, since I assume any compiler that would understand (AREF (THE
802 ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I
803 ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it.
805 ;; If sequence is declared to be a list, it's better to cdr down it, so we
806 ;; have some extra cases here. Normally folks would write LIST-ELEMENTS,
807 ;; but maybe they wanted to get the index for free...
811 '((size (length s)))))
813 (values (cond ,(if listp
817 (,accessor s index)))
818 (t (funcall finish)))
820 (setq index (1+ index))))))))
825 "Generates each time 2 items, the indicator and the value."
826 `(let ((tail ,plist))
828 (values (if (endp tail)
831 (prog1 (if (endp (setq tail (cdr tail)))
834 (setq tail (cdr tail)))))))
836 (defun sequence-accessor (type)
838 ;; returns the function with which most efficiently to make accesses to
839 ;; a sequence of type TYPE.
840 (case (if (consp type)
841 ; e.g., (VECTOR FLOAT *)
844 ((array simple-array vector) 'aref)
845 (simple-vector 'svref)
847 (simple-string 'schar)
849 (simple-bit-vector 'sbit)
852 ;; These "iterators" may be withdrawn
854 (defmacro eachtime (expr)
856 (declare (ignore finish))
859 (defmacro while (expr)
861 (unless ,expr (funcall finish))))
863 (defmacro until (expr)
865 (when ,expr (funcall finish))))
869 (defmacro gathering (clauses &body body &environment env)
870 (or (optimize-gathering-form clauses body env)
871 (simple-expand-gathering-form clauses body env)))
873 (defmacro with-gathering (clauses gather-body &body use-body)
874 "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
876 ;; We may optimize this a little better later for those compilers that
877 ;; don't do a good job on (m-v-bind vars (... (values ...)) ...).
878 `(multiple-value-bind ,(mapcar #'car clauses)
879 (gathering ,clauses ,gather-body)
883 simple-expand-gathering-form
885 (declare (ignore env))
887 ;; The "formal semantics" of GATHERING. We use this only in cases that can't
890 ((acc-names (mapcar #'first (if (symbolp clauses)
891 ; Shorthand using anonymous
893 (setq clauses `((*anonymous-gathering-site*
896 (realizer-names (mapcar #'(lambda (binding)
897 (declare (ignore binding))
900 `(multiple-value-call
902 ,(mapcan #'list acc-names realizer-names)
903 (flet ((gather (value &optional (accumulator *anonymous-gathering-site*)
905 (funcall accumulator value)))
907 (values ,@(mapcar #'(lambda (rname)
910 ,@(mapcar #'second clauses))))
912 (defvar *active-gatherers* nil
913 "List of GATHERING bindings currently active during macro expansion)")
915 (defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site).")
917 (defun optimize-gathering-form (clauses body gathering-env)
919 (acc-info leftover-body top-bindings finish-forms top-decls)
920 (dolist (clause (if (symbolp clauses)
922 `((*anonymous-gathering-site* (,clauses)))
925 (let-body binding-type let-bindings localdecls otherdecls extra-body)
926 (expand-into-let (second clause)
927 'gathering gathering-env)
929 ((acc-var (first clause))
930 renamed-vars accumulator realizer)
931 (when (and (consp let-body)
934 (consp (setq let-body (cdr let-body)))
935 (setq accumulator (function-lambda-p (car let-body)))
936 (consp (setq let-body (cdr let-body)))
937 (setq realizer (function-lambda-p (car let-body)
939 (null (cdr let-body)))
941 ;; Macro returned something of the form
942 ;; (VALUES #'(lambda (value) ...)
943 ;; #'(lambda () ...)),
944 ;; a function to accumulate values and a function to realize the
948 ;; Gatherer expanded into a LET
949 (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
951 `(declare ,@otherdecls))
955 ;; The first transformation we want to perform is a
956 ;; variant of "LET-eversion": turn
959 ;; (let (..bindings..)
960 ;; (values #'(lambda ...)
964 ;; (let* (..bindings..
965 ;; (acc #'(lambda ...))
966 ;; (real #'(lambda ...)))
968 ;; This transformation is valid if nothing in body refers
969 ;; to any of the bindings, something we can ensure by
970 ;; alpha-converting the inner let (substituting new names
971 ;; for each var). Of course, none of those vars can be
972 ;; special, but we already checked for that above.
973 (multiple-value-setq (let-bindings renamed-vars)
974 (rename-let-bindings let-bindings binding-type
975 gathering-env leftover-body))
976 (setq top-bindings (nconc top-bindings let-bindings))
977 (setq leftover-body nil)
978 ; If there was any leftover
979 ; from previous, it is now
982 (setq leftover-body (nconc leftover-body extra-body))
983 ; Computation to do after these
985 (push (cons acc-var (rename-and-capture-variables accumulator
986 renamed-vars gathering-env))
988 (setq realizer (rename-variables realizer renamed-vars
990 (push (cond ((null (cdddr realizer))
991 ; Simple (LAMBDA () expr) =>
994 (t ; There could be declarations
995 ; or something, so leave as a
997 (cons 'let (cdr realizer))))
999 (unless (null localdecls)
1000 ; Declarations about the LET
1001 ; variables also has to
1003 (setq top-decls (nconc top-decls (sublis renamed-vars
1006 (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
1011 (expansion `(multiple-value-list ,(second clause))))
1012 ; Slow way--bind gensym to the
1013 ; macro expansion, and we will
1014 ; funcall it in the body
1015 (push (list acc-var gs)
1017 (push `(funcall (cadr ,gs))
1023 (list (list gs (cond (leftover-body
1024 `(progn ,@(prog1 leftover-body
1025 (setq leftover-body nil))
1027 (t expansion))))))))))
1028 (setq body (walk-gathering-body body gathering-env acc-info))
1029 (cond ((eq body :abort)
1030 ; Couldn't finish expansion
1032 (t `(let* ,top-bindings
1033 ,@(and top-decls `((declare ,@top-decls)))
1035 ,(cond ((null (cdr finish-forms))
1036 ; just a single value
1038 (t `(values ,@(reverse finish-forms)))))))))
1040 (defun rename-and-capture-variables (form alist env)
1042 ;; Walks FORM, renaming occurrences of the key variables in ALIST with
1043 ;; their corresponding values, and capturing any other free variables.
1044 ;; Returns a list of the new form and the list of other closed-over
1045 ;; vars. ENV is FORM's environment, so we can make sure we are talking
1046 ;; about the same variables.
1050 #'(lambda (form context subenv)
1051 (declare (ignore context))
1053 (cond ((or (not (symbolp form))
1054 (not (variable-same-p form subenv
1056 ; non-variable or one that has
1059 ((setq pair (assoc form alist))
1063 (pushnew form closed)
1069 (body gathering-env acc-info)
1071 ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV.
1072 ;; ACC-INFO is a list of information about each of the gathering "bindings"
1073 ;; in the form, in the form (var gatheringfn freevars env)
1075 ((*active-gatherers* (nconc (mapcar #'car acc-info)
1076 *active-gatherers*)))
1078 ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER
1079 ;; targets. This is so that when we encounter a GATHER not belonging to us
1080 ;; we can know whether to warn about it.
1086 (declare (ignore context))
1090 ((not (eq (car form)
1092 ; We only care about GATHER
1093 (when (and (eq (car form)
1097 ; Passed as functional--can't
1100 "Can't optimize GATHERING because of reference to #'GATHER."
1102 (return-from walk-gathering-body :abort))
1104 ((setq info (assoc (setq site (if (null (cddr form))
1107 *anonymous-gathering-site*
1110 ; One of ours--expand (GATHER
1111 ; value var). INFO = (var
1112 ; gatheringfn freevars env)
1113 (unless (null (cdddr form))
1114 (warn "Extra arguments (> 2) in ~S discarded." form)
1116 (let ((fn (second info)))
1118 ; Unoptimized case--just call
1119 ; the gatherer. FN is the
1120 ; gensym that we bound to the
1121 ; list of two values returned
1122 ; from the gatherer.
1125 (t ; FN = (lambda (value) ...)
1126 (dolist (s (third info))
1127 (unless (or (variable-same-p s env
1129 (and (variable-special-p
1134 ;; Some var used free in the LAMBDA form has been
1135 ;; rebound between here and the parent GATHERING
1136 ;; form, so can't substitute the lambda. Ok if it's
1137 ;; a special reference both here and in the LAMBDA,
1138 ;; because then it's not closed over.
1139 (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
1141 (return-from walk-gathering-body
1144 ;; Return ((lambda (value) ...) actual-value). In
1145 ;; many cases we could simplify this further by
1146 ;; substitution, but we'd have to be careful (for
1147 ;; example, we would need to alpha-convert any LET
1148 ;; we found inside). Any decent compiler will do it
1150 (list fn (second form))))))
1151 ((and (setq info (member site *active-gatherers*))
1152 (or (eq site '*anonymous-gathering-site*)
1153 (variable-same-p site env (fourth info))))
1154 ; Some other GATHERING will
1155 ; take care of this form, so
1156 ; pass it up for now.
1157 ; Environment check is to make
1158 ; sure nobody shadowed it
1159 ; between here and there
1161 (t ; Nobody's going to handle it
1162 (if (eq site '*anonymous-gathering-site*)
1163 ; More likely that she forgot
1164 ; to mention the site than
1165 ; forget to write an anonymous
1167 (warn "There is no gathering site specified in ~S."
1170 "The site ~S in ~S is not defined in an enclosing GATHERING form."
1172 ; Turn it into something else
1173 ; so we don't warn twice in the
1175 `(%orphaned-gather ,@(cdr form)))))
1176 ((and (symbolp form)
1177 (setq info (assoc form acc-info))
1178 (variable-same-p form env gathering-env))
1179 ; A variable reference to a
1180 ; gather binding from
1182 (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
1184 (return-from walk-gathering-body :abort))
1189 ;; FIXME: If these are only samples, can we delete them?
1193 (&key initial-value)
1194 `(let* ((head ,initial-value)
1195 (tail ,(and initial-value `(last head))))
1196 (values #'(lambda (value)
1198 (setq head (setq tail (list value)))
1199 (setq tail (cdr (rplacd tail (list value))))))
1200 #'(lambda nil head))))
1202 (defmacro joining (&key initial-value)
1203 `(let ((result ,initial-value))
1204 (values #'(lambda (value)
1205 (setq result (nconc result value)))
1206 #'(lambda nil result))))
1210 (&key initial-value)
1211 `(let ((result ,initial-value))
1214 (when ,(cond ((and (constantp initial-value)
1215 (not (null (eval initial-value))))
1216 ; Initial value is given and we
1217 ; know it's not NIL, so leave
1218 ; out the null check
1220 (t '(or (null result)
1222 (setq result value)))
1223 #'(lambda nil result))))
1227 (&key initial-value)
1228 `(let ((result ,initial-value))
1231 (when ,(cond ((and (constantp initial-value)
1232 (not (null (eval initial-value))))
1233 ; Initial value is given and we
1234 ; know it's not NIL, so leave
1235 ; out the null check
1237 (t '(or (null result)
1239 (setq result value)))
1240 #'(lambda nil result))))
1242 (defmacro summing (&key (initial-value 0))
1243 `(let ((sum ,initial-value))
1244 (values #'(lambda (value)
1245 (setq sum (+ sum value)))
1246 #'(lambda nil sum))))
1248 ;;; It's easier to read expanded code if PROG1 gets left alone.
1249 (define-walker-template prog1 (nil return sb-walker::repeat (eval)))