[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-serv7500/cells-gtk

Modified Files:
	gtk-app.lisp 
Log Message:
More work toward straightening out the gtk main loop in lispworks. Also stuff for loading of libcellsgtk.so
Date: Sat Feb 26 23:26:09 2005
Author: pdenno

Index: root/cells-gtk/gtk-app.lisp
diff -u root/cells-gtk/gtk-app.lisp:1.12 root/cells-gtk/gtk-app.lisp:1.13
--- root/cells-gtk/gtk-app.lisp:1.12	Wed Feb 16 23:20:37 2005
+++ root/cells-gtk/gtk-app.lisp	Sat Feb 26 23:26:09 2005
@@ -27,9 +27,11 @@
   (:default-initargs
       :on-delete-event (lambda (self widget event data)
                          (declare (ignore self widget event data))
-                         (gtk-main-quit)
+                         #+lispworks(signal 'gtk-user-signals-quit)
+                         #-lispworks(gtk-main-quit)
                          0)))
 
+
 (defmethod initialize-instance :after ((self gtk-app) &key stock-icons)
   (loop for (name pathname) in stock-icons do
        (let* ((image (gtk-image-new-from-file pathname))
@@ -69,6 +71,7 @@
       (gdk-threads-init)
       (assert (gtk-init-check c-null-int 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)))
@@ -91,19 +94,28 @@
 
           (when *gtk-debug*
             (trc nil "STARTING GTK-MAIN") (force-output))
-          #-lispworks(gtk-main)
+          #-lispworks 
+          (gtk-main)
           #+lispworks
-          (catch 'try-again
-            (handler-case
-              (loop
-                 (loop while (gtk-events-pending)
-                    do (gtk-main-iteration-do nil))
-                 (process-wait-with-timeout .01 "GTK event loop waiting"))
-              (gtk-cells-error (err)
-                (show-message (format nil "Cells-GTK Error: ~a" err) :message-type :error)
-                (process-wait "Acknowledge error" #'gtk-events-pending)
-                (loop while (gtk-events-pending) do (gtk-main-iteration-do nil))
-                (throw 'try-again nil))))))))
+          (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 (c)
+                      (declare (ignore c))
+                      (return-from start-app nil))))
+                (not-to-be app)
+                (gtk-main-quit)
+                (do-gtk)))))))
+
 
 (defvar *gtk-global-callbacks* nil)
 (defvar *gtk-loaded* #+clisp t #-clisp nil) ;; kt: looks like CLisp does this on its own
@@ -128,7 +140,7 @@
   (gtk-reset)
   #-cmu
   (unless *gtk-loaded*
-    (loop for lib in '(:gthread :glib :gobject :gdk :gtk)
+    (loop for lib in '(:gthread :glib :gobject :gdk :gtk #+libcellsgtk :cgtk)
           for libname = (gtk-ffi::libname lib)
           with libpath = (cond ((directory "/usr/lib/libgtk*") "/usr/lib/")
                                ((directory "/opt/gnome/lib/libgtk*") "/opt/gnome/lib/")
@@ -136,11 +148,20 @@
                                (t (error "Cannot find a path containing libgtk")))
         do #-mswindows ;; probably have to refine this for diff implementations
           (setq libname (uffi:find-foreign-library (gtk-ffi::libname lib) libpath))
-          (assert (uffi:load-foreign-library libname
-                    :force-load #+lispworks t #-lispworks nil
-                    :module (string lib)))
-        finally (setf *gtk-loaded* t))))
+          (assert (or (uffi:load-foreign-library libname
+                         :force-load #+lispworks t #-lispworks nil
+                         :module (string lib))
+                      (eql lib :cgtk)))
+        finally (setf *gtk-loaded* t))
+    #-libcellsgtk(warn "libcellsgtk.so not found. Just a few capabilities will be unavailable.")))
+
+;;; 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)))
\ No newline at end of file
+             start-app gtk-global-callback-register gtk-global-callback-funcall gtk-user-quit-p)))
\ No newline at end of file