;;; When the optimized function is computed, the function of the
;;; funcallable instance is set to it.
;;;
-(sb-kernel:!defstruct-with-alternate-metaclass ctor
+(!defstruct-with-alternate-metaclass ctor
:slot-names (function-name class-name class initargs)
:boa-constructor %make-ctor
:superclass-name pcl-funcallable-instance
- :metaclass-name sb-kernel:random-pcl-class
- :metaclass-constructor sb-kernel:make-random-pcl-class
- :dd-type sb-kernel:funcallable-structure
+ :metaclass-name random-pcl-classoid
+ :metaclass-constructor make-random-pcl-classoid
+ :dd-type funcallable-structure
:runtime-type-checks-p nil)
;;; List of all defined ctors.
(defun install-initial-constructor (ctor &key force-p)
(when (or force-p (ctor-class ctor))
(setf (ctor-class ctor) nil)
- (setf (sb-kernel:funcallable-instance-fun ctor)
- #'(sb-kernel:instance-lambda (&rest args)
+ (setf (funcallable-instance-fun ctor)
+ #'(instance-lambda (&rest args)
(install-optimized-constructor ctor)
(apply ctor args)))
- (setf (sb-kernel:%funcallable-instance-info ctor 1)
+ (setf (%funcallable-instance-info ctor 1)
(ctor-function-name ctor))))
;;;
(function-name (make-ctor-function-name class-name initargs)))
;;
;; Prevent compiler warnings for calling the ctor.
- (sb-kernel:proclaim-as-fun-name function-name)
- (sb-kernel:note-name-defined function-name :function)
+ (proclaim-as-fun-name function-name)
+ (note-name-defined function-name :function)
(when (eq (info :function :where-from function-name) :assumed)
(setf (info :function :where-from function-name) :defined)
(when (info :function :assumed-type function-name)
(finalize-inheritance class))
(setf (ctor-class ctor) class)
(pushnew ctor (plist-value class 'ctors))
- (setf (sb-kernel:funcallable-instance-fun ctor)
+ (setf (funcallable-instance-fun ctor)
;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL
;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't
;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA
(or (and (not (structure-class-p class))
(null (cdr make-instance-methods))
(null (cdr allocate-instance-methods))
- (check-initargs-1 class (plist-keys (ctor-initargs ctor))
- (append ii-methods si-methods) nil nil)
+ (null (check-initargs-1 class (plist-keys (ctor-initargs ctor))
+ (append ii-methods si-methods) nil nil))
(not (around-or-nonstandard-primary-method-p
ii-methods *the-system-ii-method*))
(not (around-or-nonstandard-primary-method-p
(defun fallback-generator (ctor ii-methods si-methods)
(declare (ignore ii-methods si-methods))
- `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor)
+ `(instance-lambda ,(make-ctor-parameter-list ctor)
(make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))))
(defun optimizing-generator (ctor ii-methods si-methods)
(multiple-value-bind (body before-method-p)
(fake-initialization-emf ctor ii-methods si-methods)
- `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor)
+ `(instance-lambda ,(make-ctor-parameter-list ctor)
(declare #.*optimize-speed*)
,(wrap-in-allocate-forms ctor body before-method-p))))
`(let ((.instance. (%make-standard-instance nil
(get-instance-hash-code)))
(.slots. (make-array
- ,(sb-kernel:layout-length wrapper)
+ ,(layout-length wrapper)
,@(when before-method-p
'(:initial-element +slot-unbound+)))))
(setf (std-instance-wrapper .instance.) ,wrapper)
(multiple-value-bind (si-around si-before si-primary si-after)
(standard-sort-methods si-methods)
(declare (ignore si-primary))
- (assert (and (null ii-around) (null si-around)))
+ (aver (and (null ii-around) (null si-around)))
(let ((initargs (ctor-initargs ctor))
(slot-inits (slot-init-forms ctor (or ii-before si-before))))
(values
(initargs (ctor-initargs ctor))
(initkeys (plist-keys initargs))
(slot-vector
- (make-array (sb-kernel:layout-length (class-wrapper class))
+ (make-array (layout-length (class-wrapper class))
:initial-element nil))
(class-inits ())
+ (default-inits ())
(default-initargs (class-default-initargs class))
(initarg-locations
(compute-initarg-locations
class (append initkeys (mapcar #'car default-initargs)))))
(labels ((initarg-locations (initarg)
(cdr (assoc initarg initarg-locations :test #'eq)))
-
+ (initializedp (location)
+ (cond
+ ((consp location)
+ (assoc location class-inits :test #'eq))
+ ((integerp location)
+ (not (null (aref slot-vector location))))
+ (t (bug "Weird location in ~S" 'slot-init-forms))))
(class-init (location type val)
- (assert (consp location))
- (unless (assoc location class-inits :test #'eq)
+ (aver (consp location))
+ (unless (initializedp location)
(push (list location type val) class-inits)))
-
(instance-init (location type val)
- (assert (integerp location))
- (assert (not (instance-slot-initialized-p location)))
- (setf (aref slot-vector location) (list type val)))
-
- (instance-slot-initialized-p (location)
- (not (null (aref slot-vector location)))))
- ;;
+ (aver (integerp location))
+ (unless (initializedp location)
+ (setf (aref slot-vector location) (list type val))))
+ (default-init-var-name (i)
+ (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
+ (if (array-in-bounds-p ps i)
+ (aref ps i)
+ (intern (format nil ".D~D." i) *the-pcl-package*)))))
;; Loop over supplied initargs and values and record which
;; instance and class slots they initialize.
(loop for (key value) on initargs by #'cddr
(if (consp location)
(class-init location 'param value)
(instance-init location 'param value)))))
- ;;
;; Loop over default initargs of the class, recording
;; initializations of slots that have not been initialized
- ;; above.
- (loop for (key initfn initform) in default-initargs do
- (unless (member key initkeys :test #'eq)
- (if (constantp initform)
- (dolist (location (initarg-locations key))
- (if (consp location)
- (class-init location 'constant initform)
- (instance-init location 'constant initform)))
- (dolist (location (initarg-locations key))
- (if (consp location)
- (class-init location 'initfn initfn)
- (instance-init location 'initfn initfn))))))
- ;;
+ ;; above. Default initargs which are not in the supplied
+ ;; initargs are treated as if they were appended to supplied
+ ;; initargs, that is, their values must be evaluated even
+ ;; if not actually used for initializing a slot.
+ (loop for (key initfn initform) in default-initargs and i from 0
+ unless (member key initkeys :test #'eq) do
+ (let* ((type (if (constantp initform) 'constant 'var))
+ (init (if (eq type 'var) initfn initform)))
+ (when (eq type 'var)
+ (let ((init-var (default-init-var-name i)))
+ (setq init init-var)
+ (push (cons init-var initfn) default-inits)))
+ (dolist (location (initarg-locations key))
+ (if (consp location)
+ (class-init location type init)
+ (instance-init location type init)))))
;; Loop over all slots of the class, filling in the rest from
;; slot initforms.
(loop for slotd in (class-slots class)
as initform = (slot-definition-initform slotd) do
(unless (or (eq allocation :class)
(null initfn)
- (instance-slot-initialized-p location))
+ (initializedp location))
(if (constantp initform)
(instance-init location 'initform initform)
(instance-init location 'initform/initfn initfn))))
- ;;
;; Generate the forms for initializing instance and class slots.
(let ((instance-init-forms
(loop for slot-entry across slot-vector and i from 0
((nil)
(unless before-method-p
`(setf (clos-slots-ref .slots. ,i) +slot-unbound+)))
- (param
+ ((param var)
`(setf (clos-slots-ref .slots. ,i) ,value))
(initfn
`(setf (clos-slots-ref .slots. ,i) (funcall ,value)))
(loop for (location type value) in class-inits collect
`(setf (cdr ',location)
,(ecase type
- (constant `',(eval value))
- (param `,value)
- (initfn `(funcall ,value)))))))
- `(progn
- ,@(delete nil instance-init-forms)
- ,@class-init-forms)))))
+ (constant `',(eval value))
+ ((param var) `,value)
+ (initfn `(funcall ,value)))))))
+ (multiple-value-bind (vars bindings)
+ (loop for (var . initfn) in (nreverse default-inits)
+ collect var into vars
+ collect `(,var (funcall ,initfn)) into bindings
+ finally (return (values vars bindings)))
+ `(let ,bindings
+ (declare (ignorable ,@vars))
+ ,@(delete nil instance-init-forms)
+ ,@class-init-forms))))))
;;;
;;; Return an alist of lists (KEY LOCATION ...) telling, for each
;;; *******************************
(defun update-ctors (reason &key class name generic-function method)
- (flet ((reset-class-ctors (class)
- (loop for ctor in (plist-value class 'ctors) do
- (install-initial-constructor ctor))))
+ (labels ((reset (class &optional ri-cache-p (ctorsp t))
+ (when ctorsp
+ (dolist (ctor (plist-value class 'ctors))
+ (install-initial-constructor ctor)))
+ (when ri-cache-p
+ (setf (plist-value class 'ri-initargs) ()))
+ (dolist (subclass (class-direct-subclasses class))
+ (reset subclass ri-cache-p ctorsp))))
(ecase reason
;;
;; CLASS must have been specified.
(finalize-inheritance
- (reset-class-ctors class))
+ (reset class t))
;;
;; NAME must have been specified.
(setf-find-class
(loop for ctor in *all-ctors*
when (eq (ctor-class-name ctor) name) do
(when (ctor-class ctor)
- (reset-class-ctors (ctor-class ctor)))
+ (reset (ctor-class ctor)))
(loop-finish)))
;;
;; GENERIC-FUNCTION and METHOD must have been specified.
((add-method remove-method)
- (case (generic-function-name generic-function)
- ((make-instance allocate-instance initialize-instance
- shared-initialize)
- (let ((type (first (method-specializers method))))
- (reset-class-ctors (type-class type)))))))))
+ (flet ((class-of-1st-method-param (method)
+ (type-class (first (method-specializers method)))))
+ (case (generic-function-name generic-function)
+ ((make-instance allocate-instance
+ initialize-instance shared-initialize)
+ (reset (class-of-1st-method-param method) t t))
+ ((reinitialize-instance)
+ (reset (class-of-1st-method-param method) t nil))))))))
(defun precompile-ctors ()
(dolist (ctor *all-ctors*)
(when (and class (class-finalized-p class))
(install-optimized-constructor ctor))))))
+(defun check-ri-initargs (instance initargs)
+ (let* ((class (class-of instance))
+ (keys (plist-keys initargs))
+ (cached (assoc keys (plist-value class 'ri-initargs)
+ :test #'equal))
+ (invalid-keys
+ (if (consp cached)
+ (cdr cached)
+ (let ((invalid
+ ;; FIXME: give CHECK-INITARGS-1 and friends a
+ ;; more mnemonic name and (possibly) a nicer,
+ ;; more orthogonal interface.
+ (check-initargs-1
+ class initargs
+ (list (list* 'reinitialize-instance instance initargs)
+ (list* 'shared-initialize instance nil initargs))
+ t nil)))
+ (setf (plist-value class 'ri-initargs)
+ (acons keys invalid cached))
+ invalid))))
+ (when invalid-keys
+ (error 'initarg-error :class class :initargs invalid-keys))))
+
;;; end of ctor.lisp
projects / sbcl.git / blobdiff