From: Christophe R. <cr...@us...> - 2002-10-15 09:23:24
|
Update of /cvsroot/sbcl/sbcl/tests In directory usw-pr-cvs1:/tmp/cvs-serv8615/tests Modified Files: mop.impure.lisp Log Message: 0.7.8.38: Apply Gerd Moellmann's patch for UPDATE-CLASS / FINALIZE-INHERITANCE problems (as reported on cmucl-imp by Kevin Rosenberg 2002-10-14) ... and add some more MOP tests (see Entomotomy bug finalize-instance-not-being-called-on-class-finalization) Index: mop.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/mop.impure.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- mop.impure.lisp 12 Oct 2002 16:02:38 -0000 1.1 +++ mop.impure.lisp 15 Oct 2002 09:23:21 -0000 1.2 @@ -21,7 +21,8 @@ (:use "CL")) (in-package "MOP-TEST") - + +;;; Readers for Generic Function Metaobjects (pp. 216--218 of AMOP) (defgeneric fn-with-odd-arg-precedence (a b c) (:argument-precedence-order b c a)) @@ -44,6 +45,38 @@ (let ((ll (sb-pcl:generic-function-lambda-list #'documentation))) (list (nth ll 1) (nth ll 0))))) ||# + +;;; Readers for Slot Definition Metaobjects (pp. 221--224 of AMOP) + +;;; Ensure that SLOT-DEFINITION-ALLOCATION returns :INSTANCE/:CLASS as +;;; appropriate. +(defclass sdm-test-class () + ((an-instance-slot :accessor an-instance-slot) + (a-class-slot :allocation :class :accessor a-class-slot))) +(dolist (m (list (list #'an-instance-slot :instance) + (list #'a-class-slot :class))) + (let ((methods (sb-pcl:generic-function-methods (car m)))) + (assert (= (length methods) 1)) + (assert (eq (sb-pcl:slot-definition-allocation + (sb-pcl:accessor-method-slot-definition + (car methods))) + (cadr m))))) + +;;; Class Finalization Protocol (see section 5.5.2 of AMOP) +(let ((finalized-count 0)) + (defmethod sb-pcl:finalize-inheritance :after ((x sb-pcl::standard-class)) + (incf finalized-count)) + (defun get-count () finalized-count)) +(defclass finalization-test-1 () ()) +(make-instance 'finalization-test-1) +(assert (= (get-count) 1)) +(defclass finalization-test-2 (finalization-test-3) ()) +(assert (= (get-count) 1)) +(defclass finalization-test-3 () ()) +(make-instance 'finalization-test-3) +(assert (or (= (get-count) 2) (= (get-count) 3))) +(make-instance 'finalization-test-2) +(assert (= (get-count) 3)) ;;;; success (sb-ext:quit :unix-status 104) |