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))