From: Christophe R. <cr...@us...> - 2006-07-25 16:06:43
|
Update of /cvsroot/sbcl/sbcl/tests In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12194/tests Modified Files: clos.impure.lisp mop-18.impure-cload.lisp Log Message: 0.9.14.32: Bandage for James Y Knight "internal PCL type error" sbcl-devel 2006-06-20. ... don't let invalid-wrappers near a cache in MAKE-EMF-CACHE. ... test case (+ whitespace) Note that MAKE-EMF-CACHE via MEC-ALL-CLASSES-FOO functions is hideously written, and will perform the same work several times, pointlessly. Rather than build up several large lists with duplicated class lists between them, it might be sensible to perform some kind of walk down the class hierarchies, performing wrapper invalidation and regeneration and class finalization as required. Index: clos.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure.lisp,v retrieving revision 1.82 retrieving revision 1.83 diff -u -d -r1.82 -r1.83 --- clos.impure.lisp 17 Jul 2006 12:28:14 -0000 1.82 +++ clos.impure.lisp 25 Jul 2006 16:06:31 -0000 1.83 @@ -1320,4 +1320,30 @@ (defclass class-with-odd-class-name-method () ((a :accessor class-name))) +;;; another case where precomputing (this time on PRINT-OBJET) and +;;; lazily-finalized classes caused problems. (report from James Y +;;; Knight sbcl-devel 20-07-2006) + +(defclass base-print-object () ()) +;;; this has the side-effect of finalizing BASE-PRINT-OBJECT, and +;;; additionally the second specializer (STREAM) changes the cache +;;; structure to require two keys, not just one. +(defmethod print-object ((o base-print-object) (s stream)) + nil) + +;;; unfinalized as yet +(defclass sub-print-object (base-print-object) ()) +;;; the accessor causes an eager finalization +(defclass subsub-print-object (sub-print-object) + ((a :accessor a))) + +;;; triggers a discriminating function (and so cache) recomputation. +;;; The method on BASE-PRINT-OBJECT will cause the system to attempt +;;; to fill the cache for all subclasses of BASE-PRINT-OBJECT which +;;; have valid wrappers; however, in the course of doing so, the +;;; SUB-PRINT-OBJECT class gets finalized, which invalidates the +;;; SUBSUB-PRINT-OBJECT wrapper; if an invalid wrapper gets into a +;;; cache with more than one key, then failure ensues. +(reinitialize-instance #'print-object) + ;;;; success Index: mop-18.impure-cload.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/mop-18.impure-cload.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- mop-18.impure-cload.lisp 20 Jul 2006 11:02:19 -0000 1.1 +++ mop-18.impure-cload.lisp 25 Jul 2006 16:06:31 -0000 1.2 @@ -32,7 +32,7 @@ (when *in-reinitialize-instance* (setf *finalized-class* class))) -(defmethod reinitialize-instance :around +(defmethod reinitialize-instance :around ((class test-standard-class) &key &allow-other-keys) (let ((*in-reinitialize-instance* t)) (call-next-method))) @@ -52,16 +52,16 @@ (defclass test-funcallable-standard-class (funcallable-standard-class) ()) (defmethod validate-superclass - ((class test-funcallable-standard-class) + ((class test-funcallable-standard-class) (superclass funcallable-standard-class)) t) -(defmethod finalize-inheritance :before +(defmethod finalize-inheritance :before ((class test-funcallable-standard-class)) (when *in-reinitialize-instance* (setf *finalized-class* class))) -(defmethod reinitialize-instance :around +(defmethod reinitialize-instance :around ((class test-funcallable-standard-class) &key &allow-other-keys) (let ((*in-reinitialize-instance* t)) (call-next-method))) @@ -74,7 +74,7 @@ (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) +(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 +(assert (null (class-slots (find-class 'test-funcallable-standard-object)))) |