[mcclim-cvs] CVS mcclim

[rgoldman]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv11817

Modified Files:
	recording.lisp 
Log Message:
Two fixes to the output-record protocol implementation, per discussion
on #lisp in the week of 3 September 2007:

1.  The standard-tree-output-record did not implement an
output-record-count method.  antifuchs supplied one.

2.  There was a default method for output-record-count that masked the
bug in #1.  It returned zero for any object of any output-record
subclass that did not implement output-record-count.  Per hefner's
suggestion, this method has been moved down from basic-output-record
to displayed-output-record.  We hope that this will cause earlier
failure in cases where methods are missing.



--- /project/mcclim/cvsroot/mcclim/recording.lisp	2007/07/18 16:31:27	1.134
+++ /project/mcclim/cvsroot/mcclim/recording.lisp	2007/09/07 16:49:11	1.135
@@ -619,7 +619,7 @@
       record
     (setf (rectangle-edges* record) (values x y x y))))
 
-(defmethod output-record-count ((record basic-output-record))
+(defmethod output-record-count ((record displayed-output-record))
   0)
 
 (defmethod map-over-output-records-1
@@ -971,6 +971,7 @@
   ((children :initform (%make-tree-output-record-tree)
              :accessor %tree-record-children)
    (children-hash :initform (make-hash-table :test #'eql) :reader %tree-record-children-cache)
+   (child-count :initform 0)
    (last-insertion-nr :initform 0 :accessor last-insertion-nr)))
 
 (defun %entry-in-children-cache (record entry)
@@ -992,25 +993,33 @@
   (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record)))))
     (spatial-trees:insert entry (%tree-record-children record))
     (setf (output-record-parent child) record)
-    (setf (%entry-in-children-cache record child) entry)))
+    (setf (%entry-in-children-cache record child) entry))
+  (incf (slot-value record 'child-count))
+  (values))
 
 (defmethod delete-output-record (child (record standard-tree-output-record) &optional (errorp t))
   (let ((entry (find child (spatial-trees:search (%entry-in-children-cache record child)
                                                  (%tree-record-children record))
                      :key #'tree-output-record-entry-record)))
-   (cond
-     ((not (null entry))
-      (spatial-trees:delete entry (%tree-record-children record))
-      (%remove-entry-from-children-cache record child)
-      (setf (output-record-parent child) nil))
-     (errorp (error "~S is not a child of ~S" child record)))))
+    (decf (slot-value record 'child-count))
+    (cond
+      ((not (null entry))
+       (spatial-trees:delete entry (%tree-record-children record))
+       (%remove-entry-from-children-cache record child)
+       (setf (output-record-parent child) nil))
+      (errorp (error "~S is not a child of ~S" child record)))))
 
 (defmethod clear-output-record ((record standard-tree-output-record))
-  (dolist (child (output-record-children record))
-    (setf (output-record-parent child) nil)
-    (%remove-entry-from-children-cache record child))
+  (map nil (lambda (child)
+             (setf (output-record-parent child) nil)
+             (%remove-entry-from-children-cache record child))
+       (output-record-children record))
+  (setf (slot-value record 'child-count) 0)
   (setf (%tree-record-children record) (%make-tree-output-record-tree)))
 
+(defmethod output-record-count ((record standard-tree-output-record))
+  (slot-value record 'child-count))
+
 (defun map-over-tree-output-records (function record rectangle sort-order function-args)
   (dolist (child (sort (spatial-trees:search rectangle
                                              (%tree-record-children record))