From b49f85124decb6b5e32e7a3919c024528680a7ac Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 8 Dec 2005 18:12:59 +0000 Subject: [PATCH] 0.9.7.21: Make SB-PCL::MAP-ALL-CLASSES hit each class Once And Only Once. --- src/pcl/dfun.lisp | 17 ++++++++++------- tests/clos.pure.lisp | 7 +++++++ version.lisp-expr | 2 +- 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 15601a1..47debc0 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1645,15 +1645,18 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 '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))))) diff --git a/tests/clos.pure.lisp b/tests/clos.pure.lisp index 377c7e8..5a20e88 100644 --- a/tests/clos.pure.lisp +++ b/tests/clos.pure.lisp @@ -39,3 +39,10 @@ (simple-condition-format-arguments err))) (declare (ignore value)) (assert (not format-err)))) + +;;; another not (user-)observable behaviour: make sure that +;;; sb-pcl::map-all-classes calls its function on each class once and +;;; exactly once. +(let (result) + (sb-pcl::map-all-classes (lambda (c) (push c result))) + (assert (equal result (remove-duplicates result)))) diff --git a/version.lisp-expr b/version.lisp-expr index 06701d6..0ffa9da 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.7.20" +"0.9.7.21" -- 1.7.10.4