X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=ca880839a82b98d815b00ef92a81b6782701d92f;hb=3a618201c9f2370bb8784217a866d000371769e5;hp=dde1c3fd01ad3ebe3a078802d3265c819293f2f0;hpb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index dde1c3f..ca88083 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -92,13 +92,13 @@ ;;; 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. @@ -115,11 +115,11 @@ (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)))) ;;; @@ -210,8 +210,8 @@ (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) @@ -252,7 +252,7 @@ (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 @@ -285,10 +285,11 @@ ;; together with the system-defined ones in what ;; COMPUTE-APPLICABLE-METHODS returns. (or (and (not (structure-class-p class)) + (not (condition-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 @@ -312,13 +313,13 @@ (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)))) @@ -339,7 +340,7 @@ `(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) @@ -373,7 +374,7 @@ (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 @@ -426,29 +427,36 @@ (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) *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 @@ -462,22 +470,24 @@ (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) @@ -487,11 +497,10 @@ 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 @@ -500,7 +509,7 @@ ((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))) @@ -526,12 +535,18 @@ (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 @@ -556,30 +571,38 @@ ;;; ******************************* (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*) @@ -588,4 +611,27 @@ (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