Menu
▾
▴
[Sbcl-commits] master: signal errors on trying to subclass BUILT-IN-CLASSes, lp#861004
|
From: Christophe R. <cr...@us...> - 2014-05-21 07:00:03
|
The branch "master" has been updated in SBCL:
via fe027d695f4a23cc05ac0a8a99bceec3a242d27f (commit)
from 54ea3bf3b24c17f9b37c698ffdb52f7456e4bdc6 (commit)
- Log -----------------------------------------------------------------
commit fe027d695f4a23cc05ac0a8a99bceec3a242d27f
Author: Christophe Rhodes <cs...@ca...>
Date: Tue Apr 29 12:48:49 2014 +0100
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 | 82 ++++++++++++++++++++++++---------------
src/pcl/wrapper.lisp | 6 +-
tests/clos.impure.lisp | 7 +++
tests/mop.impure.lisp | 16 ++++---
16 files changed, 144 insertions(+), 93 deletions(-)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 6c62526..b20ba2d 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 d88858c..1690ca4 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 741525a..82529b5 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
- "~@<can't find type for specializer ~S in ~S.~@:>"
- 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
+ "~@<can't find type for specializer ~S in ~S.~@:>"
+ 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 3565b52..31c63c1 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 3d3d2c2..9e7e7ed 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 fbb6f7f..b87a31e 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 9f6b6ed..40e4652 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 3821cfc..bbce4dd 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 0b633a6..cfe4682 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 3bb68cd..93a7ee6 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 2ed6c9f..e34da05 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 fc781d0..0344e75 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 8189300..2645d5b 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 "~@<The class ~S was specified as a ~
super-class of the class ~S, ~
but the meta-classes ~S and ~S are incompatible. ~
@@ -494,6 +495,29 @@
(add-slot-accessors class direct-slots definition-source)
(make-preliminary-layout class))
+(define-condition invalid-superclass (reference-condition error)
+ ((class :initarg :class :reader invalid-superclass-class)
+ (superclass :initarg :superclass :reader invalid-superclass-superclass))
+ (:report
+ (lambda (c s)
+ (let ((class (invalid-superclass-class c))
+ (superclass (invalid-superclass-superclass c)))
+ (format s
+ "~@<The class ~S was specified as a superclass of the ~
+ class ~S, but the metaclasses ~S and ~S are ~
+ incompatible. ~@[Define a method for ~S to avoid this ~
+ 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."))
+ `(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 built-in-class)) nil)))
+(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 6918b12..c4fe49b 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 "~@<PCL cannot handle the specializer ~S ~
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index b6db2a7..70464ea 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -2132,4 +2132,11 @@
(assert (= (x-633911 (make-instance 'a-633911)) 10)))
+(with-test (:name (built-in-class :subclass error))
+ (flet ((mapper (c)
+ (when (and (class-name c) (typep c 'built-in-class))
+ (assert (raises-error? (eval `(defclass ,(gensym) (,(class-name c))
+ ())))))))
+ (sb-pcl::map-all-classes #'mapper)))
+
;;;; success
diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index 01b2796..4b92178 100644
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -357,7 +357,7 @@
(sl-option (first (sb-mop:class-direct-slots
(find-class 'test-multiple-slot-option-bug))))))))
-;;; bug reported by Bruno Haibel on sbcl-devel 2004-11-19: AMOP requires
+;;; bug reported by Bruno Haible on sbcl-devel 2004-11-19: AMOP requires
;;; that CLASS-PROTOYPE signals an error if the class is not yet finalized
(defclass prototype-not-finalized-sub (prototype-not-finalized-super) ())
(multiple-value-bind (val err)
@@ -366,12 +366,14 @@
(assert (typep err 'error)))
;;; AMOP says so
-(find-method (fdefinition 'sb-mop:allocate-instance) () '(built-in-class))
-(dolist (class-name '(fixnum bignum symbol))
- (let ((class (find-class class-name)))
- (multiple-value-bind (value error) (ignore-errors (allocate-instance class))
- (assert (null value))
- (assert (typep error 'error)))))
+(with-test (:name (allocate-instance built-in-class error))
+ (dolist (class-name '(fixnum bignum symbol t))
+ (let ((class (find-class class-name)))
+ (assert (typep class 'built-in-class))
+ (multiple-value-bind (value error)
+ (ignore-errors (allocate-instance class))
+ (assert (null value))
+ (assert (typep error 'error))))))
;;; bug reported by David Morse: direct-subclass update protocol was broken
(defclass vegetable () ())
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|