(writer '(setf slot-value-using-class))
(boundp 'slot-boundp-using-class)))
(gf (gdefinition gf-name)))
- (compute-slot-accessor-info slotd type gf)))
- (initialize-internal-slot-gfs name)))
+ (compute-slot-accessor-info slotd type gf)))))
;;; CMUCL (Gerd PCL 2003-04-25) comment:
;;;
(set-class-type-translation class name)
class))
-(defmethod class-predicate-name ((class t))
- 'constantly-nil)
-
(defun fix-super (s)
(cond ((classp s) s)
((not (legal-class-name-p s))
\f
(defmethod shared-initialize :after
- ((class std-class)
- slot-names
- &key (direct-superclasses nil direct-superclasses-p)
- (direct-slots nil direct-slots-p)
- (direct-default-initargs nil direct-default-initargs-p)
- (predicate-name nil predicate-name-p))
+ ((class std-class) slot-names &key
+ (direct-superclasses nil direct-superclasses-p)
+ (direct-slots nil direct-slots-p)
+ (direct-default-initargs nil direct-default-initargs-p))
(cond (direct-superclasses-p
(setq direct-superclasses
(or direct-superclasses
(push (cons name value) collect))
(push old collect)))))
(nreverse collect)))
- (setq predicate-name (if predicate-name-p
- (setf (slot-value class 'predicate-name)
- (car predicate-name))
- (or (slot-value class 'predicate-name)
- (setf (slot-value class 'predicate-name)
- (make-class-predicate-name (class-name
- class))))))
(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))
(lambda (dependent)
(apply #'update-dependent class dependent initargs))))
+(defmethod reinitialize-instance :after ((class condition-class) &key)
+ (let* ((name (class-name class))
+ (classoid (find-classoid name))
+ (slots (condition-classoid-slots classoid)))
+ ;; to balance the REMOVE-SLOT-ACCESSORS call in
+ ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
+ (dolist (slot slots)
+ (let ((slot-name (condition-slot-name slot)))
+ (dolist (reader (condition-slot-readers slot))
+ ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
+ ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
+ (sb-kernel::install-condition-slot-reader reader name slot-name))
+ (dolist (writer (condition-slot-writers slot))
+ (sb-kernel::install-condition-slot-writer writer name slot-name))))))
+
(defmethod shared-initialize :after ((class condition-class) slot-names
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (class-name class))))
(with-slots (wrapper class-precedence-list cpl-available-p
- prototype predicate-name
- (direct-supers direct-superclasses))
+ prototype (direct-supers direct-superclasses))
class
(setf (slot-value class 'direct-slots)
(mapcar (lambda (pl) (make-direct-slotd class pl))
(setq class-precedence-list (compute-class-precedence-list class))
(setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
- (setq predicate-name (make-class-predicate-name (class-name class)))
- (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.
+ ;;
+ ;; ??? What does the above comment mean and why is it a good idea?
+ ;; CMUCL (which still as of 2005-11-18 uses this code and has this
+ ;; comment) loses slot information in its condition classes:
+ ;; DIRECT-SLOTS is always NIL. We have the right information, so we
+ ;; remove slot accessors but never put them back. I've added a
+ ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
+ ;; was meant to happen? -- CSR, 2005-11-18
(update-pv-table-cache-info class))
(defmethod direct-slot-definition-class ((class condition-class)
(sb-kernel::compiler-layout-or-lose (dd-name dd))))))
(defmethod shared-initialize :after
- ((class structure-class)
- slot-names
- &key (direct-superclasses nil direct-superclasses-p)
+ ((class structure-class) slot-names &key
+ (direct-superclasses nil direct-superclasses-p)
(direct-slots nil direct-slots-p)
- direct-default-initargs
- (predicate-name nil predicate-name-p))
+ direct-default-initargs)
(declare (ignore slot-names direct-default-initargs))
(if direct-superclasses-p
(setf (slot-value class 'direct-superclasses)
(setf (slot-value class 'wrapper) (classoid-layout lclass)))
(setf (slot-value class 'finalized-p) t)
(update-pv-table-cache-info class)
- (setq predicate-name (if predicate-name-p
- (setf (slot-value class 'predicate-name)
- (car predicate-name))
- (or (slot-value class 'predicate-name)
- (setf (slot-value class 'predicate-name)
- (make-class-predicate-name
- (class-name class))))))
- (make-class-predicate class predicate-name)
(add-slot-accessors class direct-slots)))
(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
;; do if we find that said user has added a slot
;; with the same name as another slot...
(cell (or (assq name (class-slot-cells from-class))
- (setf (class-slot-cells from-class)
- (cons (cons name +slot-unbound+)
- (class-slot-cells from-class))))))
+ (let ((c (cons name +slot-unbound+)))
+ (push c (class-slot-cells from-class))
+ c))))
(aver (consp cell))
(if (eq +slot-unbound+ (cdr cell))
;; We may have inherited an initfunction
allocp t))
(setq initargs (append (slot-definition-initargs slotd) initargs))
(let ((slotd-type (slot-definition-type slotd)))
- (setq type (cond ((eq type t) slotd-type)
- ((*subtypep type slotd-type) type)
- (t `(and ,type ,slotd-type)))))))
+ (setq type (cond
+ ((eq type t) slotd-type)
+ ;; This pairwise type intersection is perhaps a
+ ;; little inefficient and inelegant, but it's
+ ;; unlikely to lie on the critical path. Shout
+ ;; if I'm wrong. -- CSR, 2005-11-24
+ (t (type-specifier
+ (specifier-type `(and ,type ,slotd-type)))))))))
(list :name name
:initform initform
:initfunction initfunction