[graphic-forms-cvs] r9 - in trunk/src: tests/uitoolkit uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Mon Feb 13 21:15:34 2006
New Revision: 9

Modified:
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
invoke default message loop on behalf of application code

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Mon Feb 13 21:15:34 2006
@@ -205,8 +205,7 @@
                                        ((:menu "&Help" :dispatcher ,echo-md)
                                         (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp")))))
     (setf (gfw:menu-bar *event-tester-window*) menubar)
-    (gfw:show *event-tester-window*)
-    (gfw:run-default-message-loop)))
+    (gfw:show *event-tester-window*)))
 
 (defun run-event-tester ()
   (gfw:startup "Event Tester" #'run-event-tester-internal))

Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp	(original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Mon Feb 13 21:15:34 2006
@@ -68,8 +68,7 @@
     (setf menubar (gfw:defmenusystem `(((:menu "&File")
                                         (:menuitem "E&xit" :dispatcher ,md)))))
     (setf (gfw:menu-bar *hellowin*) menubar)
-    (gfw:show *hellowin*)
-    (gfw:run-default-message-loop)))
+    (gfw:show *hellowin*)))
 
 (defun run-hello-world ()
   (gfw:startup "Hello World" #'run-hello-world-internal))

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Mon Feb 13 21:15:34 2006
@@ -139,8 +139,7 @@
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
-    (gfw:show *layout-tester-win*)
-    (gfw:run-default-message-loop)))
+    (gfw:show *layout-tester-win*)))
 
 (defun run-layout-tester ()
   (gfw:startup "Layout Tester" #'run-layout-tester-internal))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Mon Feb 13 21:15:34 2006
@@ -36,12 +36,17 @@
 #+clisp (defun startup (thread-name start-fn)
           (declare (ignore thread-name))
           (setf *the-thread-context* (make-instance 'thread-context))
-          (funcall start-fn))
+          (funcall start-fn)
+          (run-default-message-loop))
 
 #+lispworks (defun startup (thread-name start-fn)
               (when (null (mp:list-all-processes))
                 (mp:initialize-multiprocessing))
-              (mp:process-run-function thread-name nil start-fn))
+              (mp:process-run-function thread-name
+                                       nil
+                                       #'(lambda () (progn
+                                                      (funcall start-fn)
+                                                      (run-default-message-loop)))))
 
 (defun shutdown (exit-code)
   (gfs::post-quit-message exit-code))