X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.impure.lisp;h=c362778563bda5797d3376f738b2f020ed42f5aa;hb=e66288cd5588b336b79a7e19f1c884e4e3263d53;hp=287655af5ed5115e07f88c58a9706834a664be98;hpb=175c318c892b0627b36fa3c4db66f59680242204;p=sbcl.git diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 287655a..c362778 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") @@ -198,6 +198,7 @@ :name 'y :allocation :instance)))) (defclass dummy-ctais () ((x :allocation :class))) +(finalize-inheritance (find-class 'class-to-add-instance-slot)) (assert (equal (mapcar #'slot-definition-allocation (class-slots (find-class 'class-to-add-instance-slot))) ;; FIXME: is the order really guaranteed? @@ -225,6 +226,7 @@ :name 'y :allocation :class)))) (defclass dummy-ctacs () ((x :allocation :class))) +(finalize-inheritance (find-class 'class-to-add-class-slot)) (assert (equal (mapcar #'slot-definition-allocation (class-slots (find-class 'class-to-add-class-slot))) '(:class :class))) @@ -382,6 +384,23 @@ (let ((subs (sb-mop:class-direct-subclasses (find-class 'bug-331-super)))) (assert (= 1 (length subs))) (assert (eq (car subs) (find-class 'bug-331-sub)))) +;;; (addendum to test for #331: conditions suffered the same problem) +(define-condition condition-bug-331-super () ()) +(define-condition condition-bug-331-sub (condition-bug-331-super) ()) +(let ((subs (sb-mop:class-direct-subclasses + (find-class 'condition-bug-331-super)))) + (assert (= 1 (length subs))) + (assert (eq (car subs) (find-class 'condition-bug-331-sub)))) +;;; (addendum to the addendum: the fix for this revealed breakage in +;;; REINITIALIZE-INSTANCE) +(define-condition condition-bug-331a () ((slot331a :reader slot331a))) +(reinitialize-instance (find-class 'condition-bug-331a)) +(let* ((gf #'slot331a) + (methods (sb-mop:generic-function-methods gf))) + (assert (= (length methods) 1)) + (assert (eq (car methods) + (find-method #'slot331a nil + (list (find-class 'condition-bug-331a)))))) ;;; detection of multiple class options in defclass, reported by Bruno Haible (defclass option-class (standard-class) @@ -429,4 +448,83 @@ (: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)))) + +;;; we should be able to make classes with silly names +(make-instance 'standard-class :name 3) +(defclass foo () ()) +(reinitialize-instance (find-class 'foo) :name '(a b)) + +;;; classes (including anonymous ones) and eql-specializers should be +;;; allowed to be specializers. +(defvar *anonymous-class* + (make-instance 'standard-class + :direct-superclasses (list (find-class 'standard-object)))) +(defvar *object-of-anonymous-class* + (make-instance *anonymous-class*)) +(eval `(defmethod method-on-anonymous-class ((obj ,*anonymous-class*)) 41)) +(assert (eql (method-on-anonymous-class *object-of-anonymous-class*) 41)) +(eval `(defmethod method-on-anonymous-class + ((obj ,(intern-eql-specializer *object-of-anonymous-class*))) + 42)) +(assert (eql (method-on-anonymous-class *object-of-anonymous-class*) 42)) + +;;; accessors can cause early finalization, which caused confusion in +;;; the system, leading to uncompileable TYPEP problems. +(defclass funcallable-class-for-typep () + ((some-slot-with-accessor :accessor some-slot-with-accessor)) + (:metaclass funcallable-standard-class)) +(compile nil '(lambda (x) (typep x 'funcallable-class-for-typep))) + +;;; even anonymous classes should be valid types +(let* ((class1 (make-instance 'standard-class :direct-superclasses (list (find-class 'standard-object)))) + (class2 (make-instance 'standard-class :direct-superclasses (list class1)))) + (assert (subtypep class2 class1)) + (assert (typep (make-instance class2) class1))) + +;;; ensure-class got its treatment of :metaclass wrong. +(ensure-class 'better-be-standard-class :direct-superclasses '(standard-object) + :metaclass 'standard-class + :metaclass 'funcallable-standard-class) +(assert (eq (class-of (find-class 'better-be-standard-class)) + (find-class 'standard-class))) + +;;; CLASS-SLOTS should signal an error for classes that are not yet +;;; finalized. Reported by Levente Meszaros on sbcl-devel. +(defclass has-slots-but-isnt-finalized () (a b c)) +(let ((class (find-class 'has-slots-but-isnt-finalized))) + (assert (not (sb-mop:class-finalized-p class))) + (assert (raises-error? (sb-mop:class-slots class) sb-kernel::reference-condition))) + ;;;; success