From fe027d695f4a23cc05ac0a8a99bceec3a242d27f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 29 Apr 2014 12:48:49 +0100 Subject: [PATCH] signal errors on trying to subclass BUILT-IN-CLASSes, lp#861004 Introduce a new "interposing" (in AMOP terms) SYSTEM-CLASS to hang some functionality on, and make BUILT-IN-CLASS a subclass. Most of the specified functionality is common to both and implemented in terms of SYSTEM-CLASS, but the error on subclassing is just for BUILT-IN-CLASSES. This therefore involves making the subclassable System Classes, SEQUENCE and STREAM (and subclasses), be of metaclass SYSTEM-CLASS rather than BUILT-IN-CLASS. The bootstrap and braid need to be adjusted accordingly. Implement the validate-superclass error in terms of a new invalid-superclass generic function (as suggested by Nick Levine in preliminary work on this problem), and make the invalid-superclass error a reference-condition so that we can defend our implementation strategy. This is yet another example of a bug tagged "easy" which involves dealing with the PCL bootstrap. Someone should do something about this. --- package-data-list.lisp-expr | 3 +- src/code/condition.lisp | 2 + src/pcl/boot.lisp | 50 ++++++++++++------------- src/pcl/braid.lisp | 17 +++++++-- src/pcl/defs.lisp | 23 +++++++----- src/pcl/dfun.lisp | 11 +++--- src/pcl/dlisp.lisp | 4 +- src/pcl/early-low.lisp | 1 + src/pcl/generic-functions.lisp | 2 + src/pcl/low.lisp | 1 + src/pcl/methods.lisp | 4 +- src/pcl/slots.lisp | 8 ++-- src/pcl/std-class.lisp | 84 +++++++++++++++++++++++++----------------- src/pcl/wrapper.lisp | 6 +-- tests/clos.impure.lisp | 7 ++++ tests/mop.impure.lisp | 16 ++++---- 16 files changed, 145 insertions(+), 94 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 6c625265e..b20ba2d4f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2301,7 +2301,8 @@ guaranteed to be present in later versions of SBCL. Use of this package is deprecated in favour of SB-MOP." :use ("CL" "SB!MOP" "SB!INT" "SB!EXT" "SB!WALKER" "SB!KERNEL") ;; experimental SBCL-only (for now) symbols - :export ("MAKE-METHOD-SPECIALIZERS-FORM" + :export ("SYSTEM-CLASS" + "MAKE-METHOD-SPECIALIZERS-FORM" "PARSE-SPECIALIZER-USING-CLASS" "UNPARSE-SPECIALIZER-USING-CLASS" "+SLOT-UNBOUND+") diff --git a/src/code/condition.lisp b/src/code/condition.lisp index d88858cb7..1690ca447 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -867,6 +867,8 @@ (:macro (format stream "Macro ~S" data)) (:section (format stream "Section ~{~D~^.~}" data)) (:glossary (format stream "Glossary entry for ~S" data)) + (:type (format stream "Type ~S" data)) + (:system-class (format stream "System Class ~S" data)) (:issue (format stream "writeup for Issue ~A" data))))) (:sbcl (format stream "The SBCL Manual") diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 741525af3..82529b5e2 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -907,33 +907,33 @@ bootstrapping. (let ((class (specializer-nameoid-class))) ;; CLASS can be null here if the user has ;; erroneously tried to use a defined type as a - ;; specializer; it can be a non-BUILT-IN-CLASS if + ;; specializer; it can be a non-SYSTEM-CLASS if ;; the user defines a type and calls (SETF ;; FIND-CLASS) in a consistent way. - (when (and class (typep class 'built-in-class)) - `(type ,(class-name class) ,parameter)))) - ((:instance nil) - (let ((class (specializer-nameoid-class))) - (cond - (class - (if (typep class '(or built-in-class structure-class)) - `(type ,class ,parameter) - ;; don't declare CLOS classes as parameters; - ;; it's too expensive. - '(ignorable))) - (t - ;; we can get here, and still not have a failure - ;; case, by doing MOP programming like (PROGN - ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) - ;; ...)). Best to let the user know we haven't - ;; been able to extract enough information: - (style-warn - "~@" - specializer-nameoid - 'parameter-specializer-declaration-in-defmethod) - '(ignorable))))) - ((:forthcoming-defclass-type) - '(ignorable)))))))) + (when (and class (typep class 'system-class)) + `(type ,(class-name class) ,parameter)))) + ((:instance nil) + (let ((class (specializer-nameoid-class))) + (cond + (class + (if (typep class '(or system-class structure-class)) + `(type ,class ,parameter) + ;; don't declare CLOS classes as parameters; + ;; it's too expensive. + '(ignorable))) + (t + ;; we can get here, and still not have a failure + ;; case, by doing MOP programming like (PROGN + ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) + ;; ...)). Best to let the user know we haven't + ;; been able to extract enough information: + (style-warn + "~@" + specializer-nameoid + 'parameter-specializer-declaration-in-defmethod) + '(ignorable))))) + ((:forthcoming-defclass-type) + '(ignorable)))))))) ;;; For passing a list (groveled by the walker) of the required ;;; parameters whose bindings are modified in the method body to the diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 3565b52d5..31c63c182 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -136,6 +136,7 @@ standard-class-wrapper standard-class funcallable-standard-class-wrapper funcallable-standard-class slot-class-wrapper slot-class + system-class-wrapper system-class built-in-class-wrapper built-in-class structure-class-wrapper structure-class condition-class-wrapper condition-class @@ -147,7 +148,7 @@ standard-generic-function-wrapper standard-generic-function) (!initial-classes-and-wrappers standard-class funcallable-standard-class - slot-class built-in-class structure-class condition-class + slot-class system-class built-in-class structure-class condition-class standard-direct-slot-definition standard-effective-slot-definition class-eq-specializer standard-generic-function) ;; First, make a class metaobject for each of the early classes. For @@ -162,6 +163,7 @@ (funcallable-standard-class funcallable-standard-class-wrapper) (built-in-class built-in-class-wrapper) + (system-class system-class-wrapper) (structure-class structure-class-wrapper) (condition-class condition-class-wrapper))) (class (or (find-class name nil) @@ -190,6 +192,7 @@ ((eq class standard-effective-slot-definition) standard-effective-slot-definition-wrapper) + ((eq class system-class) system-class-wrapper) ((eq class built-in-class) built-in-class-wrapper) ((eq class structure-class) @@ -242,6 +245,11 @@ meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper proto)) + (system-class + (!bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto)) (slot-class ; *the-class-slot-object* (!bootstrap-initialize-class meta @@ -420,7 +428,7 @@ (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) (meta (ecd-metaclass definition))) - (unless (eq meta 'built-in-class) + (unless (or (eq meta 'built-in-class) (eq meta 'system-class)) (let ((direct-slots (ecd-canonical-slots definition))) (dolist (slotd direct-slots) (let ((slot-name (getf slotd :name)) @@ -512,10 +520,13 @@ ;; First make sure that all the supers listed in ;; *BUILT-IN-CLASS-LATTICE* are themselves defined by ;; *BUILT-IN-CLASS-LATTICE*. This is just to check for typos and - ;; other sorts of brainos. + ;; other sorts of brainos. (The exceptions, T and SEQUENCE, are + ;; those classes which are SYSTEM-CLASSes which nevertheless have + ;; BUILT-IN-CLASS subclasses.) (dolist (e *built-in-classes*) (dolist (super (cadr e)) (unless (or (eq super t) + (eq super 'sequence) (assq super *built-in-classes*)) (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~ but ~S is not itself a class in *BUILT-IN-CLASSES*." diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 3d3d2c260..9e7e7eda0 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -257,10 +257,10 @@ 42)))) (remove-if (lambda (kernel-bic-entry) (member (first kernel-bic-entry) - ;; I'm not sure why these are removed from - ;; the list, but that's what the original - ;; CMU CL code did. -- WHN 20000715 - '(t function stream + ;; remove special classes (T and our + ;; SYSTEM-CLASSes) from the + ;; BUILT-IN-CLASS list + '(t function stream sequence file-stream string-stream))) sb-kernel::*built-in-classes*)))) (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") @@ -271,16 +271,19 @@ (:metaclass built-in-class)) (defclass function (t) () - (:metaclass built-in-class)) + (:metaclass system-class)) (defclass stream (t) () - (:metaclass built-in-class)) + (:metaclass system-class)) (defclass file-stream (stream) () - (:metaclass built-in-class)) + (:metaclass system-class)) (defclass string-stream (stream) () - (:metaclass built-in-class)) + (:metaclass system-class)) + +(defclass sequence (t) () + (:metaclass system-class)) (defclass slot-object (t) () (:metaclass slot-class)) @@ -684,7 +687,9 @@ (defclass forward-referenced-class (pcl-class) ()) -(defclass built-in-class (pcl-class) ()) +(defclass system-class (pcl-class) ()) + +(defclass built-in-class (system-class) ()) (defclass condition-class (slot-class) ()) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index fbb6f7f5e..b87a31e78 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -614,9 +614,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((cdc (caching-dfun-cost gf))) ; fast (> cdc (dispatch-dfun-cost gf cdc)))))) -(defparameter *non-built-in-typep-cost* 100) +(defparameter *non-system-typep-cost* 100) (defparameter *structure-typep-cost* 15) -(defparameter *built-in-typep-cost* 5) +(defparameter *system-typep-cost* 5) ;;; According to comments in the original CMU CL version of PCL, ;;; the cost LIMIT is important to cut off exponential growth for @@ -633,12 +633,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (eq 'class (car type)) (let* ((metaclass (class-of (cadr type))) (mcpl (class-precedence-list metaclass))) - (cond ((memq *the-class-built-in-class* mcpl) - *built-in-typep-cost*) + (cond ((memq *the-class-system-class* mcpl) + *system-typep-cost*) ((memq *the-class-structure-class* mcpl) *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) + (t *non-system-typep-cost*))) 0)) (max-cost-so-far (+ (max true-value false-value) type-test-cost))) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 9f6b6ed05..40e4652c8 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -387,9 +387,9 @@ ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all ;; equivalent and inlined to each other, we can collapse some ;; spurious differences. - ((class built-in-instance structure-instance condition-instance) + ((class system-instance structure-instance condition-instance) (when slot - (bug "SLOT requested for metatype ~S, but it isnt' going to happen." + (bug "SLOT requested for metatype ~S, but it isn't going to happen." metatype)) `(layout-of ,argument)) ;; a metatype of NIL should never be seen here, as NIL is only in diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index 3821cfc81..bbce4dd10 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -96,6 +96,7 @@ *the-class-funcallable-standard-object* *the-class-class* *the-class-generic-function* + *the-class-system-class* *the-class-built-in-class* *the-class-slot-class* *the-class-condition-class* diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 0b633a689..cfe468208 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -357,6 +357,8 @@ (defgeneric validate-superclass (class superclass)) +(defgeneric invalid-superclass (class superclass)) + (defgeneric (setf documentation) (new-value slotd doc-type) (:argument-precedence-order doc-type slotd new-value)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 3bb68cd40..93a7ee61e 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -141,6 +141,7 @@ (let ((class (class-of instance))) (when (or (eq class (find-class 'standard-class nil)) (eq class (find-class 'funcallable-standard-class nil)) + (eq class (find-class 'system-class nil)) (eq class (find-class 'built-in-class nil))) (princ (early-class-name instance) stream))))) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 2ed6c9f6a..e34da05d0 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -691,7 +691,7 @@ (mapc #'proclaim-incompatible-superclasses '(;; superclass class - (built-in-class std-class structure-class) ; direct subclasses of pcl-class + (system-class std-class structure-class) ; direct subclasses of pcl-class (standard-class funcallable-standard-class) ;; superclass metaobject (class eql-specializer class-eq-specializer method method-combination @@ -1085,7 +1085,7 @@ (cond ((eq class *the-class-t*) t) ((eq class *the-class-slot-object*) - `(not (typep (classoid-of ,arg) 'built-in-classoid))) + `(not (typep (classoid-of ,arg) 'system-classoid))) ((eq class *the-class-standard-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) ((eq class *the-class-funcallable-standard-object*) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index fc781d0ab..0344e757c 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -506,9 +506,11 @@ (declare (ignore initargs)) (allocate-condition (class-name class))) -(defmethod allocate-instance ((class built-in-class) &rest initargs) - (declare (ignore initargs)) - (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP +(macrolet ((def (name class) + `(defmethod ,name ((class ,class) &rest initargs) + (declare (ignore initargs)) + (error "Cannot allocate an instance of ~S." class)))) + (def allocate-instance system-class)) ;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes. (defmethod class-slots :before ((class slot-class)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 818930094..2645d5bd4 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -446,6 +446,7 @@ *the-class-standard-object*)))) (dolist (superclass direct-superclasses) (unless (validate-superclass class superclass) + (invalid-superclass class superclass) (error "~@" + superclass class (class-of superclass) (class-of class) + (and (typep superclass 'standard-class) + 'validate-superclass)))))) + +(defmethod invalid-superclass ((class class) (superclass class)) + (error 'invalid-superclass :class class :superclass superclass + :references (list* '(:amop :generic-function validate-superclass) + (and (typep superclass 'built-in-class) + (list '(:ansi-cl :system-class built-in-class) + '(:ansi-cl :section (4 3 7))))))) + (defmethod shared-initialize :after ((class forward-referenced-class) slot-names &key &allow-other-keys) (declare (ignore slot-names)) @@ -1333,8 +1357,7 @@ (eq (class-of class) (class-of proto-new-class))) (defmethod validate-superclass ((class class) (superclass class)) - (or (eq superclass *the-class-t*) - (eq (class-of class) (class-of superclass)) + (or (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*) @@ -1676,45 +1699,41 @@ (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) (apply #'change-class instance (find-class new-class-name) initargs)) -;;;; The metaclass BUILT-IN-CLASS +;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS ;;;; -;;;; This metaclass is something of a weird creature. By this point, all -;;;; instances of it which will exist have been created, and no instance -;;;; is ever created by calling MAKE-INSTANCE. +;;;; These metaclasses are something of a weird creature. By this +;;;; point, all instances it which will exist have been created, and +;;;; no instance is ever created by calling MAKE-INSTANCE. (The +;;;; distinction between the metaclasses is that we allow subclassing +;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols, +;;;; but not of BUILT-IN-CLASS.) ;;;; -;;;; But, there are other parts of the protocol we must follow and those -;;;; definitions appear here. +;;;; AMOP mandates some behaviour of the implementation with respect +;;;; to BUILT-IN-CLASSes, and we implement that through methods on +;;;; SYSTEM-CLASS here. (macrolet ((def (name args control) - `(defmethod ,name ,args - (declare (ignore initargs)) - (error 'metaobject-initialization-violation - :format-control ,(format nil "~@<~A~@:>" control) - :format-arguments (list ',name) - :references (list '(:amop :initialization "Class")))))) - (def initialize-instance ((class built-in-class) &rest initargs) - "Cannot ~S an instance of BUILT-IN-CLASS.") - (def reinitialize-instance ((class built-in-class) &rest initargs) - "Cannot ~S an instance of BUILT-IN-CLASS.")) - -(macrolet ((def (name) - `(defmethod ,name ((class built-in-class)) nil))) + `(defmethod ,name ,args + (declare (ignore initargs)) + (error 'metaobject-initialization-violation + :format-control ,(format nil "~@<~A~@:>" control) + :format-arguments (list (class-name class)) + :references (list '(:amop :initialization "Class")))))) + (def initialize-instance ((class system-class) &rest initargs) + "Cannot initialize an instance of ~S.") + (def reinitialize-instance ((class system-class) &rest initargs) + "Cannot reinitialize an instance of ~S.")) + +(macrolet ((def (name) `(defmethod ,name ((class system-class)) nil))) (def class-direct-slots) (def class-slots) (def class-direct-default-initargs) (def class-default-initargs)) +(defmethod validate-superclass ((c class) (s system-class)) + t) (defmethod validate-superclass ((c class) (s built-in-class)) - (or (eq s *the-class-t*) (eq s *the-class-stream*) - ;; FIXME: bad things happen if someone tries to mix in both - ;; FILE-STREAM and STRING-STREAM (as they have the same - ;; layout-depthoid). Is there any way we can provide a useful - ;; error message? -- CSR, 2005-05-03 - (eq s *the-class-file-stream*) (eq s *the-class-string-stream*) - ;; This probably shouldn't be mixed in with certain other - ;; classes, too, but it seems to work both with STANDARD-OBJECT - ;; and FUNCALLABLE-STANDARD-OBJECT - (eq s *the-class-sequence*))) + nil) ;;; Some necessary methods for FORWARD-REFERENCED-CLASS (defmethod class-direct-slots ((class forward-referenced-class)) ()) @@ -1727,8 +1746,7 @@ (def class-precedence-list) (def class-slots)) -(defmethod validate-superclass ((c slot-class) - (f forward-referenced-class)) +(defmethod validate-superclass ((c slot-class) (f forward-referenced-class)) t) (defmethod add-dependent ((metaobject dependent-update-mixin) dependent) diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index 6918b12fd..c4fe49bd0 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -263,13 +263,13 @@ (fsc *the-class-funcallable-standard-class*) (condition *the-class-condition-class*) (structure *the-class-structure-class*) - (built-in *the-class-built-in-class*) + (system *the-class-system-class*) (frc *the-class-forward-referenced-class*)) (flet ((specializer->metatype (x) (let* ((specializer-class (if (eq **boot-state** 'complete) (specializer-class-or-nil x) x)) - (meta-specializer (class-of specializer-class))) + (meta-specializer (class-of specializer-class))) (cond ((eq x *the-class-t*) t) ((not specializer-class) 'non-standard) @@ -277,7 +277,7 @@ ((*subtypep meta-specializer fsc) 'standard-instance) ((*subtypep meta-specializer condition) 'condition-instance) ((*subtypep meta-specializer structure) 'structure-instance) - ((*subtypep meta-specializer built-in) 'built-in-instance) + ((*subtypep meta-specializer system) 'system-instance) ((*subtypep meta-specializer slot) 'slot-instance) ((*subtypep meta-specializer frc) 'forward) (t (error "~@