Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18670
Modified Files: Celtk.lisp demos.lisp ltktest-ci.lisp run.lisp timer.lisp widget.lisp Log Message: Window destruction looking OK
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/24 20:38:54 1.23 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 07:12:59 1.24 @@ -125,24 +125,25 @@ """ "\""))
(defun tk-format-now (fmt$ &rest fmt-args) - (let ((*print-circle* nil) - (tk$ (apply 'format nil fmt$ fmt-args))) - ; - ; --- debug stuff --------------------------------- - ; - (let ((yes '( "destroy")) - (no '())) - (declare (ignorable yes no)) - (when (and (find-if (lambda (s) (search s tk$)) yes) - (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk> ~a~%" tk$))) - (assert *tki*) - ; --- end debug stuff ------------------------------ - ; - ; --- serious stuff --- - ; - (setf *tk-last* tk$) - (tcl-eval-ex *tki* tk$))) + (unless (find *tkw* *windows-destroyed*) + (let ((*print-circle* nil) + (tk$ (apply 'format nil fmt$ fmt-args))) + ; + ; --- debug stuff --------------------------------- + ; + (let ((yes '( "destroy")) + (no '())) + (declare (ignorable yes no)) + (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (not (find-if (lambda (s) (search s tk$)) no))) + (format t "~&tk> ~a~%" tk$))) + (assert *tki*) + ; --- end debug stuff ------------------------------ + ; + ; --- serious stuff --- + ; + (setf *tk-last* tk$) + (tcl-eval-ex *tki* tk$))))
(defun tk-format (defer-info fmt$ &rest fmt-args) "Format then send to wish (via user queue)" --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/24 20:38:54 1.18 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/25 07:12:59 1.19 @@ -21,10 +21,10 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;;'one-button-window - 'ltktest-cells-inside - ;; 'menu-button-test + ;;'ltktest-cells-inside + ;;'menu-button-test ;;'spinbox-test - ;;'lotsa-widgets + 'lotsa-widgets ;; Now in Gears project 'gears-demo ))
@@ -32,15 +32,14 @@ () (:default-initargs :kids (c? (the-kids - (mk-frame-stack - :packing (c?pack-self) - :kids (c? (the-kids - (one-deep-menubar) - #+not (mk-menubar + (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) + (mk-frame-stack + :packing (c?pack-self) + :kids (c? (the-kids (mk-text-widget :id :my-text :md-value (c?n "hello, world") --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/24 20:38:54 1.6 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/25 07:12:59 1.7 @@ -332,7 +332,7 @@ (:virtualevent (trc "canvas virtual" (xsv name xe))) (:buttonpress - (TRC "canvas buttonpress" self (xsv x-root xe)(xsv y-root xe)) + (TRC nil "canvas buttonpress" self (xsv x-root xe)(xsv y-root xe)) (pop-up (^widget-menu :bkg-pop) (xsv x-root xe) (xsv y-root xe))))))
:menus (c? (the-kids @@ -382,7 +382,7 @@ :delay 1 ;; milliseconds since this gets passed unvarnished to TK after :action (lambda (timer) (declare (ignorable timer)) - (trc "timer fires!!" timer) + (trc nil "timer fires!!" timer) (incf (^angle-1) 0.1))))) :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) (wx (sin (* 0.1 (^angle-1))))) @@ -429,7 +429,7 @@ ; declaring them to the menu widget, it seems to me. In Celtk, they do. ; :underline 1 - :command "destroy .")))))) + :command "destroy .; break"))))))
(defmodel entry-numeric (entry) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/24 20:38:54 1.12 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/25 07:12:59 1.13 @@ -34,7 +34,7 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}") - (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer)) + (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))
(with-integrity () (setf *tkw* (make-instance root-class)) @@ -43,12 +43,13 @@
(tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . <Escape> {destroy .}") - (tk-format-now "bind . <Destroy> {event generate . <<window-destroyed>>}")
(tcl-do-one-event-loop))
(defun ensure-destruction (w) + (TRC nil "ensure-destruction entry" W) (unless (find w *windows-being-destroyed*) + (TRC nil "ensure-destruction not-to-being" W) (let ((*windows-being-destroyed* (cons w *windows-being-destroyed*))) (not-to-be w))))
@@ -61,6 +62,8 @@ (ensure-destruction *tkw*))) (:virtualevent (bwhen (n$ (xsv name xe)) + (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe)) + (tcl-get-string (xsv user-data xe)))) (case (read-from-string (string-upcase n$))
(close-window @@ -74,7 +77,8 @@ (bwhen (c (^on-command)) (funcall c self))))
- (otherwise (trc "main window sees unknown" n$))))))) + (otherwise (trc "main window sees unknown" n$)))))) + 0)
;; Our own event loop ! - Use this if it is desirable to do something ;; else between events @@ -82,14 +86,14 @@ (defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)")
(defun tcl-do-one-event-loop () - (loop while (progn (trc "checking num main windows") + (loop while (progn (trc nil "checking num main windows") (plusp (tk-get-num-main-windows))) - do (trc "calling Tcl_DoOneEvent" (tk-get-num-main-windows)) + do (trc nil "calling Tcl_DoOneEvent" (tk-get-num-main-windows)) (loop until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT - (trc "sleeping") + (trc nil "sleeping") (sleep *event-loop-delay*) ;; give the IDE a few cycles finally - (trc "Tcl-do-one-event-loop sees no more windows" *tki*) + (trc nil "Tcl-do-one-event-loop sees no more windows" *tki*) (tcl-delete-interp *tki*) ;; probably unnecessary (setf *tki* nil)))
--- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/24 20:38:54 1.7 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/25 07:12:59 1.8 @@ -82,11 +82,8 @@ :initform (c? (bwhen (rpt (eko (nil ">>> repeat") (when (eq (^state) :on) (^repeat)))) (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution - (if (zerop (^executions)) - (setf (elapsed self) (now)) - (when (and (numberp rpt) - (>= (^executions) rpt)) - (print `(stop timer!!! ,(* 1.0 (- (now) (elapsed self))))))) + (when (zerop (^executions)) + (setf (elapsed self) (now))) (when (if (numberp rpt) (< (^executions) rpt) rpt) ;; playing it safe/robust: redundant with initial bwhen check that rpt is not nil --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/24 20:38:54 1.9 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/25 07:12:59 1.10 @@ -149,7 +149,8 @@ (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value)))
(defmethod not-to-be :after ((self widget)) - (unless (find .tkw *windows-destroyed*) + (when (or (and (eql self .tkw) (not (find .tkw *windows-destroyed*))) + (not (find .tkw *windows-being-destroyed*))) (tk-format `(:forget ,self) "pack forget ~a" (^path)) (tk-format `(:destroy ,self) "destroy ~a" (^path))))
@@ -159,7 +160,6 @@ (export '(canvas-offset ^canvas-offset coords-tweak ^coords-tweak caret-tweak ^caret-tweak decorations ^decorations)))
- (defmodel item-geometer () ;; mix-in ((canvas-offset :initarg :canvas-offset :accessor canvas-offset :initform (c_? (eko (nil "standard canvas offset" self (type-of self) (^p-offset)) @@ -274,5 +274,5 @@ ;;; --- menus ---------------------------------
(defun pop-up (menu x y) - (trc "popping up" menu x y) + (trc nil "popping up" menu x y) (tk-format-now "tk_popup ~A ~A ~A" (path menu) x y))