X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.impure.lisp;h=648b43bb85de39dc8282f2986c6e988c17599112;hb=4c5a011ccc355e3653b9490de6a2b3df5777e55d;hp=e446bffa579771e6d3a26daf0a8d189a31b29954;hpb=41d85303c73124856e193aea2c15f4e8f5bb9ec8;p=sbcl.git diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index e446bff..648b43b 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -89,7 +89,7 @@ ;;; that it is at least possible to define classes with that as a ;;; metaclass. (defclass gf-class (standard-generic-function) () - (:metaclass sb-pcl::funcallable-standard-class)) + (:metaclass funcallable-standard-class)) (defgeneric g (a b c) (:generic-function-class gf-class)) @@ -109,15 +109,15 @@ ;;; of all built-in-classes is of the relevant type) (assert (null (class-prototype (find-class 'null)))) -;;; simple consistency checks for the SB-PCL (perhaps AKA SB-MOP) -;;; package: all of the functionality specified in AMOP is in -;;; functions: -(assert (null (loop for x being each external-symbol in "SB-PCL" - unless (fboundp x) collect x))) -;;; and all generic functions in SB-PCL have at least one specified +;;; simple consistency checks for the SB-MOP package: all of the +;;; functionality specified in AMOP is in functions and classes: +(assert (null (loop for x being each external-symbol in "SB-MOP" + unless (or (fboundp x) (find-class x)) collect x))) +;;; and all generic functions in SB-MOP have at least one specified ;;; method, except for UPDATE-DEPENDENT -(assert (null (loop for x being each external-symbol in "SB-PCL" - unless (or (eq x 'update-dependent) +(assert (null (loop for x being each external-symbol in "SB-MOP" + unless (or (not (fboundp x)) + (eq x 'update-dependent) (not (typep (fdefinition x) 'generic-function)) (> (length (generic-function-methods (fdefinition x))) @@ -134,5 +134,202 @@ (assert (null *e-c-u-c-arg-order*)) (defclass e-c-u-c-arg-order () ()) (assert (eq *e-c-u-c-arg-order* t)) + +;;; verify that FIND-CLASS works after FINALIZE-INHERITANCE +(defclass automethod-class (standard-class) ()) +(defmethod validate-superclass ((c1 automethod-class) (c2 standard-class)) + t) +(defmethod finalize-inheritance :after ((x automethod-class)) + (format t "~&~S ~S~%" x (find-class (class-name x)))) +(defclass automethod-object () () + (:metaclass automethod-class)) +(defvar *automethod-object* (make-instance 'automethod-object)) +(assert (typep *automethod-object* 'automethod-object)) + +;;; COMPUTE-EFFECTIVE-SLOT-DEFINITION should take three arguments, one +;;; of which is the name of the slot. +(defvar *compute-effective-slot-definition-count* 0) +(defmethod compute-effective-slot-definition :before + (class (name (eql 'foo)) dsds) + (incf *compute-effective-slot-definition-count*)) +(defclass cesd-test-class () + ((foo :initarg :foo))) +(make-instance 'cesd-test-class :foo 3) +;;; FIXME: this assertion seems a little weak. I don't know why +;;; COMPUTE-EFFECTIVE-SLOT-DEFINITION gets called twice in this +;;; sequence, nor whether that's compliant with AMOP. -- CSR, +;;; 2003-04-17 +(assert (> *compute-effective-slot-definition-count* 0)) + +;;; this used to cause a nasty uncaught metacircularity in PCL. +(defclass substandard-method (standard-method) ()) +(defgeneric substandard-defgeneric (x y) + (:method-class substandard-method) + (:method ((x number) (y number)) (+ x y)) + (:method ((x string) (y string)) (concatenate 'string x y))) +(assert (= (substandard-defgeneric 1 2) 3)) +(assert (string= (substandard-defgeneric "1" "2") "12")) + +(let* ((x (find-class 'pathname)) + (xs (class-direct-subclasses x))) + (assert (>= (length xs) 1)) + (assert (member (find-class 'logical-pathname) xs))) + +;;; BUG 338: "MOP specializers as type specifiers" +;;; (reported by Bruno Haible sbcl-devel 2004-06-11) +(let* ((m (defmethod eql-specialized-method ((x (eql 4.0))) 3.0)) + (spec (first (sb-mop:method-specializers m)))) + (assert (not (typep 1 spec))) + (assert (typep 4.0 spec))) + +;;; BUG #334, relating to programmatic addition of slots to a class +;;; with COMPUTE-SLOTS. +;;; +;;; FIXME: the DUMMY classes here are to prevent class finalization +;;; before the compute-slots method is around. This should probably +;;; be done by defining the COMPUTE-SLOTS methods on a metaclass, +;;; which can be defined before. +;;; +;;; a. adding an :allocation :instance slot +(defclass class-to-add-instance-slot (dummy-ctais) ()) +(defmethod compute-slots ((c (eql (find-class 'class-to-add-instance-slot)))) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :instance)))) +(defclass dummy-ctais () ((x :allocation :class))) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-instance-slot))) + ;; FIXME: is the order really guaranteed? + '(:class :instance))) +(assert (typep (slot-definition-location + (cadr (class-slots (find-class 'class-to-add-instance-slot)))) + 'unsigned-byte)) +#| (assert (typep (slot-definition-location (car ...)) '???)) |# +(let ((x (make-instance 'class-to-add-instance-slot))) + (assert (not (slot-boundp x 'x))) + (setf (slot-value x 'x) t) + (assert (not (slot-boundp x 'y))) + (setf (slot-value x 'y) 1) + (assert (= 1 (slot-value x 'y)))) +(let ((x (make-instance 'class-to-add-instance-slot))) + (assert (slot-boundp x 'x)) + (assert (eq t (slot-value x 'x))) + (assert (not (slot-boundp x 'y)))) + +;;; b. adding an :allocation :class slot +(defclass class-to-add-class-slot (dummy-ctacs) ()) +(defmethod compute-slots ((c (eql (find-class 'class-to-add-class-slot)))) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :class)))) +(defclass dummy-ctacs () ((x :allocation :class))) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-class-slot))) + '(:class :class))) +(let ((x (make-instance 'class-to-add-class-slot))) + (assert (not (slot-boundp x 'x))) + (setf (slot-value x 'x) nil) + (assert (not (slot-boundp x 'y))) + (setf (slot-value x 'y) 1) + (assert (= 1 (slot-value x 'y)))) +(let ((x (make-instance 'class-to-add-class-slot))) + (assert (slot-boundp x 'x)) + (assert (eq nil (slot-value x 'x))) + (assert (slot-boundp x 'y)) + (assert (= 1 (slot-value x 'y)))) +;;; extra paranoia: check that we haven't broken the instance-slot class +(let ((x (make-instance 'class-to-add-instance-slot))) + (assert (slot-boundp x 'x)) + (assert (eq t (slot-value x 'x))) + (assert (not (slot-boundp x 'y)))) + +;;;; the CTOR optimization was insufficiently careful about its +;;;; assumptions: firstly, it failed with a failed AVER for +;;;; non-standard-allocation slots: +(defclass class-with-frob-slot () + ((frob-slot :initarg :frob-slot :allocation :frob))) +(handler-case + (funcall (compile nil '(lambda () + (make-instance 'class-with-frob-slot + :frob-slot 1)))) + (sb-int:bug (c) (error c)) + (error () "Probably OK: haven't implemented SLOT-BOUNDP-USING-CLASS")) +;;; secondly, it failed to take account of the fact that we might wish +;;; to customize (setf slot-value-using-class) +(defclass class-with-special-ssvuc () + ((some-slot :initarg :some-slot))) +(defvar *special-ssvuc-counter* 0) +(defmethod (setf slot-value-using-class) :before + (new-value class (instance class-with-special-ssvuc) slotd) + (incf *special-ssvuc-counter*)) +(let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc + :some-slot 1))))) + (assert (= *special-ssvuc-counter* 0)) + (funcall fun) + (assert (= *special-ssvuc-counter* 1)) + (funcall fun) + (assert (= *special-ssvuc-counter* 2))) +;;; and now with the customization after running the function once +(defclass class-with-special-ssvuc-2 () + ((some-slot :initarg :some-slot))) +(defvar *special-ssvuc-counter-2* 0) +(let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc-2 + :some-slot 1))))) + (assert (= *special-ssvuc-counter-2* 0)) + (funcall fun) + (assert (= *special-ssvuc-counter-2* 0)) + (defmethod (setf slot-value-using-class) :before + (new-value class (instance class-with-special-ssvuc-2) slotd) + (incf *special-ssvuc-counter-2*)) + (funcall fun) + (assert (= *special-ssvuc-counter-2* 1))) + +;;; vicious metacycle detection and resolution wasn't good enough: it +;;; didn't take account that the slots (and hence the slot readers) +;;; might be inherited from superclasses. This example, due to Bruno +;;; Haible, also tests programmatic addition of accessors. +(defclass auto-accessors-direct-slot-definition-class (standard-class) + ((containing-class-name :initarg :containing-class-name))) +(defmethod validate-superclass + ((c1 auto-accessors-direct-slot-definition-class) (c2 standard-class)) + t) +(defclass auto-accessors-class (standard-class) + ()) +(defmethod direct-slot-definition-class ((class auto-accessors-class) + &rest initargs) + (let ((dsd-class-name (gensym))) + (sb-pcl:ensure-class + dsd-class-name + :metaclass 'auto-accessors-direct-slot-definition-class + :direct-superclasses (list (find-class 'standard-direct-slot-definition)) + :containing-class-name (class-name class)) + (eval `(defmethod initialize-instance :after ((dsd ,dsd-class-name) + &rest args) + (when (and (null (slot-definition-readers dsd)) + (null (slot-definition-writers dsd))) + (let* ((containing-class-name + (slot-value (class-of dsd) 'containing-class-name)) + (accessor-name + (intern + (concatenate 'string + (symbol-name containing-class-name) + "-" + (symbol-name (slot-definition-name dsd))) + (symbol-package containing-class-name)))) + (setf (slot-definition-readers dsd) (list accessor-name)) + (setf (slot-definition-writers dsd) + (list (list 'setf accessor-name))))))) + (find-class dsd-class-name))) +(defmethod validate-superclass ((c1 auto-accessors-class) (c2 standard-class)) + t) +(defclass testclass15 () + ((x :initarg :x) (y)) + (:metaclass auto-accessors-class)) +(let ((inst (make-instance 'testclass15 :x 12))) + (assert (equal (list (testclass15-x inst) (setf (testclass15-y inst) 13)) + '(12 13)))) + ;;;; success (sb-ext:quit :unix-status 104)