[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp

[Peter Denno]

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv29218/root/cells-gtk

Modified Files:
	gtk-app.lisp 
Log Message:
Quit out of as many main loops as necessary.
Date: Tue Jan  3 19:57:41 2006
Author: pdenno

Index: root/cells-gtk/gtk-app.lisp
diff -u root/cells-gtk/gtk-app.lisp:1.14 root/cells-gtk/gtk-app.lisp:1.15
--- root/cells-gtk/gtk-app.lisp:1.14	Sun May 29 23:06:47 2005
+++ root/cells-gtk/gtk-app.lisp	Tue Jan  3 19:57:41 2006
@@ -91,13 +91,13 @@
             (not-to-be splash)
             (gtk-window-set-auto-startup-notification t))
           (setf (visible app) t)
-
           (when *gtk-debug*
             (trc nil "STARTING GTK-MAIN") (force-output))
           #-lispworks 
           (gtk-main)
           #+lispworks
-          (flet ((do-gtk () (loop while (gtk-events-pending) do (gtk-main-iteration-do nil))))
+          (flet ((do-gtk () (loop while (gtk-events-pending) do 
+				  (gtk-main-iteration-do nil))))
               (unwind-protect
                 (catch 'try-again
                   (handler-case
@@ -109,11 +109,11 @@
                       (show-message (format nil "Cells-GTK Error: ~a" err) 
                                     :message-type :error :title "Cells-GTK Error")
                       (throw 'try-again nil)) ; This doesn't really work. u-p cleanup forms invoked.
-                    (gtk-user-signals-quit (c)
-                      (declare (ignore c))
-                      (return-from start-app nil))))
+                    (gtk-user-signals-quit ()
+		      (loop while (> (gtk-main-level) 0) do (gtk-main-quit))
+                      (return-from start-app))))
                 (not-to-be app)
-                (gtk-main-quit)
+		(loop while (> (gtk-main-level) 0) do (gtk-main-quit))
                 (do-gtk)))))))