[cells-gtk-cvs] CVS root/cells-gtk - cells-gtk-cvs@common-lisp.net - mailman3.common-lisp.net

16 Feb 2006

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp:/tmp/cvs-serv9994/root/cells-gtk
Modified Files:
    gtk-app.lisp 
Log Message:
Uses restarts instead of kludgy code.

--- /project/cells-gtk/cvsroot/root/cells-gtk/gtk-app.lisp	2006/01/03 18:57:41	1.15
+++ /project/cells-gtk/cvsroot/root/cells-gtk/gtk-app.lisp	2006/02/16 18:15:14	1.16
@@ -25,11 +25,10 @@
    (tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil))
    (stock-icons :cell nil :accessor stock-icons :initarg :stock-icons :initform nil))
   (:default-initargs
-      :on-delete-event (lambda (self widget event data)
-                         (declare (ignore self widget event data))
-                         #+lispworks(signal 'gtk-user-signals-quit)
-                         #-lispworks(gtk-main-quit)
-                         0)))
+   :on-delete-event (lambda (self widget event data)
+		      (declare (ignore self widget event data))
+		      (signal 'gtk-user-signals-quit)
+		      0)))
(defmethod initialize-instance :after ((self gtk-app) &key stock-icons)
@@ -62,16 +61,16 @@
(defvar *gtk-initialized* nil)
+
 (defun start-app (app-name &key debug)
   (let ((*gtk-debug* debug))
     (when (not *gtk-initialized*)
       (when *gtk-debug*
         (trc nil "GTK INITIALIZATION") (force-output))
-      (g-thread-init c-null)
+      (g-thread-init +c-null+)
       (gdk-threads-init)
-      (assert (gtk-init-check c-null-int c-null))
+      (assert (gtk-init-check +c-null+ +c-null+))
       (setf *gtk-initialized* t))
-    (setf (gtk-user-quit-p) nil)
(with-gdk-threads
         (let ((app (make-instance app-name :visible (c-in nil)))
@@ -84,38 +83,49 @@
             (setf (visible splash) t)
             (loop while (gtk-events-pending) do
                  (gtk-main-iteration)))
-          
+
           (to-be app)
-          
+
           (when splash
             (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))))
-              (unwind-protect
-                (catch 'try-again
-                  (handler-case
-                    (loop
-                       (do-gtk)
-                       (when (gtk-user-quit-p) (signal 'gtk-user-signals-quit))
-                       (process-wait-with-timeout .01 "GTK event loop waiting"))
-                    (gtk-continuable-error (err)
-                      (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 ()
-		      (loop while (> (gtk-main-level) 0) do (gtk-main-quit))
-                      (return-from start-app))))
-                (not-to-be app)
-		(loop while (> (gtk-main-level) 0) do (gtk-main-quit))
-                (do-gtk)))))))
-
+          (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output))
+	  (unwind-protect
+	     (loop 
+	      (restart-case
+	       (handler-bind 
+		((gtk-user-signals-quit #'give-up-cleanly)
+		 (gtk-continuable-error #'continue-from-error)
+		 (error #'report-error-and-give-up))
+		#-lispworks
+		(gtk-main)
+		#+lispworks ; give slime a chance.
+		(loop ; just running your app in a process is not enough.
+		 (loop while (gtk-events-pending) do 
+		       (gtk-main-iteration-do nil))
+		 (process-wait-with-timeout .01 "GTK event loop waiting")))
+	       ;; Restart cases
+	       (continue-from-error (c)
+		  (show-message (format nil "Cells-GTK Error: ~a" (text c))
+				:message-type :error :title "Cells-GTK Error"))
+	       (give-up-cleanly () (return-from start-app))
+	       (report-error-and-give-up (c) (error c))))
+	    ;; clean-up forms (takes down application).
+	    (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why?
+	    (loop for i from 0 to 99 do (gtk-main-quit))
+	    (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)))))))
+
+;;; Restarts
+(defun continue-from-error (c)
+  (invoke-restart 'continue-from-error c))
+
+(defun report-error-and-give-up (c)
+  (invoke-restart 'report-error-and-give-up c))
+
+(defun give-up-cleanly (c)
+  (declare (ignore c))
+  (invoke-restart 'give-up-cleanly))
(defvar *gtk-global-callbacks* nil)
 (defvar *gtk-loaded* #+clisp t #-clisp nil) ;; kt: looks like CLisp does this on its own
@@ -127,8 +137,7 @@
     (make-array 128 :adjustable t :fill-pointer 0)))
(defun gtk-global-callback-register (callback)
-  (vector-push-extend callback
-    *gtk-global-callbacks* 16))
+  (vector-push-extend callback *gtk-global-callbacks* 16))
(defun gtk-global-callback-funcall (n)
   (trc nil "gtk-global-callback-funcall >" n
@@ -143,13 +152,7 @@
     (setf *gtk-loaded* t))
   (gtk-reset))
-;;; Implements quits other than through destroy.
-(let (quit)
-  (defun gtk-user-quit-p () quit)
-  (defun (setf gtk-user-quit-p) (val) 
-    (setf quit val))
-)
-
 (eval-when (compile load eval)
   (export '(gtk-app gtk-reset cells-gtk-init title icon tooltips tooltips-enable tooltips-delay
-             start-app gtk-global-callback-register gtk-global-callback-funcall gtk-user-quit-p)))
\ No newline at end of file
+             start-app gtk-global-callback-register gtk-global-callback-funcall)))
+

    