[cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp

[Peter Denno]

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv8345/cells-gtk

Modified Files:
	widgets.lisp 
Log Message:
Make gtk-object-forget recursive.
Date: Sat Feb 26 23:31:41 2005
Author: pdenno

Index: root/cells-gtk/widgets.lisp
diff -u root/cells-gtk/widgets.lisp:1.10 root/cells-gtk/widgets.lisp:1.11
--- root/cells-gtk/widgets.lisp:1.10	Wed Feb 16 23:24:07 2005
+++ root/cells-gtk/widgets.lisp	Sat Feb 26 23:31:41 2005
@@ -65,18 +65,11 @@
                         "gtk-object-store id ~a already known as ~a, not ~a"
                         hash-id known gtk-object)))))
 
-(defun gtk-object-forget (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id)))
-  (assert *gtk-objects*)
-  (let ((known (gethash hash-id *gtk-objects*)))
-    (cond
-     ((not known))
-     ((eql known gtk-object)
-      (setf (gethash hash-id *gtk-objects*) nil))
-     (t
-      (gtk-report-error gtk-object-id-error 
-          "gtk-object-store id ~a known as ~a, not forgettable ~a"
-        hash-id known gtk-object)))))
-
+(defun gtk-object-forget (gtk-id gtk-object)
+  (when gtk-id
+    (assert *gtk-objects*)
+    (remhash (pointer-address gtk-id) *gtk-objects*)
+    (mapc #'(lambda (k) (gtk-object-forget (id k) k)) (kids gtk-object))))
 
 (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id)))
   (when *gtk-objects*
@@ -117,7 +110,7 @@
       (intern (format nil "GTK-~a~{-~a~}" class slot-access) :gtk-ffi))))
 
 ;;; --- widget --------------------
-
+;;; Define handlers that recover the the callback defined on the widget
 (defmacro def-gtk-event-handler (event)
   `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event)))
      ((widget :pointer-void) (event :pointer-void) (data :pointer-void))
@@ -381,6 +374,7 @@
 (def-c-output .kids ((self window))
   (assert-bin self)
   (dolist (kid new-value)
+    (when *gtk-debug* (format t "~% window ~A has kid ~A" self kid))
     (when *gtk-debug* (trc nil "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output))
     (gtk-container-add (id self) (id kid)))
   #+clisp (call-next-method))