(allocate-instance class)
(allocate-standard-instance wrapper))))))
+(defmethod class-prototype ((class condition-class))
+ (with-slots (prototype) class
+ (or prototype (setf prototype (allocate-instance class)))))
+
(defmethod class-direct-default-initargs ((class slot-class))
(plist-value class 'direct-default-initargs))
(defmethod class-slot-cells ((class std-class))
(plist-value class 'class-slot-cells))
+(defmethod (setf class-slot-cells) (new-value (class std-class))
+ (setf (plist-value class 'class-slot-cells) new-value))
\f
;;;; class accessors that are even a little bit more complicated than those
;;;; above. These have a protocol for updating them, we must implement that
(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
(declare (ignore slot-names))
- (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
+ (setf (slot-value specl 'type)
+ `(eql ,(specializer-object specl)))
+ (setf (info :type :translator specl)
+ (constantly (make-member-type :members (list (specializer-object specl))))))
+
\f
(defun real-load-defclass (name metaclass-name supers slots other)
(let ((res (apply #'ensure-class name :metaclass metaclass-name
(setq direct-supers direct-superclasses)
(setq wrapper (classoid-layout classoid))
(setq class-precedence-list (compute-class-precedence-list class))
- (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)
(incf location))
(:class
(let* ((name (slot-definition-name eslotd))
- (from-class (slot-definition-allocation-class eslotd))
- (cell (assq name (class-slot-cells from-class))))
+ (from-class
+ (or
+ (slot-definition-allocation-class eslotd)
+ ;; we get here if the user adds an extra slot
+ ;; himself...
+ (setf (slot-definition-allocation-class eslotd)
+ class)))
+ ;; which raises the question of what we should
+ ;; 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))))))
(aver (consp cell))
(if (eq +slot-unbound+ (cdr cell))
;; We may have inherited an initfunction
(rplacd cell (funcall initfun))
cell))
cell)))))
+ (unless (slot-definition-class eslotd)
+ (setf (slot-definition-class eslotd) class))
(initialize-internal-slot-functions eslotd))))
(defmethod compute-slots ((class funcallable-standard-class))