From f65bc6e5d42bbce340cd86e9b1c210327a70531a Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 20 Jul 2006 11:02:18 +0000 Subject: [PATCH] 0.9.14.29: Make REINITIALIZE-INSTANCE (well, SHARED-INITIALIZE in fact, but I'm pretty sure that's OK) call FINALIZE-INHERITANCE rather than UPDATE-CLASS if the class has already been finalized, as required by AMOP. --- NEWS | 3 ++ src/pcl/std-class.lisp | 45 +++++++++++----------- tests/mop-18.impure-cload.lisp | 80 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 107 insertions(+), 23 deletions(-) create mode 100644 tests/mop-18.impure-cload.lisp diff --git a/NEWS b/NEWS index 54afc8b..cfc0b4b 100644 --- a/NEWS +++ b/NEWS @@ -30,6 +30,9 @@ changes in sbcl-0.9.15 relative to sbcl-0.9.14: * fixed bug: SPECIALIZER metaobjects (including anonymous classes and EQL-SPECIALIZERs) can be used as specializers to DEFMETHOD. (reported by Pascal Costanza) + * fixed bug: FINALIZE-INHERITANCE is called from + REINITIALIZE-INSTANCE on classes when the class has previously + been finalized, as required by AMOP. * minor code generation optimizations: ** better register allocation in CLOS dispatching functions ** overflow detection when coercing signed bytes to fixnums on x86-64 diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 28bbf00..02862cf 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -408,27 +408,10 @@ (push old collect))))) (nreverse collect))) (add-direct-subclasses class direct-superclasses) - (update-class class nil) - (do* ((slots (slot-value class 'slots) (cdr slots)) - (dupes nil)) - ((null slots) (when dupes - (style-warn - ;; FIXME: the indentation request ("~4I") - ;; below appears not to do anything. Finding - ;; out why would be nice. -- CSR, 2003-04-24 - "~@~@:>" - class - dupes))) - (let* ((slot (car slots)) - (oslots (remove (slot-definition-name slot) (cdr slots) - :test #'string/= :key #'slot-definition-name))) - (when oslots - (pushnew (cons (slot-definition-name slot) - (mapcar #'slot-definition-name oslots)) - dupes - :test #'string= :key #'car)))) + (if (class-finalized-p class) + ;; required by AMOP, "Reinitialization of Class Metaobjects" + (finalize-inheritance class) + (update-class class nil)) (add-slot-accessors class direct-slots) (make-preliminary-layout class)) @@ -880,7 +863,25 @@ (wrapper-instance-slots-layout nwrapper) nlayout (wrapper-class-slots nwrapper) nwrapper-class-slots (wrapper-no-of-instance-slots nwrapper) nslots - wrapper nwrapper)) + wrapper nwrapper) + (do* ((slots (slot-value class 'slots) (cdr slots)) + (dupes nil)) + ((null slots) + (when dupes + (style-warn + "~@~@:>" + class dupes))) + (let* ((slot (car slots)) + (oslots (remove (slot-definition-name slot) (cdr slots) + :test #'string/= + :key #'slot-definition-name))) + (when oslots + (pushnew (cons (slot-definition-name slot) + (mapcar #'slot-definition-name oslots)) + dupes + :test #'string= :key #'car))))) (setf (slot-value class 'finalized-p) t) (unless (eq owrapper nwrapper) (update-pv-table-cache-info class) diff --git a/tests/mop-18.impure-cload.lisp b/tests/mop-18.impure-cload.lisp new file mode 100644 index 0000000..925c4ae --- /dev/null +++ b/tests/mop-18.impure-cload.lisp @@ -0,0 +1,80 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; this file tests the protocol for Reinitialization of Class Metaobjects + +(defpackage "MOP-18" + (:use "CL" "SB-MOP")) + +(in-package "MOP-18") + +(defvar *in-reinitialize-instance* nil) + +(defvar *finalized-class* nil) + +(defclass test-standard-class (standard-class) ()) + +(defmethod validate-superclass + ((class test-standard-class) (superclass standard-class)) + t) + +(defmethod finalize-inheritance :before ((class test-standard-class)) + (when *in-reinitialize-instance* + (setf *finalized-class* class))) + +(defmethod reinitialize-instance :around + ((class test-standard-class) &key &allow-other-keys) + (let ((*in-reinitialize-instance* t)) + (call-next-method))) + +(defclass test-standard-object () ((slot)) + (:metaclass test-standard-class)) + +(unless (class-finalized-p (find-class 'test-standard-object)) + (finalize-inheritance (find-class 'test-standard-object))) + +(assert (class-slots (find-class 'test-standard-object))) +(assert (null *finalized-class*)) +(reinitialize-instance (find-class 'test-standard-object) :direct-slots nil) +(assert (eq *finalized-class* (find-class 'test-standard-object))) +(assert (null (class-slots (find-class 'test-standard-object)))) + +(defclass test-funcallable-standard-class (funcallable-standard-class) ()) + +(defmethod validate-superclass + ((class test-funcallable-standard-class) + (superclass funcallable-standard-class)) + t) + +(defmethod finalize-inheritance :before + ((class test-funcallable-standard-class)) + (when *in-reinitialize-instance* + (setf *finalized-class* class))) + +(defmethod reinitialize-instance :around + ((class test-funcallable-standard-class) &key &allow-other-keys) + (let ((*in-reinitialize-instance* t)) + (call-next-method))) + +(defclass test-funcallable-standard-object () ((slot)) + (:metaclass test-funcallable-standard-class)) + +(unless (class-finalized-p (find-class 'test-funcallable-standard-object)) + (finalize-inheritance (find-class 'test-funcallable-standard-object))) + +(assert (class-slots (find-class 'test-funcallable-standard-object))) +(assert (eq *finalized-class* (find-class 'test-standard-object))) +(reinitialize-instance (find-class 'test-funcallable-standard-object) + :direct-slots nil) +(assert (eq *finalized-class* (find-class 'test-funcallable-standard-object))) +(assert (null (class-slots (find-class 'test-funcallable-standard-object)))) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index dcae6c5..55655dd 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.14.28" +"0.9.14.29" -- 1.7.10.4