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*))))) - ,@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 + ,@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)