(compute-slot-accessor-info slotd type gf)))
(initialize-internal-slot-gfs name)))
+;;; CMUCL (Gerd PCL 2003-04-25) comment:
+;;;
+;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
+;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
+;;; writing/testing effective slot SLOTD.
+;;;
+;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
+;;; GF. Store the effective method in the effective slot definition
+;;; object itself; these GFs have special dispatch functions calling
+;;; effective methods directly retrieved from effective slot
+;;; definition objects, as an optimization.
+;;;
+;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
+;;; or some such.
(defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
type gf)
(let* ((name (slot-value slotd 'name))
(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))
(add-direct-subclasses class direct-superclasses)
(make-class-predicate class predicate-name)
(update-class class nil)
+ (do* ((slots (slot-value class 'slots) (cdr slots))
+ (dupes nil))
+ ((null slots) (when dupes
+ (style-warn
+ ;; FIXME: the indentation request ("~4I")
+ ;; below appears not to do anything. Finding
+ ;; out why would be nice. -- CSR, 2003-04-24
+ "~@<slot names with the same SYMBOL-NAME but ~
+ different SYMBOL-PACKAGE (possible package problem) ~
+ for class ~S:~@:_~4I~<~@{~S~^~:@_~}~:>~@:>"
+ class
+ dupes)))
+ (let* ((slot (car slots))
+ (oslots (remove (slot-definition-name slot) (cdr slots)
+ :test-not #'string= :key #'slot-definition-name)))
+ (when oslots
+ (pushnew (cons (slot-definition-name slot)
+ (mapcar #'slot-definition-name oslots))
+ dupes
+ :test #'string= :key #'car))))
(add-slot-accessors class direct-slots)
(make-preliminary-layout class))
(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)
(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
(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
(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))
(make-class-predicate class predicate-name)
(add-slot-accessors class direct-slots)))
-(defmethod direct-slot-definition-class ((class structure-class) initargs)
+(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
(declare (ignore initargs))
(find-class 'structure-direct-slot-definition))
(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.
(setf (plist-value class 'default-initargs) inits))
\f
(defmethod compute-default-initargs ((class slot-class))
- (let ((cpl (class-precedence-list class))
- (direct (class-direct-default-initargs class)))
- (labels ((walk (tail)
- (if (null tail)
- nil
- (let ((c (pop tail)))
- (append (if (eq c class)
- direct
- (class-direct-default-initargs c))
- (walk tail))))))
- (let ((initargs (walk cpl)))
- (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
+ (let ((initargs (loop for c in (class-precedence-list class)
+ append (class-direct-default-initargs c))))
+ (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
\f
;;;; protocols for constructing direct and effective slot definitions
-(defmethod direct-slot-definition-class ((class std-class) initargs)
+(defmethod direct-slot-definition-class ((class std-class) &rest initargs)
(declare (ignore initargs))
(find-class 'standard-direct-slot-definition))
(defun make-direct-slotd (class initargs)
(let ((initargs (list* :class class initargs)))
(apply #'make-instance
- (direct-slot-definition-class class initargs)
+ (apply #'direct-slot-definition-class class initargs)
initargs)))
(defmethod compute-slots ((class std-class))
(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
(declare (ignore name))
(let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
- (class (effective-slot-definition-class class initargs)))
+ (class (apply #'effective-slot-definition-class class initargs)))
(apply #'make-instance class initargs)))
-(defmethod effective-slot-definition-class ((class std-class) initargs)
+(defmethod effective-slot-definition-class ((class std-class) &rest initargs)
(declare (ignore initargs))
(find-class 'standard-effective-slot-definition))
-(defmethod effective-slot-definition-class ((class structure-class) initargs)
+(defmethod effective-slot-definition-class ((class structure-class) &rest initargs)
(declare (ignore initargs))
(find-class 'structure-effective-slot-definition))
projects / sbcl.git / blobdiff