-;;;; This file defines the defconstructor and other make-instance optimization
-;;;; mechanisms.
+;;;; This file defines MAKE-INSTANCE optimization mechanisms.
+;;;;
+;;;; KLUDGE: I removed the old DEFCONSTRUCTOR, MAKE-CONSTRUCTOR, and
+;;;; LOAD-CONSTRUCTOR families of definitions in sbcl-0.pre7.99, since
+;;;; it was clear from a few minutes with egrep that they were dead
+;;;; code, but I suspect more dead code remains in this file. (Maybe
+;;;; it's all dead?) -- WHN 2001-12-26
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB-PCL")
\f
-;;; defconstructor is used to define special purpose functions which just
-;;; call make-instance with a symbol as the first argument. The semantics
-;;; of defconstructor is that it is equivalent to defining a function which
-;;; just calls make-instance. The purpose of defconstructor is to provide
-;;; PCL with a way of noticing these calls to make-instance so that it can
-;;; optimize them. Specific ports of PCL could just have their compiler
-;;; spot these calls to make-instance and then call this code. Having the
-;;; special defconstructor facility is the best we can do portably.
-;;;
-;;; A call to defconstructor like:
-;;;
-;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
-;;;
-;;; Is equivalent to a defun like:
-;;;
-;;; (defun make-foo (a b &rest r)
-;;; (make-instance 'foo 'a a ':mumble b 'baz r))
-;;;
-;;; Calls like the following are also legal:
-;;;
-;;; (defconstructor make-foo foo ())
-;;; (defconstructor make-bar bar () :x *x* :y *y*)
-;;; (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
-;;;
-;;; The general idea of this implementation is that the expansion of the
-;;; defconstructor form includes the creation of closure generators which
-;;; can be called to create constructor code for the class. The ways that
-;;; a constructor can be optimized depends not only on the defconstructor
-;;; form, but also on the state of the class and the generic functions in
-;;; the initialization protocol. Because of this, the determination of the
-;;; form of constructor code to be used is a two part process.
-;;;
-;;; At compile time, make-constructor-code-generators looks at the actual
-;;; defconstructor form and makes a list of appropriate constructor code
-;;; generators. All that is really taken into account here is whether
-;;; any initargs are supplied in the call to make-instance, and whether
-;;; any of those are constant.
-;;;
-;;; At constructor code generation time (see note about lazy evaluation)
-;;; compute-constructor-code calls each of the constructor code generators
-;;; to try to get code for this constructor. Each generator looks at the
-;;; state of the class and initialization protocol generic functions and
-;;; decides whether its type of code is appropriate. This depends on things
-;;; like whether there are any applicable methods on initialize-instance,
-;;; whether class slots are affected by initialization etc.
-;;;
-;;; Constructor objects are funcallable instances, the protocol followed to
-;;; to compute the constructor code for them is quite similar to the protocol
-;;; followed to compute the discriminator code for a generic function. When
-;;; the constructor is first loaded, we install as its code a function which
-;;; will compute the actual constructor code the first time it is called.
-;;;
-;;; If there is an update to the class structure which might invalidate the
-;;; optimized constructor, the special lazy constructor installer is put back
-;;; so that it can compute the appropriate constructor when it is called.
-;;; This is the same kind of lazy evaluation update strategy used elswhere
-;;; in PCL.
-;;;
-;;; To allow for flexibility in the PCL implementation and to allow PCL users
-;;; to specialize this constructor facility for their own metaclasses, there
-;;; is an internal protocol followed by the code which loads and installs
-;;; the constructors. This is documented in the comments in the code.
-;;;
-;;; This code is also designed so that one of its levels, can be used to
-;;; implement optimization of calls to make-instance which can't go through
-;;; the defconstructor facility. This has not been implemented yet, but the
-;;; hooks are there.
-
-(defmacro defconstructor
- (name class lambda-list &rest initialization-arguments)
- (expand-defconstructor class
- name
- lambda-list
- (copy-list initialization-arguments)))
-
-(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
- (let ((class (find-class class-name nil))
- (supplied-initarg-names
- (loop for name in supplied-initargs by #'cddr
- collect name)))
- (when (null class)
- (error "defconstructor form being compiled (or evaluated) before~@
- class ~S is defined."
- class-name))
- `(progn
- ;; comments from PCL code back when it was portable:
- ;; In order to avoid undefined function warnings, we want to
- ;; tell the compile time environment that a function with this
- ;; name and this argument list has been defined. The portable
- ;; way to do this is with defun:
- ;; #-cmu (declaim (notinline ,name))
- ;; #-cmu
- ;; (defun ,name ,lambda-list
- ;; (declare (ignore ,@(extract-parameters lambda-list)))
- ;; (error "Constructor ~S not loaded." ',name))
- ;; But the derived result type for the above is wrong under CMU CL.
- ;; So instead:
- (declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name)
- ,name))
- (load-constructor
- ',class-name
- ',(class-name (class-of class))
- ',name
- ',supplied-initarg-names
- ;; make-constructor-code-generators is called to return a list
- ;; of constructor code generators. The actual interpretation
- ;; of this list is left to compute-constructor-code, but the
- ;; general idea is that it should be an plist where the keys
- ;; name a kind of constructor code and the values are generator
- ;; functions which return the actual constructor code. The
- ;; constructor code is usually a closures over the arguments
- ;; to the generator.
- ,(make-constructor-code-generators class
- name
- lambda-list
- supplied-initarg-names
- supplied-initargs)))))
-
-(defun load-constructor (class-name metaclass-name constructor-name
- supplied-initarg-names code-generators)
- (let ((class (find-class class-name nil)))
- (cond ((null class)
- (error "defconstructor form being loaded (or evaluated) before~@
- class ~S is defined."
- class-name))
- ((neq (class-name (class-of class)) metaclass-name)
- (error "When defconstructor ~S was compiled, the metaclass of the~@
- class ~S was ~S. The metaclass is now ~S.~@
- The constructor must be recompiled."
- constructor-name
- class-name
- metaclass-name
- (class-name (class-of class))))
- (t
- (load-constructor-internal class
- constructor-name
- supplied-initarg-names
- code-generators)
- constructor-name))))
-
;;; The actual constructor objects.
(defclass constructor (funcallable-standard-object)
((class ;The class with which this
:initform nil ;This is the symbol in whose
:initarg :name ;function cell the constructor
:reader constructor-name) ;usually sits. Of course, this
- ;is optional. defconstructor
- ;makes named constructors, but
+ ;is optional. The old
+ ;DEFCONSTRUCTOR macro made
+ ;named constructors, but
;it is possible to manipulate
;anonymous constructors also.
:reader constructor-code-generators)) ;could use.
(:metaclass funcallable-standard-class))
-;;; Because the value in the code-type slot should always correspond
-;;; to the FUNCALLABLE-INSTANCE-FUN of the constructor, this function
-;;; should always be used to set them both at the same time.
-(defun set-constructor-code (constructor code type)
- (set-funcallable-instance-fun constructor code)
- (set-fun-name constructor (constructor-name constructor))
- (setf (constructor-code-type constructor) type))
-
(defmethod describe-object ((constructor constructor) stream)
(format stream
"~S is a constructor for the class ~S.~%~
(doplist (key val) (constructor-code-generators constructor)
(push key collect))
(nreverse collect))))
-
-;;; I am not in a hairy enough mood to make this implementation be
-;;; metacircular enough that it can support a defconstructor for
-;;; constructor objects.
-(defun make-constructor (class name supplied-initarg-names code-generators)
- (make-instance 'constructor
- :class class
- :name name
- :supplied-initarg-names supplied-initarg-names
- :code-generators code-generators))
-
-; This definition actually appears in std-class.lisp.
-;(defmethod class-constructors ((class std-class))
-; (with-slots (plist) class (getf plist 'constructors)))
-
-(defmethod add-constructor ((class slot-class)
- (constructor constructor))
- (with-slots (plist) class
- (pushnew constructor (getf plist 'constructors))))
-
-(defmethod remove-constructor ((class slot-class)
- (constructor constructor))
- (with-slots (plist) class
- (setf (getf plist 'constructors)
- (delete constructor (getf plist 'constructors)))))
-
-(defmethod get-constructor ((class slot-class) name &optional (error-p t))
- (or (dolist (c (class-constructors class))
- (when (eq (constructor-name c) name) (return c)))
- (if error-p
- (error "Couldn't find a constructor with name ~S for class ~S."
- name class)
- ())))
-
-;;; This is called to actually load a defconstructor constructor. It
-;;; must install the lazy installer in the function cell of the
-;;; constructor name, and also add this constructor to the list of
-;;; constructors the class has.
-(defmethod load-constructor-internal
- ((class slot-class) name initargs generators)
- (let ((constructor (make-constructor class name initargs generators))
- (old (get-constructor class name nil)))
- (when old (remove-constructor class old))
- (install-lazy-constructor-installer constructor)
- (add-constructor class constructor)
- (setf (gdefinition name) constructor)))
-
-(defmethod install-lazy-constructor-installer ((constructor constructor))
- (let ((class (constructor-class constructor)))
- (set-constructor-code constructor
- #'(sb-kernel:instance-lambda (&rest args)
- (multiple-value-bind (code type)
- (compute-constructor-code class constructor)
- (set-constructor-code constructor code type)
- (apply constructor args)))
- 'lazy)))
-
-;;; the interface to keeping the constructors updated
-;;;
-;;; add-method and remove-method (for standard-generic-function and
-;;; -method), promise to call maybe-update-constructors on the generic
-;;; function and the method.
-;;;
-;;; The class update code promises to call update-constructors
-;;; whenever the class is changed. That is, whenever the supers, slots
-;;; or options change. If user defined classes of constructor needs to
-;;; be updated in more than these circumstances, they should use the
-;;; dependent updating mechanism to make sure update-constructors is
-;;; called.
-;;;
-;;; Bootstrapping concerns force the definitions of
-;;; maybe-update-constructors and update-constructors to be in the
-;;; file std-class. For clarity, they also appear below. Be sure to
-;;; keep the definition here and there in sync.
-;(defvar *initialization-generic-functions*
-; (list #'make-instance
-; #'default-initargs
-; #'allocate-instance
-; #'initialize-instance
-; #'shared-initialize))
-;
-;(defmethod maybe-update-constructors
-; ((generic-function generic-function)
-; (method method))
-; (when (memq generic-function *initialization-generic-functions*)
-; (labels ((recurse (class)
-; (update-constructors class)
-; (dolist (subclass (class-direct-subclasses class))
-; (recurse subclass))))
-; (when (classp (car (method-specializers method)))
-; (recurse (car (method-specializers method)))))))
-;
-;(defmethod update-constructors ((class slot-class))
-; (dolist (cons (class-constructors class))
-; (install-lazy-constructor-installer cons)))
-;
-;(defmethod update-constructors ((class class))
-; ())
\f
-;;; Here is the actual smarts for making the code generators and then trying
-;;; each generator to get constructor code. This extensible mechanism allows
-;;; new kinds of constructor code types to be added. A programmer defining a
-;;; specialization of the constructor class can either use this mechanism to
-;;; define new code types, or can override this mechanism by overriding the
-;;; methods on make-constructor-code-generators and compute-constructor-code.
-;;;
-;;; The function defined by define-constructor-code-type will receive the
-;;; class object, and the 4 original arguments to defconstructor. It can
-;;; return a constructor code generator, or return nil if this type of code
-;;; is determined to not be appropriate after looking at the defconstructor
-;;; arguments.
-;;;
-;;; When compute-constructor-code is called, it first performs basic checks
-;;; to make sure that the basic assumptions common to all the code types are
-;;; valid. (For details see method definition). If any of the tests fail,
-;;; the fallback constructor code type is used. If none of the tests fail,
-;;; the constructor code generators are called in order. They receive 5
-;;; arguments:
-;;;
-;;; CLASS the class the constructor is making instances of
-;;; WRAPPER that class's wrapper
-;;; DEFAULTS the result of calling class-default-initargs on class
-;;; INITIALIZE the applicable methods on initialize-instance
-;;; SHARED the applicable methosd on shared-initialize
-;;;
-;;; The first code generator to return code is used. The code generators are
-;;; called in reverse order of definition, so define-constructor-code-type
-;;; forms which define better code should appear after ones that define less
-;;; good code. The fallback code type appears first. Note that redefining a
-;;; code type does not change its position in the list. To do that, define
-;;; a new type at the end with the behavior.
+;;;; Here is the actual smarts for making the code generators and then
+;;;; trying each generator to get constructor code. This extensible
+;;;; mechanism allows new kinds of constructor code types to be added.
+;;;; A programmer defining a specialization of the constructor class
+;;;; can use this mechanism to define new code types.
+;;;;
+;;;; original PCL comment from before dead DEFCONSTRUCTOR was deleted:
+;;;; The function defined by define-constructor-code-type will receive
+;;;; the class object, and the 4 original arguments to DEFCONSTRUCTOR.
+;;;; It can return a constructor code generator, or return NIL if this
+;;;; type of code is determined to not be appropriate after looking at
+;;;; the DEFCONSTRUCTOR arguments.
+;;;;
+;;;; original PCL comment from before dead COMPUTE-CONSTRUCTOR-CODE
+;;;; was deleted:
+;;;; When compute-constructor-code is called, it first performs
+;;;; basic checks to make sure that the basic assumptions common to
+;;;; all the code types are valid. (For details see method
+;;;; definition). If any of the tests fail, the fallback
+;;;; constructor code type is used. If none of the tests fail, the
+;;;; constructor code generators are called in order. They receive
+;;;; 5 arguments:
+;;;;
+;;;; CLASS the class the constructor is making instances of
+;;;; WRAPPER that class's wrapper
+;;;; DEFAULTS the result of calling class-default-initargs on class
+;;;; INITIALIZE the applicable methods on initialize-instance
+;;;; SHARED the applicable methosd on shared-initialize
+;;;;
+;;;; The first code generator to return code is used. The code
+;;;; generators are called in reverse order of definition, so
+;;;; DEFINE-CONSTRUCTOR-CODE-TYPE forms which define better code
+;;;; should appear after ones that define less good code. The fallback
+;;;; code type appears first. Note that redefining a code type does
+;;;; not change its position in the list. To do that, define a new
+;;;; type at the end with the behavior.
(defvar *constructor-code-types* ())
(setf (cadr old-entry) generator)
(push (list type generator) *constructor-code-types*))
type))
-
-(defmethod make-constructor-code-generators
- ((class slot-class)
- name lambda-list supplied-initarg-names supplied-initargs)
- (cons 'list
- (let ((collect nil))
- (dolist (entry *constructor-code-types*)
- (let ((generator
- (funcall (cadr entry) class name lambda-list
- supplied-initarg-names
- supplied-initargs)))
- (when generator
- (push `',(car entry) collect)
- (push generator collect))))
- (nreverse collect))))
-
-(defmethod compute-constructor-code ((class slot-class)
- (constructor constructor))
- (let* ((proto (class-prototype class))
- (wrapper (class-wrapper class))
- (defaults (class-default-initargs class))
- (make
- (compute-applicable-methods (gdefinition 'make-instance) (list class)))
- (supplied-initarg-names
- (constructor-supplied-initarg-names constructor))
- (default
- (compute-applicable-methods (gdefinition 'default-initargs)
- (list class supplied-initarg-names))) ;?
- (allocate
- (compute-applicable-methods (gdefinition 'allocate-instance)
- (list class)))
- (initialize
- (compute-applicable-methods (gdefinition 'initialize-instance)
- (list proto)))
- (shared
- (compute-applicable-methods (gdefinition 'shared-initialize)
- (list proto t)))
- (code-generators
- (constructor-code-generators constructor)))
- (flet ((call-code-generator (generator)
- (when (null generator)
- (unless (setq generator (getf code-generators 'fallback))
- (error "No FALLBACK generator?")))
- (funcall generator class wrapper defaults initialize shared)))
- (if (or (cdr make)
- (cdr default)
- (cdr allocate)
- (not (check-initargs-1 class
- supplied-initarg-names
- (append initialize shared)
- nil nil)))
- ;; These are basic shared assumptions, if one of the
- ;; has been violated, we have to resort to the fallback
- ;; case. Any of these assumptions could be moved out
- ;; of here and into the individual code types if there
- ;; was a need to do so.
- (values (call-code-generator nil) 'fallback)
- ;; Otherwise try all the generators until one produces
- ;; code for us.
- (doplist (type generator) code-generators
- (let ((code (call-code-generator generator)))
- (when code (return (values code type)))))))))
-
-;;; The facilities are useful for debugging, and to measure the performance
-;;; boost from constructors.
-;;;
-;;; FIXME: so they should probably be #+SB-SHOW instead of unconditional
-
-(defun map-constructors (fn)
- (let ((nclasses 0)
- (nconstructors 0))
- (labels ((recurse (class)
- (incf nclasses)
- (dolist (constructor (class-constructors class))
- (incf nconstructors)
- (funcall fn constructor))
- (dolist (subclass (class-direct-subclasses class))
- (recurse subclass))))
- (recurse (find-class t))
- (values nclasses nconstructors))))
-
-(defun reset-constructors ()
- (multiple-value-bind (nclass ncons)
- (map-constructors #'install-lazy-constructor-installer )
- (format t "~&~W classes, ~W constructors." nclass ncons)))
-
-(defun disable-constructors ()
- (multiple-value-bind (nclass ncons)
- (map-constructors
- #'(lambda (c)
- (let ((gen (getf (constructor-code-generators c) 'fallback)))
- (if (null gen)
- (error "No fallback constructor for ~S." c)
- (set-constructor-code c
- (funcall gen
- (constructor-class c)
- () () () ())
- 'fallback)))))
- (format t "~&~W classes, ~W constructors." nclass ncons)))
-
-(defun enable-constructors ()
- (reset-constructors))
\f
-;;; helper functions and utilities that are shared by all of the code types
-;;; and by the main compute-constructor-code method as well
+;;;; helper functions and utilities that are shared by all of the code
+;;;; types
(defvar *standard-initialize-instance-method*
(get-method #'initialize-instance
(push (cons initarg positions) collect))))
(nreverse collect))))
\f
-;;; The FALLBACK case allows anything. This always works, and always appears
-;;; as the last of the generators for a constructor. It does a full call to
-;;; make-instance.
+;;; The FALLBACK case allows anything. This always works, and always
+;;; appears as the last of the generators for a constructor. It does a
+;;; full call to make-instance.
(define-constructor-code-type fallback
(class name arglist supplied-initarg-names supplied-initargs)
(declare (ignore name supplied-initarg-names))
+++ /dev/null
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-
-;;;; FIXME: It'd be nice to get rid of all 750 lines of code in this
-;;;; file, plus miscellaneous cruft elsewhere (e.g. the definition of
-;;;; the SB-ITERATE package). There are only 20 calls to this ITERATE
-;;;; macro in the PCL code. (There's another ITERATE macro used in the
-;;;; classic CMU CL code, but that's different.) Most if not all of
-;;;; them would be easy to replace with ANSI LOOP or simpler standard
-;;;; iteration constructs.
-
-;;;; This software is derived from software originally released by Xerox
-;;;; Corporation. Copyright and release statements follow. Later modifications
-;;;; to the software are in the public domain and are provided with
-;;;; absolutely no warranty. See the COPYING and CREDITS files for more
-;;;; information.
-
-;;;; copyright information from original PCL sources:
-;;;;
-;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;;; All rights reserved.
-;;;;
-;;;; Use and copying of this software and preparation of derivative works based
-;;;; upon this software are permitted. Any distribution of this software or
-;;;; derivative works must comply with all applicable United States export
-;;;; control laws.
-;;;;
-;;;; This software is made available AS IS, and Xerox Corporation makes no
-;;;; warranty about the software, its performance or its conformity to any
-;;;; specification.
-
-(in-package "SB-ITERATE")
-\f
-;;; Are warnings to be issued for iterate/gather forms that aren't
-;;; optimized?
-;;; NIL => never
-;;; :USER => those resulting from user code
-;;; T => always, even if it's the iteration macro that's suboptimal.
-(defvar *iterate-warnings* :any)
-
-;;; ITERATE macro
-(defmacro iterate (clauses &body body &environment env)
- (optimize-iterate-form clauses body env))
-
-;;; temporary variable names used by ITERATE expansions
-(defparameter *iterate-temp-vars-list*
- '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4
- iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8))
-
-(defun
- optimize-iterate-form
- (clauses body iterate-env)
- (let*
- ((temp-vars *iterate-temp-vars-list*)
- (block-name (gensym))
- (finish-form `(return-from ,block-name))
- (bound-vars (mapcan #'(lambda (clause)
- (let ((names (first clause)))
- (if (listp names)
- (copy-list names)
- (list names))))
- clauses))
- iterate-decls generator-decls update-forms bindings leftover-body)
- (do ((tail bound-vars (cdr tail)))
- ((null tail))
- ;; Check for duplicates
- (when (member (car tail)
- (cdr tail))
- (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
- (flet
- ((get-iterate-temp nil
-
- ;; Make temporary var. Note that it is ok to re-use these symbols
- ;; in each iterate, because they are not used within BODY.
- (or (pop temp-vars)
- (gensym))))
- (dolist (clause clauses)
- (cond
- ((or (not (consp clause))
- (not (consp (cdr clause))))
- (warn "bad syntax in ITERATE: clause not of form (var iterator): ~S"
- clause))
- (t
- (unless (null (cddr clause))
- (warn
- "probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
- clause))
- (multiple-value-bind
- (let-body binding-type let-bindings localdecls otherdecls extra-body)
- (expand-into-let (second clause)
- 'iterate iterate-env)
-
- ;; We have expanded the generator clause and parsed it into
- ;; its LET pieces.
- (prog*
- ((vars (first clause))
- gen-args renamed-vars)
- (setq vars (if (listp vars)
- (copy-list vars)
- (list vars)))
- ; VARS is now a (fresh) list of
- ; all iteration vars bound in
- ; this clause
- (cond
- ((eq let-body :abort)
- ; Already issued a warning
- ; about malformedness
- )
- ((null (setq let-body (function-lambda-p let-body 1)))
- ; Not of the expected form
- (let ((generator (second clause)))
- (cond ((and (consp generator)
- (fboundp (car generator)))
- ; It looks ok--a macro or
- ; function here--so the guy who
- ; wrote it just didn't do it in
- ; an optimizable way
- (maybe-warn :definition "could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
- generator))
- (t ; Perhaps it's just a
- ; misspelling? Probably user
- ; error
- (maybe-warn :user
- "Iterate operator in clause ~S is not fboundp."
- generator)))
- (setq let-body :abort)))
- (t
-
- ;; We have something of the form #'(LAMBDA (finisharg) ...),
- ;; possibly with some LET bindings around it. LET-BODY =
- ;; ((finisharg) ...).
- (setq let-body (cdr let-body))
- (setq gen-args (pop let-body))
- (when let-bindings
-
- ;; The first transformation we want to perform is
- ;; "LET-eversion": turn (let* ((generator (let (..bindings..)
- ;; #'(lambda ...)))) ..body..) into (let* (..bindings..
- ;; (generator #'(lambda ...))) ..body..). This
- ;; transformation is valid if nothing in body refers to any
- ;; of the bindings, something we can ensure by
- ;; alpha-converting the inner let (substituting new names for
- ;; each var). Of course, none of those vars can be special,
- ;; but we already checked for that above.
- (multiple-value-setq (let-bindings renamed-vars)
- (rename-let-bindings let-bindings binding-type
- iterate-env leftover-body #'get-iterate-temp))
- (setq leftover-body nil)
- ; If there was any leftover
- ; from previous, it is now
- ; consumed.
- )
-
- ;; The second transformation is substituting the body of the
- ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance
- ;; in the update form (funcall generator #'(lambda ()
- ;; finish-form)), then simplifying that form. The requirement
- ;; for this part is that the generator body not refer to any
- ;; variables that are bound between the generator binding and the
- ;; appearance in the loop body. The only variables bound in that
- ;; interval are generator temporaries, which have unique names so
- ;; are no problem, and the iteration variables remaining for
- ;; subsequent clauses. We'll discover the story as we walk the
- ;; body.
- (multiple-value-bind (finishdecl other rest)
- (parse-declarations let-body gen-args)
- (declare (ignore finishdecl))
- ; Pull out declares, if any,
- ; separating out the one(s)
- ; referring to the finish arg,
- ; which we will throw away.
- (when other
- ; Combine remaining decls with
- ; decls extracted from the LET,
- ; if any.
- (setq otherdecls (nconc otherdecls other)))
- (setq let-body (cond
- (otherdecls
- ; There are interesting
- ; declarations, so have to keep
- ; it wrapped.
- `(let nil (declare ,@otherdecls)
- ,@rest))
- ((null (cdr rest))
- ; Only one form left
- (first rest))
- (t `(progn ,@rest)))))
- (unless (eq (setq let-body (iterate-transform-body let-body
- iterate-env renamed-vars
- (first gen-args)
- finish-form bound-vars clause))
- :abort)
-
- ;; Skip the rest if transformation failed. Warning has
- ;; already been issued.
-
- ;; Note possible further optimization: if LET-BODY expanded
- ;; into (prog1 oldvalue prepare-for-next-iteration), as so
- ;; many do, then we could in most cases split the PROG1 into
- ;; two pieces: do the (setq var oldvalue) here, and do the
- ;; prepare-for-next-iteration at the bottom of the loop.
- ;; This does a slight optimization of the PROG1 and also
- ;; rearranges the code in a way that a reasonably clever
- ;; compiler might detect how to get rid of redundant
- ;; variables altogether (such as happens with INTERVAL and
- ;; LIST-TAILS); that would make the whole thing closer to
- ;; what you might have coded by hand. However, to do this
- ;; optimization, we need to ensure that (a) the
- ;; prepare-for-next-iteration refers freely to no vars other
- ;; than the internal vars we have extracted from the LET, and
- ;; (b) that the code has no side effects. These are both
- ;; true for all the iterators defined by this module, but how
- ;; shall we represent side-effect info and/or tap into the
- ;; compiler's knowledge of same?
- (when localdecls
- ; There were declarations for
- ; the generator locals--have to
- ; keep them for later, and
- ; rename the vars mentioned
- (setq
- generator-decls
- (nconc
- generator-decls
- (mapcar
- #'(lambda
- (decl)
- (let ((head (car decl)))
- (cons head (if (eq head 'type)
- (cons (second decl)
- (sublis renamed-vars
- (cddr decl)))
- (sublis renamed-vars
- (cdr decl))))))
- localdecls)))))))
-
- ;; Finished analyzing clause now. LET-BODY is the form which, when
- ;; evaluated, returns updated values for the iteration variable(s)
- ;; VARS.
- (when (eq let-body :abort)
-
- ;; Some punt case: go with the formal semantics: bind a var to
- ;; the generator, then call it in the update section
- (let
- ((gvar (get-iterate-temp))
- (generator (second clause)))
- (setq
- let-bindings
- (list (list gvar
- (cond
- ;; FIXME: This conditional was here with this
- ;; comment in old CMU CL PCL. Does Python really
- ;; think it's unreachable?
- ;;#-cmu ; Python thinks this is unreachable.
- (leftover-body
- ; Have to use this up
- `(progn ,@(prog1 leftover-body (setq
- leftover-body
- nil))
- generator))
- (t generator)))))
- (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form)))))
- (push (mv-setq (copy-list vars)
- let-body)
- update-forms)
- (dolist (v vars)
- (declare (ignore v))
- ;; Pop off the vars we have now bound from the list of vars to
- ;; watch out for -- we'll bind them right now.
- (pop bound-vars))
- (setq bindings
- (nconc bindings let-bindings
- (cond (extra-body
- ;; There was some computation to do after the
- ;; bindings--here's our chance.
- (cons (list (first vars)
- `(progn ,@extra-body nil))
- (rest vars)))
- (t vars))))))))))
- (do ((tail body (cdr tail)))
- ((not (and (consp tail)
- (consp (car tail))
- (eq (caar tail)
- 'declare)))
-
- ;; TAIL now points at first non-declaration. If there were
- ;; declarations, pop them off so they appear in the right place
- (unless (eq tail body)
- (setq iterate-decls (ldiff body tail))
- (setq body tail))))
- `(block ,block-name
- (let* ,bindings ,@(and generator-decls
- `((declare ,@generator-decls)))
- ,@iterate-decls
- ,@leftover-body
- (loop ,@(nreverse update-forms)
- ,@body)))))
-
-(defun expand-into-let (clause parent-name env)
-
- ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra
- ;; body, where BODY is a single form. If multiple forms in a LET, the
- ;; preceding forms are returned as extra body. Returns :ABORT if it
- ;; issued a punt warning.
- (prog ((expansion clause)
- expandedp binding-type let-bindings let-body)
- expand
- (multiple-value-setq (expansion expandedp)
- (macroexpand-1 expansion env))
- (cond ((not (consp expansion))
- ; Shouldn't happen
- )
- ((symbolp (setq binding-type (first expansion)))
- (case binding-type
- ((let let*)
- (setq let-bindings (second expansion))
- ; List of variable bindings
- (setq let-body (cddr expansion))
- (go handle-let))))
- ((and (consp binding-type)
- (eq (car binding-type)
- 'lambda)
- (not (find-if #'(lambda (x)
- (member x lambda-list-keywords)
- )
- (setq let-bindings (second binding-type)))
- )
- (eql (length (second expansion))
- (length let-bindings))
- (null (cddr expansion)))
- ; A simple LAMBDA form can be
- ; treated as LET
- (setq let-body (cddr binding-type))
- (setq let-bindings (mapcar #'list let-bindings (second
- expansion))
- )
- (setq binding-type 'let)
- (go handle-let)))
-
- ;; Fall thru if not a LET
- (cond (expandedp ; try expanding again
- (go expand))
- (t ; Boring--return form as the
- ; body
- (return expansion)))
- handle-let
- (return (let ((locals (variables-from-let let-bindings))
- extra-body specials)
- (multiple-value-bind (localdecls otherdecls let-body)
- (parse-declarations let-body locals)
- (cond ((setq specials (extract-special-bindings
- locals localdecls))
- (maybe-warn (cond ((find-if
- #'var-globally-special-p
- specials)
- ;; This could be the
- ;; fault of a user
- ;; proclamation.
- :user)
- (t :definition))
-
- "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
- parent-name clause specials)
- :abort)
- (t (values (cond ((not (consp let-body))
-
- ; Null body of LET? unlikely,
- ; but someone else will likely
- ; complain
- nil)
- ((null (cdr let-body))
-
- ; A single expression, which we
- ; hope is (function
- ; (lambda...))
- (first let-body))
- (t
-
- ;; More than one expression. These are forms to
- ;; evaluate after the bindings but before the
- ;; generator form is returned. Save them to
- ;; evaluate in the next convenient place. Note that
- ;; this is ok, as there is no construct that can
- ;; cause a LET to return prematurely (without
- ;; returning also from some surrounding construct).
- (setq extra-body
- (butlast let-body))
- (car (last let-body))))
- binding-type let-bindings localdecls
- otherdecls extra-body))))))))
-
-(defun variables-from-let (bindings)
-
- ;; Return a list of the variables bound in the first argument to LET[*].
- (mapcar #'(lambda (binding)
- (if (consp binding)
- (first binding)
- binding))
- bindings))
-
-(defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg
- finish-form bound-vars clause)
-
-;;; This is the second major transformation for a single iterate clause.
-;;; LET-BODY is the body of the iterator after we have extracted its local
-;;; variables and declarations. We have two main tasks: (1) Substitute
-;;; internal temporaries for occurrences of the LET variables; the alist
-;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of
-;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we
-;;; check for forms that would invalidate these transformations: occurrence of
-;;; FINISH-ARG outside of a funcall, and free reference to any element of
-;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type
-;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we
-;;; return the transformed body; on failure, :ABORT.
-
- (walk-form
- let-body
- iterate-env
- (lambda (form context env)
- (declare (ignore context))
-
- ;; We need to substitute RENAMED-VARS, as well as turn
- ;; (FUNCALL finish-arg) into the finish form.
- (cond ((symbolp form)
- (let (renaming)
- (cond ((and (eq form finish-arg)
- (var-same-p form env iterate-env))
- ;; an occurrence of the finish arg outside
- ;; of FUNCALL context: I can't handle this!
- (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
- (second clause))
- (return-from iterate-transform-body
- :abort))
- ((and (setq renaming (assoc form renamed-vars))
- (var-same-p form env iterate-env))
- ;; Reference to one of the vars
- ;; we're renaming
- (cdr renaming))
- ((and (member form bound-vars)
- (var-same-p form env iterate-env))
- ;; FORM is a var that is bound in this same
- ;; ITERATE, or bound later in this ITERATE*.
- ;; This is a conflict.
- (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
- (second clause)
- form)
- (return-from iterate-transform-body
- :abort))
- (t form))))
- ((and (consp form)
- (eq (first form)
- 'funcall)
- (eq (second form)
- finish-arg)
- (var-same-p (second form) env
- iterate-env))
- ;; (FUNCALL finish-arg) => finish-form
- (unless (null (cddr form))
- (maybe-warn :definition
- "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
- (second clause)
- (cddr form)))
- finish-form)
- (t form)))))
-
-(defun
- parse-declarations
- (tail locals)
-
- ;; Extract the declarations from the head of TAIL and divide them into 2
- ;; classes: declares about variables in the list LOCALS, and all other
- ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL.
- (let
- (localdecls otherdecls form)
- (loop
- (unless (and tail (consp (setq form (car tail)))
- (eq (car form)
- 'declare))
- (return (values localdecls otherdecls tail)))
- (mapc
- #'(lambda
- (decl)
- (case (first decl)
- ((inline notinline optimize)
- ; These don't talk about vars
- (push decl otherdecls))
- (t ; Assume all other kinds are
- ; for vars
- (let* ((vars (if (eq (first decl)
- 'type)
- (cddr decl)
- (cdr decl)))
- (l (intersection locals vars))
- other)
- (cond
- ((null l)
- ; None talk about LOCALS
- (push decl otherdecls))
- ((null (setq other (set-difference vars l)))
- ; All talk about LOCALS
- (push decl localdecls))
- (t ; Some of each
- (let ((head (cons 'type (and (eq (first decl)
- 'type)
- (list (second decl))))))
- (push (append head other)
- otherdecls)
- (push (append head l)
- localdecls))))))))
- (cdr form))
- (pop tail))))
-
-(defun extract-special-bindings (vars decls)
-
- ;; Return the subset of VARS that are special, either globally or
- ;; because of a declaration in DECLS
- (let ((specials (remove-if-not #'var-globally-special-p vars)))
- (dolist (d decls)
- (when (eq (car d)
- 'special)
- (setq specials (union specials (intersection vars
- (cdr d))))))
- specials))
-
-(defun function-lambda-p (form &optional nargs)
-
- ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length
- ;; NARGS, return the lambda expression
- (let (args body)
- (and (consp form)
- (eq (car form)
- 'function)
- (consp (setq form (cdr form)))
- (null (cdr form))
- (consp (setq form (car form)))
- (eq (car form)
- 'lambda)
- (consp (setq body (cdr form)))
- (listp (setq args (car body)))
- (or (null nargs)
- (eql (length args)
- nargs))
- form)))
-
-(defun
- rename-let-bindings
- (let-bindings binding-type env leftover-body &optional tempvarfn)
-
- ;; Perform the alpha conversion required for "LET eversion" of
- ;; (LET[*] LET-BINDINGS . body)--rename each of the variables to an
- ;; internal name. Returns 2 values: a new set of LET bindings and the
- ;; alist of old var names to new (so caller can walk the body doing
- ;; the rest of the renaming). BINDING-TYPE is one of LET or LET*.
- ;; LEFTOVER-BODY is optional list of forms that must be eval'ed
- ;; before the first binding happens. ENV is the macro expansion
- ;; environment, in case we have to walk a LET*. TEMPVARFN is a
- ;; function of no args to return a temporary var; if omitted, we use
- ;; GENSYM.
- (let
- (renamed-vars)
- (values (mapcar #'(lambda (binding)
- (let ((valueform (cond ((not (consp binding))
-
- ; No initial value
- nil)
- ((or (eq binding-type
- 'let)
- (null renamed-vars))
-
- ; All bindings are in parallel,
- ; so none can refer to others
- (second binding))
- (t
- ; In a LET*, have to substitute
- ; vars in the 2nd and
- ; subsequent initialization
- ; forms
- (rename-variables
- (second binding)
- renamed-vars env))))
- (newvar (if tempvarfn
- (funcall tempvarfn)
- (gensym))))
- (push (cons (if (consp binding)
- (first binding)
- binding)
- newvar)
- renamed-vars)
- ; Add new variable to the list
- ; AFTER we have walked the
- ; initial value form
- (when leftover-body
- ;; Previous clause had some computation to do
- ;; after its bindings. Here is the first
- ;; opportunity to do it
- (setq valueform `(progn ,@leftover-body
- ,valueform))
- (setq leftover-body nil))
- (list newvar valueform)))
- let-bindings)
- renamed-vars)))
-
-(defun rename-variables (form alist env)
-
- ;; Walks FORM, renaming occurrences of the key variables in ALIST with
- ;; their corresponding values. ENV is FORM's environment, so we can
- ;; make sure we are talking about the same variables.
- (walk-form form env
- #'(lambda (form context subenv)
- (declare (ignore context))
- (let (pair)
- (cond ((and (symbolp form)
- (setq pair (assoc form alist))
- (var-same-p form subenv env))
- (cdr pair))
- (t form))))))
-
-(defun
- mv-setq
- (vars expr)
-
- ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some
- ;; of the simple cases for benefit of compilers that don't, and I don't care
- ;; what the value is, and I know that the variables need not be set in
- ;; parallel, since they can't be used free in EXPR
- (cond
- ((null vars)
- ; EXPR is a side-effect
- expr)
- ((not (consp vars))
- ; This is an error, but I'll
- ; let MULTIPLE-VALUE-SETQ
- ; report it
- `(multiple-value-setq ,vars ,expr))
- ((and (listp expr)
- (eq (car expr)
- 'values))
-
- ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq
- ;; (psetq returns nil, but I don't care about returned value). Do this
- ;; even for the single variable case so that we catch (mv-setq (a) (values
- ;; x y))
- (pop expr)
- ; VALUES
- `(setq ,@(mapcon #'(lambda (tail)
- (list (car tail)
- (cond ((or (cdr tail)
- (null (cdr expr)))
- ; One result expression for
- ; this var
- (pop expr))
- (t ; More expressions than vars,
- ; so arrange to evaluate all
- ; the rest now.
- (cons 'prog1 expr)))))
- vars)))
- ((null (cdr vars))
- ; Simple one variable case
- `(setq ,(car vars)
- ,expr))
- (t ; General case--I know nothing
- `(multiple-value-setq ,vars ,expr))))
-
-(defun var-same-p (var env1 env2)
- (eq (var-lexical-p var env1)
- (var-lexical-p var env2)))
-
-(defun maybe-warn (type &rest warn-args)
-
- ;; Issue a warning about not being able to optimize this thing. TYPE
- ;; is one of :DEFINITION, meaning the definition is at fault, and
- ;; :USER, meaning the user's code is at fault.
- (when (case *iterate-warnings*
- ((nil) nil)
- ((:user) (eq type :user))
- (t t))
- (apply #'warn warn-args)))
-
-;;; sample iterators
-;;;
-;;; FIXME: If they're only samples, can they be commented out?
-
-(defmacro
- interval
- (&whole whole &key from downfrom to downto above below by type)
- (cond
- ((and from downfrom)
- (error "Can't use both FROM and DOWNFROM in ~S" whole))
- ((cdr (remove nil (list to downto above below)))
- (error "Can't use more than one limit keyword in ~S" whole))
- (t
- (let*
- ((down (or downfrom downto above))
- (limit (or to downto above below))
- (inc (cond ((null by)
- 1)
- ((constantp by)
- ; Can inline this increment
- by))))
- `(let
- ((from ,(or from downfrom 0))
- ,@(and limit `((to ,limit)))
- ,@(and (null inc)
- `((by ,by))))
- ,@(and type `((declare (type ,type from ,@(and limit '(to))
- ,@(and (null inc)
- `(by))))))
- #'(lambda
- (finish)
- ,@(cond ((null limit)
- ; We won't use the FINISH arg.
- '((declare (ignore finish)))))
- (prog1 ,(cond (limit ; Test the limit. If ok,
- ; return current value and
- ; increment, else quit
- `(if (,(cond (above '>)
- (below '<)
- (down '>=)
- (t '<=))
- from to)
- from
- (funcall finish)))
- (t ; No test
- 'from))
- (setq from (,(if down
- '-
- '+)
- from
- ,(or inc 'by))))))))))
-
-(defmacro list-elements (list &key (by '#'cdr))
- `(let ((tail ,list))
- #'(lambda (finish)
- (prog1 (if (endp tail)
- (funcall finish)
- (first tail))
- (setq tail (funcall ,by tail))))))
-
-(defmacro list-tails (list &key (by '#'cdr))
- `(let ((tail ,list))
- #'(lambda (finish)
- (prog1 (if (endp tail)
- (funcall finish)
- tail)
- (setq tail (funcall ,by tail))))))
-
-(defmacro
- elements
- (sequence)
- "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type."
- (let*
- ((type (and (consp sequence)
- (eq (first sequence)
- 'the)
- (second sequence)))
- (accessor (if type
- (sequence-accessor type)
- 'elt))
- (listp (eq type 'list)))
-
- ;; If type is given via THE, we may be able to generate a good accessor here
- ;; for the benefit of implementations that aren't smart about (ELT (THE
- ;; STRING FOO)). I'm not bothering to keep the THE inside the body,
- ;; however, since I assume any compiler that would understand (AREF (THE
- ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I
- ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it.
-
- ;; If sequence is declared to be a list, it's better to cdr down it, so we
- ;; have some extra cases here. Normally folks would write LIST-ELEMENTS,
- ;; but maybe they wanted to get the index for free...
- `(let* ((index 0)
- (s ,sequence)
- ,@(and (not listp)
- '((size (length s)))))
- #'(lambda (finish)
- (values (cond ,(if listp
- '((not (endp s))
- (pop s))
- `((< index size)
- (,accessor s index)))
- (t (funcall finish)))
- (prog1 index
- (setq index (1+ index))))))))
-
-(defmacro
- plist-elements
- (plist)
- "Generates each time 2 items, the indicator and the value."
- `(let ((tail ,plist))
- #'(lambda (finish)
- (values (if (endp tail)
- (funcall finish)
- (first tail))
- (prog1 (if (endp (setq tail (cdr tail)))
- (funcall finish)
- (first tail))
- (setq tail (cdr tail)))))))
-
-(defun sequence-accessor (type)
-
- ;; returns the function with which most efficiently to make accesses to
- ;; a sequence of type TYPE.
- (case (if (consp type)
- ; e.g., (VECTOR FLOAT *)
- (car type)
- type)
- ((array simple-array vector) 'aref)
- (simple-vector 'svref)
- (string 'char)
- (simple-string 'schar)
- (bit-vector 'bit)
- (simple-bit-vector 'sbit)
- (t 'elt)))
-
-;; These "iterators" may be withdrawn
-
-(defmacro eachtime (expr)
- `#'(lambda (finish)
- (declare (ignore finish))
- ,expr))
-
-(defmacro while (expr)
- `#'(lambda (finish)
- (unless ,expr (funcall finish))))
-
-(defmacro until (expr)
- `#'(lambda (finish)
- (when ,expr (funcall finish))))
-
- ; GATHERING macro
-
-(defmacro gathering (clauses &body body &environment env)
- (or (optimize-gathering-form clauses body env)
- (simple-expand-gathering-form clauses body env)))
-
-(defmacro with-gathering (clauses gather-body &body use-body)
- "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
-
- ;; We may optimize this a little better later for those compilers that
- ;; don't do a good job on (m-v-bind vars (... (values ...)) ...).
- `(multiple-value-bind ,(mapcar #'car clauses)
- (gathering ,clauses ,gather-body)
- ,@use-body))
-
-(defun
- simple-expand-gathering-form
- (clauses body env)
- (declare (ignore env))
-
- ;; The "formal semantics" of GATHERING. We use this only in cases that can't
- ;; be optimized.
- (let
- ((acc-names (mapcar #'first (if (symbolp clauses)
- ; Shorthand using anonymous
- ; gathering site
- (setq clauses `((*anonymous-gathering-site*
- (,clauses))))
- clauses)))
- (realizer-names (mapcar #'(lambda (binding)
- (declare (ignore binding))
- (gensym))
- clauses)))
- `(multiple-value-call
- #'(lambda
- ,(mapcan #'list acc-names realizer-names)
- (flet ((gather (value &optional (accumulator *anonymous-gathering-site*)
- )
- (funcall accumulator value)))
- ,@body
- (values ,@(mapcar #'(lambda (rname)
- `(funcall ,rname))
- realizer-names))))
- ,@(mapcar #'second clauses))))
-
-(defvar *active-gatherers* nil
- "List of GATHERING bindings currently active during macro expansion)")
-
-(defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site).")
-
-(defun optimize-gathering-form (clauses body gathering-env)
- (let*
- (acc-info leftover-body top-bindings finish-forms top-decls)
- (dolist (clause (if (symbolp clauses)
- ; a shorthand
- `((*anonymous-gathering-site* (,clauses)))
- clauses))
- (multiple-value-bind
- (let-body binding-type let-bindings localdecls otherdecls extra-body)
- (expand-into-let (second clause)
- 'gathering gathering-env)
- (prog*
- ((acc-var (first clause))
- renamed-vars accumulator realizer)
- (when (and (consp let-body)
- (eq (car let-body)
- 'values)
- (consp (setq let-body (cdr let-body)))
- (setq accumulator (function-lambda-p (car let-body)))
- (consp (setq let-body (cdr let-body)))
- (setq realizer (function-lambda-p (car let-body)
- 0))
- (null (cdr let-body)))
-
- ;; Macro returned something of the form
- ;; (VALUES #'(lambda (value) ...)
- ;; #'(lambda () ...)),
- ;; a function to accumulate values and a function to realize the
- ;; result.
- (when binding-type
-
- ;; Gatherer expanded into a LET
- (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
- (second clause)
- `(declare ,@otherdecls))
- (go punt)))
- (when let-bindings
-
- ;; The first transformation we want to perform is a
- ;; variant of "LET-eversion": turn
- ;; (mv-bind
- ;; (acc real)
- ;; (let (..bindings..)
- ;; (values #'(lambda ...)
- ;; #'(lambda ...)))
- ;; ..body..)
- ;; into
- ;; (let* (..bindings..
- ;; (acc #'(lambda ...))
- ;; (real #'(lambda ...)))
- ;; ..body..).
- ;; This transformation is valid if nothing in body refers
- ;; to any of the bindings, something we can ensure by
- ;; alpha-converting the inner let (substituting new names
- ;; for each var). Of course, none of those vars can be
- ;; special, but we already checked for that above.
- (multiple-value-setq (let-bindings renamed-vars)
- (rename-let-bindings let-bindings binding-type
- gathering-env leftover-body))
- (setq top-bindings (nconc top-bindings let-bindings))
- (setq leftover-body nil)
- ; If there was any leftover
- ; from previous, it is now
- ; consumed
- ))
- (setq leftover-body (nconc leftover-body extra-body))
- ; Computation to do after these
- ; bindings
- (push (cons acc-var (rename-and-capture-variables accumulator
- renamed-vars gathering-env))
- acc-info)
- (setq realizer (rename-variables realizer renamed-vars
- gathering-env))
- (push (cond ((null (cdddr realizer))
- ; Simple (LAMBDA () expr) =>
- ; expr
- (third realizer))
- (t ; There could be declarations
- ; or something, so leave as a
- ; LET
- (cons 'let (cdr realizer))))
- finish-forms)
- (unless (null localdecls)
- ; Declarations about the LET
- ; variables also has to
- ; percolate up
- (setq top-decls (nconc top-decls (sublis renamed-vars
- localdecls))))
- (return))
- (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
- (second clause))
- punt
- (let
- ((gs (gensym))
- (expansion `(multiple-value-list ,(second clause))))
- ; Slow way--bind gensym to the
- ; macro expansion, and we will
- ; funcall it in the body
- (push (list acc-var gs)
- acc-info)
- (push `(funcall (cadr ,gs))
- finish-forms)
- (setq
- top-bindings
- (nconc
- top-bindings
- (list (list gs (cond (leftover-body
- `(progn ,@(prog1 leftover-body
- (setq leftover-body nil))
- ,expansion))
- (t expansion))))))))))
- (setq body (walk-gathering-body body gathering-env acc-info))
- (cond ((eq body :abort)
- ; Couldn't finish expansion
- nil)
- (t `(let* ,top-bindings
- ,@(and top-decls `((declare ,@top-decls)))
- ,body
- ,(cond ((null (cdr finish-forms))
- ; just a single value
- (car finish-forms))
- (t `(values ,@(reverse finish-forms)))))))))
-
-(defun rename-and-capture-variables (form alist env)
-
- ;; Walks FORM, renaming occurrences of the key variables in ALIST with
- ;; their corresponding values, and capturing any other free variables.
- ;; Returns a list of the new form and the list of other closed-over
- ;; vars. ENV is FORM's environment, so we can make sure we are talking
- ;; about the same variables.
- (let (closed)
- (list (walk-form
- form env
- #'(lambda (form context subenv)
- (declare (ignore context))
- (let (pair)
- (cond ((or (not (symbolp form))
- (not (var-same-p form subenv env)))
- ; non-variable or one that has
- ; been rebound
- form)
- ((setq pair (assoc form alist))
- ; One to rename
- (cdr pair))
- (t ; var is free
- (pushnew form closed)
- form)))))
- closed)))
-
-(defun
- walk-gathering-body
- (body gathering-env acc-info)
-
- ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV.
- ;; ACC-INFO is a list of information about each of the gathering "bindings"
- ;; in the form, in the form (var gatheringfn freevars env)
- (let
- ((*active-gatherers* (nconc (mapcar #'car acc-info)
- *active-gatherers*)))
-
- ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER
- ;; targets. This is so that when we encounter a GATHER not belonging to us
- ;; we can know whether to warn about it.
- (walk-form
- (cons 'progn body)
- gathering-env
- #'(lambda
- (form context env)
- (declare (ignore context))
- (let (info site)
- (cond ((consp form)
- (cond
- ((not (eq (car form)
- 'gather))
- ; We only care about GATHER
- (when (and (eq (car form)
- 'function)
- (eq (cadr form)
- 'gather))
- ; Passed as functional--can't
- ; macroexpand
- (maybe-warn :user
- "Can't optimize GATHERING because of reference to #'GATHER."
- )
- (return-from walk-gathering-body :abort))
- form)
- ((setq info (assoc (setq site (if (null (cddr form))
-
- '
- *anonymous-gathering-site*
- (third form)))
- acc-info))
- ; One of ours--expand (GATHER
- ; value var). INFO = (var
- ; gatheringfn freevars env)
- (unless (null (cdddr form))
- (warn "Extra arguments (> 2) in ~S discarded." form)
- )
- (let ((fn (second info)))
- (cond ((symbolp fn)
- ; Unoptimized case--just call
- ; the gatherer. FN is the
- ; gensym that we bound to the
- ; list of two values returned
- ; from the gatherer.
- `(funcall (car ,fn)
- ,(second form)))
- (t ; FN = (lambda (value) ...)
- (dolist (s (third info))
- (unless (or (var-same-p s env
- gathering-env)
- (and (var-special-p
- s env)
- (var-special-p
- s gathering-env)))
-
- ;; Some var used free in the LAMBDA form has been
- ;; rebound between here and the parent GATHERING
- ;; form, so can't substitute the lambda. Ok if it's
- ;; a special reference both here and in the LAMBDA,
- ;; because then it's not closed over.
- (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
- s)
- (return-from walk-gathering-body
- :abort)))
-
- ;; Return ((lambda (value) ...) actual-value). In
- ;; many cases we could simplify this further by
- ;; substitution, but we'd have to be careful (for
- ;; example, we would need to alpha-convert any LET
- ;; we found inside). Any decent compiler will do it
- ;; for us.
- (list fn (second form))))))
- ((and (setq info (member site *active-gatherers*))
- (or (eq site '*anonymous-gathering-site*)
- (var-same-p site env (fourth info))))
- ; Some other GATHERING will
- ; take care of this form, so
- ; pass it up for now.
- ; Environment check is to make
- ; sure nobody shadowed it
- ; between here and there
- form)
- (t ; Nobody's going to handle it
- (if (eq site '*anonymous-gathering-site*)
- ; More likely that she forgot
- ; to mention the site than
- ; forget to write an anonymous
- ; gathering.
- (warn "There is no gathering site specified in ~S."
- form)
- (warn
- "The site ~S in ~S is not defined in an enclosing GATHERING form."
- site form))
- ; Turn it into something else
- ; so we don't warn twice in the
- ; nested case
- `(%orphaned-gather ,@(cdr form)))))
- ((and (symbolp form)
- (setq info (assoc form acc-info))
- (var-same-p form env gathering-env))
- ; A variable reference to a
- ; gather binding from
- ; environment TEM
- (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
- form)
- (return-from walk-gathering-body :abort))
- (t form)))))))
-
-;; sample gatherers
-;;
-;; FIXME: If these are only samples, can we delete them?
-
-(defmacro
- collecting
- (&key initial-value)
- `(let* ((head ,initial-value)
- (tail ,(and initial-value `(last head))))
- (values #'(lambda (value)
- (if (null head)
- (setq head (setq tail (list value)))
- (setq tail (cdr (rplacd tail (list value))))))
- #'(lambda nil head))))
-
-(defmacro joining (&key initial-value)
- `(let ((result ,initial-value))
- (values #'(lambda (value)
- (setq result (nconc result value)))
- #'(lambda nil result))))
-
-(defmacro
- maximizing
- (&key initial-value)
- `(let ((result ,initial-value))
- (values
- #'(lambda (value)
- (when ,(cond ((and (constantp initial-value)
- (not (null (eval initial-value))))
- ; Initial value is given and we
- ; know it's not NIL, so leave
- ; out the null check
- '(> value result))
- (t '(or (null result)
- (> value result))))
- (setq result value)))
- #'(lambda nil result))))
-
-(defmacro
- minimizing
- (&key initial-value)
- `(let ((result ,initial-value))
- (values
- #'(lambda (value)
- (when ,(cond ((and (constantp initial-value)
- (not (null (eval initial-value))))
- ; Initial value is given and we
- ; know it's not NIL, so leave
- ; out the null check
- '(< value result))
- (t '(or (null result)
- (< value result))))
- (setq result value)))
- #'(lambda nil result))))
-
-(defmacro summing (&key (initial-value 0))
- `(let ((sum ,initial-value))
- (values #'(lambda (value)
- (setq sum (+ sum value)))
- #'(lambda nil sum))))
-
-;;; It's easier to read expanded code if PROG1 gets left alone.
-(define-walker-template prog1 (nil return sb-walker::repeat (eval)))
projects / sbcl.git / commitdiff