Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12194/src/pcl
Modified Files:
methods.lisp std-class.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: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -d -r1.57 -r1.58
--- methods.lisp 17 Jul 2006 12:28:14 -0000 1.57
+++ methods.lisp 25 Jul 2006 16:06:31 -0000 1.58
@@ -1039,7 +1039,11 @@
;; invalidate wrappers.
(let ((wrappers (get-wrappers-from-classes
nkeys wrappers classes metatypes)))
- (setq cache (fill-cache cache wrappers value)))))))))
+ (when (if (atom wrappers)
+ (not (invalid-wrapper-p wrappers))
+ (every (complement #'invalid-wrapper-p)
+ wrappers))
+ (setq cache (fill-cache cache wrappers value))))))))))
(if classes-list
(mapc #'add-class-list classes-list)
(dolist (method (generic-function-methods generic-function))
Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -d -r1.100 -r1.101
--- std-class.lisp 20 Jul 2006 11:02:19 -0000 1.100
+++ std-class.lisp 25 Jul 2006 16:06:31 -0000 1.101
@@ -866,7 +866,7 @@
wrapper nwrapper)
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
- ((null slots)
+ ((null slots)
(when dupes
(style-warn
"~@<slot names with the same SYMBOL-NAME but ~
@@ -875,7 +875,7 @@
class dupes)))
(let* ((slot (car slots))
(oslots (remove (slot-definition-name slot) (cdr slots)
- :test #'string/=
+ :test #'string/=
:key #'slot-definition-name)))
(when oslots
(pushnew (cons (slot-definition-name slot)
|