-;;; 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
- (gathering1 (collecting)
- (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
- (gather1 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))))
-