[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Thu May 25 07:12:59 UTC 2006
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))
More information about the Cells-cvs
mailing list