From: Christophe Rhodes Date: Fri, 9 Sep 2005 17:43:45 +0000 (+0000) Subject: 0.9.4.56: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2d237dbc3edb1f6f5337ab19dd74a317e43234db;p=sbcl.git 0.9.4.56: Make VALIDATE-SUPERCLASS obey the rules. ... ah, but we need an additional constraint for CLOS classes to behave: F-S-Cs must have FUNCTION in their CPL, while S-Cs mustn't. Otherwise you end up with things which are functions but whose type-of isn't subtypep function, and similar disasters. ... document this additional constraint. --- diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 2c01c35..7960c08 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -58,6 +58,7 @@ hierarchy; @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. @@ -71,6 +72,21 @@ the arguments @code{:declare} and @code{:declarations} to 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 diff --git a/src/pcl/fsc.lisp b/src/pcl/fsc.lisp index cb3a834..46f6944 100644 --- a/src/pcl/fsc.lisp +++ b/src/pcl/fsc.lisp @@ -42,12 +42,6 @@ (defmethod raw-instance-allocator ((class funcallable-standard-class)) 'allocate-funcallable-instance) -(defmethod validate-superclass ((fsc funcallable-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 fsc) new-super-meta-class)))) - (defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index e92cc55..34f3981 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -383,7 +383,7 @@ (defgeneric update-gf-dfun (class gf)) -(defgeneric validate-superclass (fsc class)) +(defgeneric validate-superclass (class superclass)) (defgeneric (setf documentation) (new-value slotd doc-type) (:argument-precedence-order doc-type slotd new-value)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d5d906b..ef7c7c2 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -123,7 +123,7 @@ (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 @@ -382,10 +382,10 @@ *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 "~@" superclass class (class-of superclass) (class-of class) 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) @@ -818,9 +818,32 @@ (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 "~@" + (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) @@ -1218,14 +1241,13 @@ (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*)))) ;;; What this does depends on which of the four possible values of ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 287655a..3c3ae3e 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -16,7 +16,7 @@ ;;;; no regressions. (defpackage "MOP-TEST" - (:use "CL" "SB-MOP")) + (:use "CL" "SB-MOP" "ASSERTOID")) (in-package "MOP-TEST") @@ -429,4 +429,37 @@ (:metaclass custom-default-initargs-class)) (assert (eq (slot-value (make-instance 'extra-initarg) 'slot) 'extra)) +;;; 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 diff --git a/version.lisp-expr b/version.lisp-expr index 3903ab8..7bd2bb9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.4.55" +"0.9.4.56"