Simplify Lisp image initialization and finalization process

diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd
index 28388f7..88a1241 100644 (file)
--- a/glib/cl-gtk2-glib.asd
+++ b/glib/cl-gtk2-glib.asd
@@ -34,7 +34,5 @@
                (:file "gobject.cffi-callbacks")
                (:file "gobject.foreign-gobject-subclassing")
 
-               (:file "gobject.boxed")
-               
-               #+sbcl (:file "sbcl"))
+               (:file "gobject.boxed"))
   :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop))
\ No newline at end of file

diff --git a/glib/glib.lisp b/glib/glib.lisp
index 57c6e71..904e1ff 100644 (file)
--- a/glib/glib.lisp
+++ b/glib/glib.lisp
@@ -25,7 +25,8 @@
            #:g-idle-add-full
            #:g-idle-add
            #:g-timeout-add-full
-           #:g-source-remove)
+           #:g-source-remove
+           #:at-finalize)
   (:documentation
    "Cl-gtk2-glib is wrapper for @a[http://library.gnome.org/devel/glib/]{GLib}."))
 
@@ -37,12 +38,28 @@
   (defun register-initializer (key fn)
     (unless (gethash key *initializers-table*)
       (setf (gethash key *initializers-table*) t
-            *initializers* (nconc *initializers* (list fn))))))
+            *initializers* (nconc *initializers* (list fn)))))
+  (defvar *finalizers-table* (make-hash-table :test 'equalp))
+  (defvar *finalizers* nil)
+  (defun register-finalizer (key fn)
+    (unless (gethash key *finalizers-table*)
+      (setf (gethash key *finalizers-table*) t
+            *finalizers* (nconc *finalizers* (list fn))))))
 
 (defun run-initializers ()
   (iter (for fn in *initializers*)
         (funcall fn)))
 
+(defun run-finalizers ()
+  (iter (for fn in *finalizers*)
+        (funcall fn)))
+
+#+sbcl
+(pushnew 'run-initializers sb-ext:*init-hooks*)
+
+#+sbcl
+(pushnew 'run-finalizers sb-ext:*save-hooks*)
+
 (defmacro at-init ((&rest keys) &body body)
   "
 @arg[keys]{list of expression}
@@ -64,6 +81,9 @@ In this example, for every @code{class}, @code{(initialize-gobject-class-g-type
   `(progn (register-initializer (list ,@keys ',body) (lambda () ,@body))
           ,@body))
 
+(defmacro at-finalize ((&rest keys) &body body)
+  `(register-finalizer (list ,@keys ',body) (lambda () ,@body)))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (define-foreign-library glib
     (:unix (:or "libglib-2.0.so.0" "libglib-2.0.so"))

diff --git a/glib/gobject.object.high.lisp b/glib/gobject.object.high.lisp
index 099bf5f..66a0b63 100644 (file)
--- a/glib/gobject.object.high.lisp
+++ b/glib/gobject.object.high.lisp
@@ -23,6 +23,13 @@
 (defvar *current-object-from-pointer* nil)
 (defvar *currently-making-object-p* nil)
 
+(at-finalize ()
+  (clrhash *foreign-gobjects-weak*)
+  (clrhash *foreign-gobjects-strong*)
+  (setf *current-creating-object* nil
+        *current-object-from-pointer* nil
+        *currently-making-object-p* nil))
+
 (defun ref-count (pointer)
   (foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct :ref-count))
 

diff --git a/glib/sbcl.lisp b/glib/sbcl.lisp
deleted file mode 100644 (file)
index c5a670b..0000000
--- a/glib/sbcl.lisp
+++ /dev/null
@@ -1,16 +0,0 @@
-(in-package :glib)
-
-#+thread-support
-(progn
-  (defun glib-stop-thread ()
-    (setf *threads-initialized-p* nil))
-  (pushnew 'glib-stop-thread sb-ext:*save-hooks*))
-
-(defun map-inherited-classes (class fn)
-  (when (symbolp class) (setf class (find-class class)))
-  (when class
-    (funcall fn class)
-    (iter (for subclass in (closer-mop:class-direct-subclasses class))
-          (map-inherited-classes subclass fn))))
-
-(pushnew 'run-initializers sb-ext:*init-hooks*)

diff --git a/gtk/cl-gtk2-gtk.asd b/gtk/cl-gtk2-gtk.asd
index 38710c4..124c9e0 100644 (file)
--- a/gtk/cl-gtk2-gtk.asd
+++ b/gtk/cl-gtk2-gtk.asd
@@ -58,7 +58,6 @@
                (:file "gtk.dialog.example")
                
                (:file "gtk.demo")
-               #+sbcl (:file "sbcl")
                (:module "demo-files"
                         :pathname "demo"
                         :components ((:static-file "demo1.glade")

diff --git a/gtk/gtk.main_loop_events.lisp b/gtk/gtk.main_loop_events.lisp
index d2809bc..961b357 100644 (file)
--- a/gtk/gtk.main_loop_events.lisp
+++ b/gtk/gtk.main_loop_events.lisp
@@ -17,7 +17,7 @@
            (error "Cannot initialize Gtk+"))
       (foreign-free (mem-ref argv '(:pointer :string))))))
 
-(gtk-init)
+(at-init () (gtk-init))
 
 (defcfun gtk-main :void)
 
@@ -25,11 +25,17 @@
 (defvar *main-thread* nil)
 
 #+thread-support
+(at-finalize ()
+  (when (and *main-thread* (bt:thread-alive-p *main-thread*))
+    (bt:destroy-thread *main-thread*)
+    (setf *main-thread* nil)))
+
+#+thread-support
 (defun ensure-gtk-main ()
   (when (and *main-thread* (not (bt:thread-alive-p *main-thread*)))
     (setf *main-thread* nil))
   (unless *main-thread*
-    (setf *main-thread* (bt:make-thread (lambda () (gtk:gtk-main)) :name "cl-gtk2 main thread"))))
+    (setf *main-thread* (bt:make-thread (lambda () (gtk-main)) :name "cl-gtk2 main thread"))))
 
 #+thread-support
 (defun join-main-thread ()

diff --git a/gtk/gtk.misc.lisp b/gtk/gtk.misc.lisp
index 1dfa2cb..19c9720 100644 (file)
--- a/gtk/gtk.misc.lisp
+++ b/gtk/gtk.misc.lisp
@@ -53,6 +53,6 @@
 (defmacro with-main-loop (&body body)
   `(progn
      ,@body
-     (gtk-main)))
+     (ensure-gtk-main)))
 
 (export 'with-main-loop)
\ No newline at end of file

diff --git a/gtk/sbcl.lisp b/gtk/sbcl.lisp
deleted file mode 100644 (file)
index 59830eb..0000000
--- a/gtk/sbcl.lisp
+++ /dev/null
@@ -1,14 +0,0 @@
-(in-package :gtk)
-
-#+thread-support
-(progn
-  (defun stop-main-thread-on-save ()
-    (when (and *main-thread* (bt:thread-alive-p *main-thread*))
-      (within-main-loop-and-wait (gtk-main-quit))
-      (bt:destroy-thread *main-thread*)
-      (setf *main-thread* nil)))
-  (defun cl-gtk2-sbcl-init ()
-    (gtk-init))
-  (pushnew 'cl-gtk2-sbcl-init sb-ext:*init-hooks*)
-  (pushnew 'stop-main-thread-on-save sb-ext:*save-hooks*))
-