X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=22c3c10b5248ac6947a9e12baa4cacb342044a8f;hb=22aec7852f4861e5dab28cc0d619c24b62590dad;hp=d943fb860b0792e41902e2262d1a44b4d68c342a;hpb=a1007bcf38130a9a08e32f04a69e6836f76329d2;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d943fb8..22c3c10 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -499,6 +499,9 @@ (setq direct-default-initargs (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) + ;; The below initializes shared slots from direct initforms, + ;; but one might inherit initforms from superclasses + ;; (cf. UPDATE-SHARED-SLOT-VALUES). (let (collect) (dolist (dslotd direct-slots) (when (eq :class (slot-definition-allocation dslotd)) @@ -603,12 +606,15 @@ (apply #'update-dependent class dependent initargs)))) (defmethod shared-initialize :after ((class condition-class) slot-names - &key direct-superclasses) + &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) (with-slots (wrapper class-precedence-list prototype predicate-name (direct-supers direct-superclasses)) class + (setf (slot-value class 'direct-slots) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots)) (setf (slot-value class 'finalized-p) t) (setf (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) @@ -617,7 +623,62 @@ (setq prototype (make-condition (class-name class))) (add-direct-subclasses class direct-superclasses) (setq predicate-name (make-class-predicate-name (class-name class))) - (make-class-predicate class predicate-name)))) + (make-class-predicate class predicate-name) + (setf (slot-value class 'slots) (compute-slots class)))) + ;; Comment from Gerd's PCL, 2003-05-15: + ;; + ;; We don't ADD-SLOT-ACCESSORS here because we don't want to + ;; override condition accessors with generic functions. We do this + ;; differently. + (update-pv-table-cache-info class)) + +(defmethod direct-slot-definition-class ((class condition-class) + &rest initargs) + (declare (ignore initargs)) + (find-class 'condition-direct-slot-definition)) + +(defmethod effective-slot-definition-class ((class condition-class) + &rest initargs) + (declare (ignore initargs)) + (find-class 'condition-effective-slot-definition)) + +(defmethod finalize-inheritance ((class condition-class)) + (aver (slot-value class 'finalized-p)) + nil) + +(defmethod compute-effective-slot-definition + ((class condition-class) slot-name dslotds) + (let ((slotd (call-next-method))) + (setf (slot-definition-reader-function slotd) + (lambda (x) + (handler-case (condition-reader-function x slot-name) + ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot + ;; is unbound; maybe it should be a CELL-ERROR of some + ;; sort? + (error () (slot-unbound class x slot-name))))) + (setf (slot-definition-writer-function slotd) + (lambda (v x) + (condition-writer-function x v slot-name))) + (setf (slot-definition-boundp-function slotd) + (lambda (x) + (multiple-value-bind (v c) + (ignore-errors (condition-reader-function x slot-name)) + (declare (ignore v)) + (null c)))) + slotd)) + +(defmethod compute-slots ((class condition-class)) + (mapcan (lambda (superclass) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class (slot-definition-name dslotd) (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class 'class-precedence-list)))) + +(defmethod compute-slots :around ((class condition-class)) + (let ((eslotds (call-next-method))) + (mapc #'initialize-internal-slot-functions eslotds) + eslotds)) (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names &key @@ -675,6 +736,19 @@ (cons nil nil)))) (values defstruct-form constructor reader-names writer-names))) +(defun make-defstruct-allocation-function (class) + (let ((dd (get-structure-dd (class-name class)))) + (lambda () + (let ((instance (%make-instance (dd-length dd))) + (raw-index (dd-raw-index dd))) + (setf (%instance-layout instance) + (sb-kernel::compiler-layout-or-lose (dd-name dd))) + (when raw-index + (setf (%instance-ref instance raw-index) + (make-array (dd-raw-length dd) + :element-type '(unsigned-byte 32)))) + instance)))) + (defmethod shared-initialize :after ((class structure-class) slot-names @@ -709,22 +783,24 @@ (make-direct-slotd class pl)) direct-slots))) (setq direct-slots (slot-value class 'direct-slots))) - (when defstruct-p - (let ((include (car (slot-value class 'direct-superclasses)))) - (multiple-value-bind (defstruct-form constructor reader-names writer-names) - (make-structure-class-defstruct-form name direct-slots include) - (unless (structure-type-p name) (eval defstruct-form)) - (mapc (lambda (dslotd reader-name writer-name) - (let* ((reader (gdefinition reader-name)) - (writer (when (gboundp writer-name) - (gdefinition writer-name)))) - (setf (slot-value dslotd 'internal-reader-function) - reader) - (setf (slot-value dslotd 'internal-writer-function) - writer))) - direct-slots reader-names writer-names) - (setf (slot-value class 'defstruct-form) defstruct-form) - (setf (slot-value class 'defstruct-constructor) constructor)))) + (if defstruct-p + (let ((include (car (slot-value class 'direct-superclasses)))) + (multiple-value-bind (defstruct-form constructor reader-names writer-names) + (make-structure-class-defstruct-form name direct-slots include) + (unless (structure-type-p name) (eval defstruct-form)) + (mapc (lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (gboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) + reader) + (setf (slot-value dslotd 'internal-writer-function) + writer))) + direct-slots reader-names writer-names) + (setf (slot-value class 'defstruct-form) defstruct-form) + (setf (slot-value class 'defstruct-constructor) constructor))) + (setf (slot-value class 'defstruct-constructor) + (make-defstruct-allocation-function class))) (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) @@ -826,13 +902,27 @@ (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) + (update-shared-slot-values class) (update-ctors 'finalize-inheritance :class class)) (unless finalizep (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) +(defun update-shared-slot-values (class) + (dolist (slot (class-slots class)) + (when (eq (slot-definition-allocation slot) :class) + (let ((cell (assq (slot-definition-name slot) (class-slot-cells class)))) + (when cell + (let ((initfn (slot-definition-initfunction slot))) + (when initfn + (setf (cdr cell) (funcall initfn))))))))) + (defun update-cpl (class cpl) (if (class-finalized-p class) - (unless (equal (class-precedence-list class) cpl) + (unless (and (equal (class-precedence-list class) cpl) + (dolist (c cpl t) + (when (position :class (class-direct-slots c) + :key #'slot-definition-allocation) + (return nil)))) ;; comment from the old CMU CL sources: ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMU CL. @@ -899,7 +989,8 @@ wrapper nwrapper)) (setf (slot-value class 'finalized-p) t) (unless (eq owrapper nwrapper) - (update-pv-table-cache-info class))))) + (update-pv-table-cache-info class) + (maybe-update-standard-class-locations class))))) (defun compute-class-slots (eslotds) (let (collect)