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