[Sbcl-commits] CVS: sbcl/src/pcl dfun.lisp,1.41,1.42

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18258/src/pcl

Modified Files:
	dfun.lisp 
Log Message:
0.9.7.21:
	Make SB-PCL::MAP-ALL-CLASSES hit each class Once And Only Once.


Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -d -r1.41 -r1.42
--- dfun.lisp	4 Nov 2005 11:18:37 -0000	1.41
+++ dfun.lisp	8 Dec 2005 18:13:00 -0000	1.42
@@ -1645,15 +1645,18 @@
                            'specializer-applicable-using-type-p
                            type)))))
 
-(defun map-all-classes (function &optional (root t))
-  (let ((braid-p (or (eq *boot-state* 'braid)
+(defun map-all-classes (fun &optional (root t))
+  (let ((all-classes (make-hash-table :test 'eq))
+        (braid-p (or (eq *boot-state* 'braid)
                      (eq *boot-state* 'complete))))
     (labels ((do-class (class)
-               (mapc #'do-class
-                     (if braid-p
-                         (class-direct-subclasses class)
-                         (early-class-direct-subclasses class)))
-               (funcall function class)))
+               (unless (gethash class all-classes)
+                 (setf (gethash class all-classes) t)
+                 (funcall fun class)
+                 (mapc #'do-class
+                       (if braid-p
+                           (class-direct-subclasses class)
+                           (early-class-direct-subclasses class))))))
       (do-class (if (symbolp root)
                     (find-class root)
                     root)))))