X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.impure.lisp;h=35118d0cabd825ec633f47883b51cb479a0abaa9;hb=a51d83191034919bc76367268929e234d62164db;hp=3c3ae3e065e9081c7967231ec41f277bf08e9d3c;hpb=2d237dbc3edb1f6f5337ab19dd74a317e43234db;p=sbcl.git diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 3c3ae3e..35118d0 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -15,8 +15,10 @@ ;;;; However, this seems a good a way as any of ensuring that we have ;;;; no regressions. +(load "test-util.lisp") + (defpackage "MOP-TEST" - (:use "CL" "SB-MOP" "ASSERTOID")) + (:use "CL" "SB-MOP" "ASSERTOID" "TEST-UTIL")) (in-package "MOP-TEST") @@ -198,6 +200,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 +228,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 +386,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) @@ -434,7 +455,7 @@ ((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 +(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)) @@ -461,5 +482,77 @@ () (: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))) + +;;; Check that MAKE-METHOD-LAMBDA which wraps the original body doesn't +;;; break RETURN-FROM. +(defclass wrapped-generic (standard-generic-function) + () + (:metaclass sb-mop:funcallable-standard-class)) + +(defmethod sb-mop:make-method-lambda ((gf wrapped-generic) method lambda env) + (call-next-method gf method + `(lambda ,(second lambda) + (flet ((default () :default)) + ,@(cddr lambda))) + env)) + +(defgeneric wrapped (x) + (:generic-function-class wrapped-generic)) + +(defmethod wrapped ((x cons)) + (return-from wrapped (default))) + +(with-test (:name :make-method-lambda-wrapping+return-from) + (assert (eq :default (wrapped (cons t t))))) + +(with-test (:name :slow-method-is-fboundp) + (assert (fboundp '(sb-pcl::slow-method wrapped (cons)))) + (assert (eq :default (funcall #'(sb-pcl::slow-method wrapped (cons)) (list (cons t t)) nil)))) + ;;;; success