@findex compute-slots
@findex sb-mop:compute-slots
@tindex funcallable-standard-class
+@tindex sb-mop:funcallable-standard-class
the system-supplied @code{:around} method for @code{compute-slots}
specialized on @code{funcallable-standard-class} does not respect the
requested order from a user-supplied primary method.
argument defining the declarations to be stored and returned by
@code{generic-function-declarations}.
+@item
+@findex validate-superclass
+@findex finalize-inheritance
+@findex sb-mop:validate-superclass
+@findex sb-mop:finalize-inheritance
+@tindex standard-class
+@tindex funcallable-standard-class
+@tindex sb-mop:funcallable-standard-class
+although we obey the requirement in AMOP for @code{validate-superclass}
+for @code{standard-class} and @code{funcallable-standard-class} to be
+compatible metaclasses, we impose an additional requirement at class
+finalization time: a class of metaclass
+@code{funcallable-standard-class} must have @code{function} in its
+superclasses, and a class of metaclass @code{standard-class} must not.
+
@end itemize
@node Support For Unix
(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)
(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
;;;; no regressions.
(defpackage "MOP-TEST"
- (:use "CL" "SB-MOP"))
+ (:use "CL" "SB-MOP" "ASSERTOID"))
(in-package "MOP-TEST")
\f
(:metaclass custom-default-initargs-class))
(assert (eq (slot-value (make-instance 'extra-initarg) 'slot) 'extra))
\f
+;;; STANDARD-CLASS valid as a superclass for FUNCALLABLE-STANDARD-CLASS
+(defclass standard-class-for-fsc ()
+ ((scforfsc-slot :initarg :scforfsc-slot :accessor scforfsc-slot)))
+(defvar *standard-class-for-fsc*
+ (make-instance 'standard-class-for-fsc :scforfsc-slot 1))
+(defclass fsc-with-standard-class-superclass
+ (standard-class-for-fsc funcallable-standard-object)
+ ((fsc-slot :initarg :fsc-slot :accessor fsc-slot))
+ (:metaclass funcallable-standard-class))
+(defvar *fsc/scs*
+ (make-instance 'fsc-with-standard-class-superclass
+ :scforfsc-slot 2
+ :fsc-slot 3))
+(assert (= (scforfsc-slot *standard-class-for-fsc*) 1))
+(assert (= (scforfsc-slot *fsc/scs*) 2))
+(assert (= (fsc-slot *fsc/scs*) 3))
+(assert (subtypep 'fsc-with-standard-class-superclass 'function))
+(assert (not (subtypep 'standard-class-for-fsc 'function)))
+
+;;; also check that our sanity check for functionness is good
+(assert (raises-error?
+ (progn
+ (defclass bad-standard-class (funcallable-standard-object)
+ ()
+ (:metaclass standard-class))
+ (make-instance 'bad-standard-class))))
+(assert (raises-error?
+ (progn
+ (defclass bad-funcallable-standard-class (standard-object)
+ ()
+ (:metaclass funcallable-standard-class))
+ (make-instance 'bad-funcallable-standard-class))))
+
;;;; success
projects / sbcl.git / commitdiff