[cells-cvs] CVS Celtk

[ktilton]

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv7353

Modified Files:
	CELTK.lpr togl.lisp 
Log Message:
Get destroy callbacks working on Togls

--- /project/cells/cvsroot/Celtk/CELTK.lpr	2006/05/24 20:38:54	1.12
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2006/05/27 06:04:22	1.13
@@ -10,6 +10,7 @@
                  (make-instance 'module :name "tk-interp.lisp")
                  (make-instance 'module :name "tk-events.lisp")
                  (make-instance 'module :name "tk-object.lisp")
+                 (make-instance 'module :name "fileevent.lisp")
                  (make-instance 'module :name "widget.lisp")
                  (make-instance 'module :name "font.lisp")
                  (make-instance 'module :name "layout.lisp")
@@ -103,7 +104,7 @@
   :old-space-size 256000
   :new-space-size 6144
   :runtime-build-option :standard
-  :on-initialization 'celtk::tk-test
+  :on-initialization 'celtk::test-fileevent
   :on-restart 'do-default-restart)
 
 ;; End of Project Definition
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/05/26 17:50:36	1.7
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/05/27 06:04:22	1.8
@@ -98,7 +98,7 @@
   ;(assert (not (zerop (tk-init-stubs interp "8.1" 0))))
   (togl_init interp)
   (togl-create-func (callback togl-create))
-  ;;; needed? (togl-destroy-func (callback togl-destroy)
+  (togl-destroy-func (callback togl-destroy))
   (togl-display-func (callback togl-display))
   (togl-reshape-func (callback togl-reshape))
   (togl-timer-func (callback togl-timer)) ;; probably want to make this optional
@@ -175,6 +175,7 @@
            (let ((,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*))
                               (gethash (togl-ident ,ptr-var)(dictionary *tkw*)))))
              , at preamble
+             (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*)))
              (,(intern uc$) ,self-var))))
        (defmethod ,(intern uc$) :around ((self togl))
          (if (,(intern cb-slot$) self)
@@ -183,7 +184,9 @@
        (defmethod ,(intern uc$) ((self togl))))))
 
 (def-togl-callback create ()
-    (setf (togl-ptr self) togl-ptr))
+  (setf (togl-ptr self) togl-ptr)
+  (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
+
 (def-togl-callback display ())
 (def-togl-callback reshape ())
 (def-togl-callback destroy ())
@@ -195,3 +198,16 @@
     (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}"
       (path self)(tk-configurations self)))) ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create
 
+
+;;;
+;;;(DEFCFUN ("Togl_DestroyFunc" TOGL-DESTROY-FUNC) :VOID (CALLBACK :POINTER))
+;;;(defcallback togl-destroy :void ((togl-ptr :pointer))
+;;;  (trc "togl-destroy ptr" togl-ptr (loop for k being the hash-keys of (tkwins *tkw*)
+;;;                                         collecting k))
+;;;  (unless (c-stopped)
+;;;    (let ((self (or (gethash (pointer-address togl-ptr) (tkwins *tkw*)) (gethash (togl-ident togl-ptr) (dictionary *tkw*)))))
+;;;      
+;;;      (togl-destroy-using-class self))))
+;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS :AROUND ((SELF TOGL))
+;;;  (IF (CB-DESTROY SELF) (FUNCALL (CB-DESTROY SELF) SELF) (CALL-NEXT-METHOD)))
+;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS ((SELF TOGL)))
\ No newline at end of file