[cells-cvs] CVS Celtk

[ktilton]

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

Modified Files:
	Celtk.lisp run.lisp tk-interp.lisp 
Log Message:
use tk_getnummainwindows to figure out when to stop looping on tcl_dooneevent

--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/05/03 08:46:56	1.15
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/05/03 20:02:36	1.16
@@ -124,7 +124,7 @@
   ;
   ; --- debug stuff ---
   ;
-  (let ((yes '("pop" "menu" "mnu"))
+  (let ((yes '("bind" "pop" "menu" "mnu"))
         (no  '("tk-events")))
 
     (declare (ignorable yes no))
--- /project/cells/cvsroot/Celtk/run.lisp	2006/05/03 17:18:29	1.4
+++ /project/cells/cvsroot/Celtk/run.lisp	2006/05/03 20:02:36	1.5
@@ -72,7 +72,8 @@
 
 (defun tcl-do-one-event-loop ()
   (loop with start-time = (get-internal-real-time)
-        while (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second))
+        while (and (plusp (tk-get-num-main-windows))
+                (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second)))
         do
         (bif (events (prog1
                          (tk-eval-list "set tk-events")
@@ -80,6 +81,7 @@
           (progn
             #+shhh (loop for e in events
               do (trc "event preview" e))
+            (trc "main windows count =" (tk-get-num-main-windows))
             (loop for e in events
               do (setf start-time (get-internal-real-time))
             (tk-process-event e)))
--- /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/05/03 08:20:49	1.2
+++ /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/05/03 20:02:36	1.3
@@ -165,6 +165,8 @@
 
     (defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string
       (interp      :pointer))
+
+    (defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int)
     
     (defun Tcl_Eval (interp script)
       (with-foreign-string (script-cstr script)
@@ -388,11 +390,11 @@
     (trc "tk-eval result:" (tk-eval "tk scaling"))
     (trc "tk-eval-list result:" (tk-eval-list "font families"))))
 
-(defun exec-main ()
-  (main "\\0devtools\\frgotk\\psu-rc-gui.tcl"))
-
-#+test
-(exec-main)
+;;;(defun exec-main ()
+;;;  (main "\\0devtools\\frgotk\\psu-rc-gui.tcl"))
+;;;
+;;;#+test
+;;;(exec-main)
 
 ;;; Togl stuff