From: Christophe Rhodes Date: Tue, 15 Oct 2002 09:23:21 +0000 (+0000) Subject: 0.7.8.38: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=63b936310ea60482b6903126d20a9b68f560de4c;p=sbcl.git 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) --- diff --git a/NEWS b/NEWS index 6c65e6a..c76e8d3 100644 --- a/NEWS +++ b/NEWS @@ -1311,8 +1311,12 @@ changes in sbcl-0.7.9 relative to sbcl-0.7.8: * fixed bug 142: The FFI conversion of C string values to Lisp string values no longer conses excessively. (thanks to Nathan Froyd porting Raymond Toy's fix to CMU CL) - * improved MOP conformance in PCL (thanks to Nathan Froyd porting - Gerd Moellman's work in CMU CL) + * began to systematize and improve MOP conformance in PCL (thanks to + Nathan Froyd, Gerd Moellman and Pierre Mai): + ** SLOT-DEFINITION-ALLOCATION now returns :CLASS, not the class + itself; + ** GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER is now implemented; + ** FINALIZE-INHERITANCE is now called on class finalization. * fixed bug 202: The compiler no longer fails on functions whose derived types contradict their declared type. * DEFMACRO is implemented via EVAL-WHEN instead of IR1 translation, diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ed9995e..7b4c293 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -676,9 +676,24 @@ ;;; This is called by :after shared-initialize whenever a class is initialized ;;; or reinitialized. The class may or may not be finalized. (defun update-class (class finalizep) + ;; Comment from Gerd Moellmann: + ;; + ;; Note that we can't simply delay the finalization when CLASS has + ;; no forward referenced superclasses because that causes bootstrap + ;; problems. + (when (and (not finalizep) + (not (class-finalized-p class)) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (return-from update-class)) (when (or finalizep (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) (update-cpl class (compute-class-precedence-list class)) + ;; This invocation of UPDATE-SLOTS, in practice, finalizes the + ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE + ;; is called at finalization, so that MOP programmers can hook + ;; into the system as described in "Class Finalization Protocol" + ;; (section 5.5.2 of AMOP). (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 6c81e86..5b65f1c 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -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)) @@ -45,5 +46,37 @@ currently, better put in a quick test in the hope that we can fix it soon: (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) diff --git a/version.lisp-expr b/version.lisp-expr index 3a3b87d..986b2c4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.8.37" +"0.7.8.38"