(defmethod class-prototype :before (class)
(unless (class-finalized-p class)
- (error "~S not yet finalized, cannot allocate a prototype." class)))
+ (error "~@<~S is not finalized.~:@>" class)))
;;; KLUDGE: For some reason factoring the common body into a function
;;; breaks PCL bootstrapping, so just generate it with a macrolet for
*the-class-standard-object*))))
(dolist (superclass direct-superclasses)
(unless (validate-superclass class superclass)
- (error "The class ~S was specified as a~%
- super-class of the class ~S;~%~
- but the meta-classes ~S and~%~S are incompatible.~@
- Define a method for ~S to avoid this error."
+ (error "~@<The class ~S was specified as a ~
+ super-class of the class ~S, ~
+ but the meta-classes ~S and ~S are incompatible. ~
+ Define a method for ~S to avoid this error.~@:>"
superclass class (class-of superclass) (class-of class)
'validate-superclass)))
(setf (slot-value class 'direct-superclasses) direct-superclasses))
(update-initargs class (compute-default-initargs class))
(update-ctors 'finalize-inheritance :class class))
(unless finalizep
- (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))))
+ (dolist (sub (class-direct-subclasses class))
+ (update-class sub nil)))))
+
+(define-condition cpl-protocol-violation (reference-condition error)
+ ((class :initarg :class :reader cpl-protocol-violation-class)
+ (cpl :initarg :cpl :reader cpl-protocol-violation-cpl))
+ (:default-initargs :references (list '(:sbcl :node "Metaobject Protocol")))
+ (:report
+ (lambda (c s)
+ (format s "~@<Protocol violation: the ~S class ~S ~
+ ~:[has~;does not have~] the class ~S in its ~
+ class precedence list: ~S.~@:>"
+ (class-name (class-of (cpl-protocol-violation-class c)))
+ (cpl-protocol-violation-class c)
+ (eq (class-of (cpl-protocol-violation-class c))
+ *the-class-funcallable-standard-class*)
+ (find-class 'function)
+ (cpl-protocol-violation-cpl c)))))
(defun update-cpl (class cpl)
+ (when (eq (class-of class) *the-class-standard-class*)
+ (when (find (find-class 'function) cpl)
+ (error 'cpl-protocol-violation :class class :cpl cpl)))
+ (when (eq (class-of class) *the-class-funcallable-standard-class*)
+ (unless (find (find-class 'function) cpl)
+ (error 'cpl-protocol-violation :class class :cpl cpl)))
(if (class-finalized-p class)
(unless (and (equal (class-precedence-list class) cpl)
(dolist (c cpl t)
;;; the slots predictably, but maybe it would be good to compute some
;;; kind of optimal slot layout by looking at locations of slots in
;;; superclasses?
-(defmethod compute-slots ((class std-class))
+(defun std-compute-slots (class)
;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
;; for each different slot name we find in our superclasses. Each
;; call receives the class and a list of the dslotds with that name.
(nreverse name-dslotds-alist))))
(defmethod compute-slots ((class standard-class))
- (call-next-method))
+ (std-compute-slots class))
+(defmethod compute-slots ((class funcallable-standard-class))
+ (std-compute-slots class))
-(defmethod compute-slots :around ((class standard-class))
- (let ((eslotds (call-next-method))
- (location -1))
+(defun std-compute-slots-around (class eslotds)
+ (let ((location -1))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
(case (slot-definition-allocation eslotd)
(setf (slot-definition-class eslotd) class))
(initialize-internal-slot-functions eslotd))))
-(defmethod compute-slots ((class funcallable-standard-class))
- (call-next-method))
-
+(defmethod compute-slots :around ((class standard-class))
+ (let ((eslotds (call-next-method)))
+ (std-compute-slots-around class eslotds)))
(defmethod compute-slots :around ((class funcallable-standard-class))
- (labels ((instance-slot-names (slotds)
- (let (collect)
- (dolist (slotd slotds (nreverse collect))
- (when (eq (slot-definition-allocation slotd) :instance)
- (push (slot-definition-name slotd) collect)))))
- ;; This sorts slots so that slots of classes later in the CPL
- ;; come before slots of other classes. This is crucial for
- ;; funcallable instances because it ensures that the slots of
- ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
- ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
- ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
- ;; a funcallable instance.
- (compute-layout (eslotds)
- (let ((first ())
- (names (instance-slot-names eslotds)))
- (dolist (class
- (reverse (class-precedence-list class))
- (nreverse (nconc names first)))
- (dolist (ss (class-slots class))
- (let ((name (slot-definition-name ss)))
- (when (member name names)
- (push name first)
- (setq names (delete name names)))))))))
- (let ((all-slotds (call-next-method))
- (instance-slots ())
- (class-slots ()))
- (dolist (slotd all-slotds)
- (case (slot-definition-allocation slotd)
- (:instance (push slotd instance-slots))
- (:class (push slotd class-slots))))
- (let ((layout (compute-layout instance-slots)))
- (dolist (slotd instance-slots)
- (setf (slot-definition-location slotd)
- (position (slot-definition-name slotd) layout))
- (initialize-internal-slot-functions slotd)))
- (dolist (slotd class-slots)
- (let ((name (slot-definition-name slotd))
- (from-class (slot-definition-allocation-class slotd)))
- (setf (slot-definition-location slotd)
- (assoc name (class-slot-cells from-class)))
- (aver (consp (slot-definition-location slotd)))
- (initialize-internal-slot-functions slotd)))
- all-slotds)))
+ (let ((eslotds (call-next-method)))
+ (std-compute-slots-around class eslotds)))
(defmethod compute-slots ((class structure-class))
(mapcan (lambda (superclass)
(defmethod compatible-meta-class-change-p (class proto-new-class)
(eq (class-of class) (class-of proto-new-class)))
-(defmethod validate-superclass ((class class) (new-super class))
- (or (eq new-super *the-class-t*)
- (eq (class-of class) (class-of new-super))))
-
-(defmethod validate-superclass ((class standard-class) (new-super std-class))
- (let ((new-super-meta-class (class-of new-super)))
- (or (eq new-super-meta-class *the-class-std-class*)
- (eq (class-of class) new-super-meta-class))))
+(defmethod validate-superclass ((class class) (superclass class))
+ (or (eq superclass *the-class-t*)
+ (eq (class-of class) (class-of superclass))
+ (and (eq (class-of superclass) *the-class-standard-class*)
+ (eq (class-of class) *the-class-funcallable-standard-class*))
+ (and (eq (class-of superclass) *the-class-funcallable-standard-class*)
+ (eq (class-of class) *the-class-standard-class*))))
\f
;;; What this does depends on which of the four possible values of
;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it