[cells-cvs] CVS Celtk

[ktilton]

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

Modified Files:
	CELTK.lpr timer.lisp togl.lisp 
Log Message:
Not really changed for the most part.

--- /project/cells/cvsroot/Celtk/CELTK.lpr	2006/06/29 09:54:52	1.17
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2006/07/24 05:04:01	1.18
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 
--- /project/cells/cvsroot/Celtk/timer.lisp	2006/07/06 22:10:40	1.9
+++ /project/cells/cvsroot/Celtk/timer.lisp	2006/07/24 05:04:01	1.10
@@ -79,8 +79,8 @@
                      (funcall (^action) self)
                      (setf (^executed) t))))
    (after-factory :reader after-factory
-     :initform (c? (bwhen (rpt (eko (nil ">>> repeat") (when (eq (^state) :on)
-                               (^repeat))))
+     :initform (c? (bwhen (rpt (when (eq (^state) :on)
+                               (^repeat)))
                    (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution
                      (when (zerop (^executions))
                        (setf (elapsed self) (now)))
@@ -90,19 +90,23 @@
                        (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters
                          (set-timer self (^delay))))))))))
 
+(defobserver state ((self timer))
+  (unless (eq new-value :on)
+    (trc "bingo!!!!!!!!!!!!!!!!!!!!! state takes out timer" self)
+    (cancel-timer self)))
+
 (defun set-timer (self time)
   (let ((callback-id (symbol-name (gentemp "AFTER"))))
     (setf (gethash callback-id (dictionary *tkw*)) self)
     (setf (cancel-id self) (tk-eval "after ~a {do-on-command ~a}" time callback-id))))
 
 (defun cancel-timer (timer)
-  (setf (state timer) :off)
   (when (cancel-id timer)
-      (tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed
+    (tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed
 
 (defobserver timers ((self tk-object) new-value old-value)
   (dolist (k (set-difference old-value new-value))
-    (cancel-timer k)))
+    (setf (state k) :off))) ;; actually could be anything but :on
 
 
     
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/07/06 22:10:40	1.14
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/07/24 05:04:01	1.15
@@ -167,11 +167,14 @@
          (callback :pointer))
        (defcallback ,(intern cb$) :void ((,ptr-var :pointer))
          (unless (c-stopped)
-           (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))))
+           (bif (,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*))
+                             (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))
+             (progn
+               , 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))
+             (trc "WARNING: Togl callback ~a sees unknown togl pointer ~a :address ~a :ident ~a"
+               ,cb$ ,ptr-var (pointer-address ,ptr-var) (togl-ident ,ptr-var)))))
        (defmethod ,(intern uc$) :around ((self togl))
          (if (,(intern cb-slot$) self)
                (funcall (,(intern cb-slot$) self) self)