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)))))))