;it is possible to manipulate
;anonymous constructors also.
- (code-type ;The type of code currently in
- :initform nil ;use by this constructor. This
- :accessor constructor-code-type) ;is mostly for debugging and
- ;analysis purposes.
- ;The lazy installer sets this
- ;to LAZY. The most basic and
- ;least optimized type of code
- ;is called FALLBACK.
-
(supplied-initarg-names ;The names of the initargs this
:initarg :supplied-initarg-names ;constructor supplies when it
:reader ;"calls" make-instance.
(defmethod describe-object ((constructor constructor) stream)
(format stream
- "~S is a constructor for the class ~S.~%~
- The current code type is ~S.~%~
- Other possible code types are ~S."
- constructor (constructor-class constructor)
- (constructor-code-type constructor)
- (let ((collect nil))
- (doplist (key val) (constructor-code-generators constructor)
- (push key collect))
- (nreverse collect))))
+ "~S is a constructor for the class ~S.~%"
+ constructor (constructor-class constructor)))
\f
;;;; Here is the actual smarts for making the code generators and then
;;;; trying each generator to get constructor code. This extensible
;;;; 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
;;;; 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* ())
-
-(defmacro define-constructor-code-type (type arglist &body body)
- (let ((fn-name (intern (format nil
- "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
- (package-name (symbol-package type))
- (symbol-name type))
- *pcl-package*)))
- `(progn
- (defun ,fn-name ,arglist .,body)
- (load-define-constructor-code-type ',type ',fn-name))))
-
-(defun load-define-constructor-code-type (type generator)
- (let ((old-entry (assq type *constructor-code-types*)))
- (if old-entry
- (setf (cadr old-entry) generator)
- (push (list type generator) *constructor-code-types*))
- type))
+;;;; generators are called in reverse order of definition, so 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.
\f
;;;; helper functions and utilities that are shared by all of the code
;;;; types
(notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
(equal '(:after) (method-qualifiers m))))
methods))
-
-;;; This returns two values. The first is a vector which can be used as the
-;;; initial value of the slots vector for the instance. The second is a symbol
-;;; describing the initforms this class has.
-;;;
-;;; If the first value is:
-;;;
-;;; :UNSUPPLIED no slot has an initform
-;;; :CONSTANTS all slots have either a constant initform
-;;; or no initform at all
-;;; T there is at least one non-constant initform
-(defun compute-constant-vector (class)
- ;;(declare (values constants flag))
- (let* ((wrapper (class-wrapper class))
- (layout (wrapper-instance-slots-layout wrapper))
- (flag :unsupplied)
- (constants ()))
- (dolist (slotd (class-slots class))
- (let ((name (slot-definition-name slotd))
- (initform (slot-definition-initform slotd))
- (initfn (slot-definition-initfunction slotd)))
- (cond ((null (memq name layout)))
- ((null initfn)
- (push (cons name +slot-unbound+) constants))
- ((constantp initform)
- (push (cons name (eval initform)) constants)
- (when (eq flag ':unsupplied) (setq flag ':constants)))
- (t
- (push (cons name +slot-unbound+) constants)
- (setq flag t)))))
- (let* ((constants-alist (sort constants #'(lambda (x y)
- (memq (car y)
- (memq (car x) layout)))))
- (constants-list (mapcar #'cdr constants-alist)))
- (values constants-list flag))))
-
-;;; This takes a class and a list of initarg-names, and returns an alist
-;;; indicating the positions of the slots those initargs may fill. The
-;;; order of the initarg-names argument is important of course, since we
-;;; have to respect the rules about the leftmost initarg that fills a slot
-;;; having precedence. This function allows initarg names to appear twice
-;;; in the list, it only considers the first appearance.
-(defun compute-initarg-positions (class initarg-names)
- (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
- (positions
- (loop for slot-name in layout
- for position from 0
- collect (cons slot-name position)))
- (slot-initargs
- (mapcar #'(lambda (slotd)
- (list (slot-definition-initargs slotd)
- (or (cdr (assq (slot-definition-name slotd)
- positions))
- ':class)))
- (class-slots class))))
- ;; Go through each of the initargs, and figure out what position
- ;; it fills by replacing the entries in slot-initargs it fills.
- (dolist (initarg initarg-names)
- (dolist (slot-entry slot-initargs)
- (let ((slot-initargs (car slot-entry)))
- (when (and (listp slot-initargs)
- (not (null slot-initargs))
- (memq initarg slot-initargs))
- (setf (car slot-entry) initarg)))))
- (let (collect)
- (dolist (initarg initarg-names)
- (let ((positions (let (collect)
- (dolist (slot-entry slot-initargs)
- (when (eq (car slot-entry) initarg)
- (push (cadr slot-entry) collect)))
- (nreverse collect))))
- (when positions
- (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.
-(define-constructor-code-type fallback
- (class name arglist supplied-initarg-names supplied-initargs)
- (declare (ignore name supplied-initarg-names))
- `(function
- (lambda (&rest ignore)
- (declare (ignore ignore))
- (function
- (sb-kernel:instance-lambda ,arglist
- (make-instance
- ',(class-name class)
- ,@(let (collect)
- (loop for tail on supplied-initargs by #'cddr
- do (push `',(car tail) collect)
- (push (cadr tail) collect))
- (nreverse collect))))))))
-\f
-;;; The GENERAL case allows:
-;;; constant, unsupplied or non-constant initforms
-;;; constant or non-constant default initargs
-;;; supplied initargs
-;;; slot-filling initargs
-;;; :after methods on shared-initialize and initialize-instance
-(define-constructor-code-type general
- (class name arglist supplied-initarg-names supplied-initargs)
- (declare (ignore name))
- (let ((raw-allocator (raw-instance-allocator class))
- (slots-fetcher (slots-fetcher class)))
- `(function
- (lambda (class .wrapper. defaults init shared)
- (multiple-value-bind (.constants.
- .constant-initargs.
- .initfns-initargs-and-positions.
- .supplied-initarg-positions.
- .shared-initfns.
- .initfns.)
- (general-generator-internal class
- defaults
- init
- shared
- ',supplied-initarg-names
- ',supplied-initargs)
- .supplied-initarg-positions.
- (when (and .constants.
- (null (non-pcl-or-after-initialize-instance-methods-p
- init))
- (null (non-pcl-or-after-shared-initialize-methods-p
- shared)))
- (function
- (sb-kernel:instance-lambda ,arglist
- (declare #.*optimize-speed*)
- (let* ((.instance. (,raw-allocator .wrapper. .constants.))
- (.slots. (,slots-fetcher .instance.))
- (.positions. .supplied-initarg-positions.)
- (.initargs. .constant-initargs.))
- .positions.
-
- (dolist (entry .initfns-initargs-and-positions.)
- (let ((val (funcall (car entry)))
- (initarg (cadr entry)))
- (when initarg
- (push val .initargs.)
- (push initarg .initargs.))
- (dolist (pos (cddr entry))
- (setf (clos-slots-ref .slots. pos) val))))
-
- ,@(let (collect)
- (doplist (initarg value) supplied-initargs
- (unless (constantp value)
- (push `(let ((.value. ,value))
- (push .value. .initargs.)
- (push ',initarg .initargs.)
- (dolist (.p. (pop .positions.))
- (setf (clos-slots-ref .slots. .p.)
- .value.)))
- collect)))
- (nreverse collect))
-
- (dolist (fn .shared-initfns.)
- (apply fn .instance. t .initargs.))
- (dolist (fn .initfns.)
- (apply fn .instance. .initargs.))
-
- .instance.)))))))))
-
-(defun general-generator-internal
- (class defaults init shared supplied-initarg-names supplied-initargs)
- (flet ((bail-out () (return-from general-generator-internal nil)))
- (let* ((constants (compute-constant-vector class))
- (layout (wrapper-instance-slots-layout (class-wrapper class)))
- (initarg-positions
- (compute-initarg-positions class
- (append supplied-initarg-names
- (mapcar #'car defaults))))
- (initfns-initargs-and-positions ())
- (supplied-initarg-positions ())
- (constant-initargs ())
- (used-positions ()))
-
- ;; Go through each of the supplied initargs for three reasons.
- ;;
- ;; - If it fills a class slot, bail out.
- ;; - If its a constant form, fill the constant vector.
- ;; - Otherwise remember the positions no two initargs
- ;; will try to fill the same position, since compute
- ;; initarg positions already took care of that, but
- ;; we do need to know what initforms will and won't
- ;; be needed.
- (doplist (initarg val) supplied-initargs
- (let ((positions (cdr (assq initarg initarg-positions))))
- (cond ((memq :class positions) (bail-out))
- ((constantp val)
- (setq val (eval val))
- (push val constant-initargs)
- (push initarg constant-initargs)
- (dolist (pos positions) (setf (svref constants pos) val)))
- (t
- (push positions supplied-initarg-positions)))
- (setq used-positions (append positions used-positions))))
-
- ;; Go through each of the default initargs, for three reasons.
- ;;
- ;; - If it fills a class slot, bail out.
- ;; - If it is a constant, and it does fill a slot, put that
- ;; into the constant vector.
- ;; - If it isn't a constant, record its initfn and position.
- (dolist (default defaults)
- (let* ((name (car default))
- (initfn (cadr default))
- (form (caddr default))
- (value ())
- (positions (cdr (assq name initarg-positions))))
- (unless (memq name supplied-initarg-names)
- (cond ((memq :class positions) (bail-out))
- ((constantp form)
- (setq value (eval form))
- (push value constant-initargs)
- (push name constant-initargs)
- (dolist (pos positions)
- (setf (svref constants pos) value)))
- (t
- (push (list* initfn name positions)
- initfns-initargs-and-positions)))
- (setq used-positions (append positions used-positions)))))
-
- ;; Go through each of the slot initforms:
- ;;
- ;; - If its position has already been filled, do nothing.
- ;; The initfn won't need to be called, and the slot won't
- ;; need to be touched.
- ;; - If it is a class slot, and has an initform, bail out.
- ;; - If its a constant or unsupplied, ignore it, it is
- ;; already in the constant vector.
- ;; - Otherwise, record its initfn and position
- (dolist (slotd (class-slots class))
- (let* ((alloc (slot-definition-allocation slotd))
- (name (slot-definition-name slotd))
- (form (slot-definition-initform slotd))
- (initfn (slot-definition-initfunction slotd))
- (position (position name layout)))
- (cond ((neq alloc :instance)
- (unless (null initfn)
- (bail-out)))
- ((member position used-positions))
- ((or (constantp form)
- (null initfn)))
- (t
- (push (list initfn nil position)
- initfns-initargs-and-positions)))))
-
- (values constants
- constant-initargs
- (nreverse initfns-initargs-and-positions)
- (nreverse supplied-initarg-positions)
- (mapcar #'method-function
- (remove *standard-shared-initialize-method* shared))
- (mapcar #'method-function
- (remove *standard-initialize-instance-method* init))))))
-\f
-;;; The NO-METHODS case allows:
-;;; constant, unsupplied or non-constant initforms
-;;; constant or non-constant default initargs
-;;; supplied initargs that are arguments to constructor, or constants
-;;; slot-filling initargs
-(define-constructor-code-type no-methods
- (class name arglist supplied-initarg-names supplied-initargs)
- (declare (ignore name))
- (let ((raw-allocator (raw-instance-allocator class))
- (slots-fetcher (slots-fetcher class)))
- `(function
- (lambda (class .wrapper. defaults init shared)
- (multiple-value-bind (.constants.
- .initfns-and-positions.
- .supplied-initarg-positions.)
- (no-methods-generator-internal class
- defaults
- ',supplied-initarg-names
- ',supplied-initargs)
- .initfns-and-positions.
- .supplied-initarg-positions.
- (when (and .constants.
- (null (non-pcl-initialize-instance-methods-p init))
- (null (non-pcl-shared-initialize-methods-p shared)))
- #'(sb-kernel:instance-lambda ,arglist
- (declare #.*optimize-speed*)
- (let* ((.instance. (,raw-allocator .wrapper. .constants.))
- (.slots. (,slots-fetcher .instance.))
- (.positions. .supplied-initarg-positions.))
- .positions.
-
- (dolist (entry .initfns-and-positions.)
- (let ((val (funcall (car entry))))
- (dolist (pos (cdr entry))
- (setf (clos-slots-ref .slots. pos) val))))
-
- ,@(let (collect)
- (doplist (initarg value) supplied-initargs
- (unless (constantp value)
- (push
- `(let ((.value. ,value))
- (dolist (.p. (pop .positions.))
- (setf (clos-slots-ref .slots. .p.)
- .value.)))
- collect)))
- (nreverse collect))
-
- .instance.))))))))
-
-(defun no-methods-generator-internal
- (class defaults supplied-initarg-names supplied-initargs)
- (flet ((bail-out () (return-from no-methods-generator-internal nil)))
- (let* ((constants (compute-constant-vector class))
- (layout (wrapper-instance-slots-layout (class-wrapper class)))
- (initarg-positions
- (compute-initarg-positions class
- (append supplied-initarg-names
- (mapcar #'car defaults))))
- (initfns-and-positions ())
- (supplied-initarg-positions ())
- (used-positions ()))
-
- ;; Go through each of the supplied initargs for three reasons.
- ;;
- ;; - If it fills a class slot, bail out.
- ;; - If its a constant form, fill the constant vector.
- ;; - Otherwise remember the positions, no two initargs
- ;; will try to fill the same position, since compute
- ;; initarg positions already took care of that, but
- ;; we do need to know what initforms will and won't
- ;; be needed.
- (doplist (initarg val) supplied-initargs
- (let ((positions (cdr (assq initarg initarg-positions))))
- (cond ((memq :class positions) (bail-out))
- ((constantp val)
- (setq val (eval val))
- (dolist (pos positions)
- (setf (svref constants pos) val)))
- (t
- (push positions supplied-initarg-positions)))
- (setq used-positions (append positions used-positions))))
-
- ;; Go through each of the default initargs, for three reasons.
- ;;
- ;; - If it fills a class slot, bail out.
- ;; - If it is a constant, and it does fill a slot, put that
- ;; into the constant vector.
- ;; - If it isn't a constant, record its initfn and position.
- (dolist (default defaults)
- (let* ((name (car default))
- (initfn (cadr default))
- (form (caddr default))
- (value ())
- (positions (cdr (assq name initarg-positions))))
- (unless (memq name supplied-initarg-names)
- (cond ((memq :class positions) (bail-out))
- ((constantp form)
- (setq value (eval form))
- (dolist (pos positions)
- (setf (svref constants pos) value)))
- (t
- (push (cons initfn positions)
- initfns-and-positions)))
- (setq used-positions (append positions used-positions)))))
-
- ;; Go through each of the slot initforms:
- ;;
- ;; - If its position has already been filled, do nothing.
- ;; The initfn won't need to be called, and the slot won't
- ;; need to be touched.
- ;; - If it is a class slot, and has an initform, bail out.
- ;; - If its a constant or unsupplied, do nothing, we know
- ;; that it is already in the constant vector.
- ;; - Otherwise, record its initfn and position
- (dolist (slotd (class-slots class))
- (let* ((alloc (slot-definition-allocation slotd))
- (name (slot-definition-name slotd))
- (form (slot-definition-initform slotd))
- (initfn (slot-definition-initfunction slotd))
- (position (position name layout)))
- (cond ((neq alloc :instance)
- (unless (null initfn)
- (bail-out)))
- ((member position used-positions))
- ((or (constantp form)
- (null initfn)))
- (t
- (push (list initfn position) initfns-and-positions)))))
-
- (values constants
- (nreverse initfns-and-positions)
- (nreverse supplied-initarg-positions)))))
-\f
-;;; The SIMPLE-SLOTS case allows:
-;;; constant or unsupplied initforms
-;;; constant default initargs
-;;; supplied initargs
-;;; slot filling initargs
-(define-constructor-code-type simple-slots
- (class name arglist supplied-initarg-names supplied-initargs)
- (declare (ignore name))
- (let ((raw-allocator (raw-instance-allocator class))
- (slots-fetcher (slots-fetcher class)))
- `(function
- (lambda (class .wrapper. defaults init shared)
- (when (and (null (non-pcl-initialize-instance-methods-p init))
- (null (non-pcl-shared-initialize-methods-p shared)))
- (multiple-value-bind (.constants. .supplied-initarg-positions.)
- (simple-slots-generator-internal class
- defaults
- ',supplied-initarg-names
- ',supplied-initargs)
- (when .constants.
- (function
- (sb-kernel:instance-lambda ,arglist
- (declare #.*optimize-speed*)
- (let* ((.instance. (,raw-allocator .wrapper. .constants.))
- (.slots. (,slots-fetcher .instance.))
- (.positions. .supplied-initarg-positions.))
- .positions.
-
- ,@(let (collect)
- (doplist (initarg value) supplied-initargs
- (unless (constantp value)
- (push
- `(let ((.value. ,value))
- (dolist (.p. (pop .positions.))
- (setf (clos-slots-ref .slots. .p.)
- .value.)))
- collect)))
- (nreverse collect))
-
- .instance.))))))))))
-
-(defun simple-slots-generator-internal
- (class defaults supplied-initarg-names supplied-initargs)
- (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
- (let* ((constants (compute-constant-vector class))
- (layout (wrapper-instance-slots-layout (class-wrapper class)))
- (initarg-positions
- (compute-initarg-positions class
- (append supplied-initarg-names
- (mapcar #'car defaults))))
- (supplied-initarg-positions ())
- (used-positions ()))
-
- ;; Go through each of the supplied initargs for three reasons.
- ;;
- ;; - If it fills a class slot, bail out.
- ;; - If its a constant form, fill the constant vector.
- ;; - Otherwise remember the positions, no two initargs
- ;; will try to fill the same position, since compute
- ;; initarg positions already took care of that, but
- ;; we do need to know what initforms will and won't
- ;; be needed.
- (doplist (initarg val) supplied-initargs
- (let ((positions (cdr (assq initarg initarg-positions))))
- (cond ((memq :class positions) (bail-out))
- ((constantp val)
- (setq val (eval val))
- (dolist (pos positions)
- (setf (svref constants pos) val)))
- (t
- (push positions supplied-initarg-positions)))
- (setq used-positions (append used-positions positions))))
-
- ;; Go through each of the default initargs for three reasons.
- ;;
- ;; - If it isn't a constant form, bail out.
- ;; - If it fills a class slot, bail out.
- ;; - If it is a constant, and it does fill a slot, put that
- ;; into the constant vector.
- (dolist (default defaults)
- (let* ((name (car default))
- (form (caddr default))
- (value ())
- (positions (cdr (assq name initarg-positions))))
- (unless (memq name supplied-initarg-names)
- (cond ((memq :class positions) (bail-out))
- ((not (constantp form))
- (bail-out))
- (t
- (setq value (eval form))
- (dolist (pos positions)
- (setf (svref constants pos) value)))))))
-
- ;; Go through each of the slot initforms:
- ;;
- ;; - If its position has already been filled, do nothing.
- ;; The initfn won't need to be called, and the slot won't
- ;; need to be touched, we are OK.
- ;; - If it has a non-constant initform, bail-out. This
- ;; case doesn't handle those.
- ;; - If it has a constant or unsupplied initform we don't
- ;; really need to do anything, the value is in the
- ;; constants vector.
- (dolist (slotd (class-slots class))
- (let* ((alloc (slot-definition-allocation slotd))
- (name (slot-definition-name slotd))
- (form (slot-definition-initform slotd))
- (initfn (slot-definition-initfunction slotd))
- (position (position name layout)))
- (cond ((neq alloc :instance)
- (unless (null initfn)
- (bail-out)))
- ((member position used-positions))
- ((or (constantp form)
- (null initfn)))
- (t
- (bail-out)))))
-
- (values constants (nreverse supplied-initarg-positions)))))
projects / sbcl.git / commitdiff