From 84fb40788d8b8c0c0dc5ad66ee02da0519c4676f Mon Sep 17 00:00:00 2001
From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Fri, 3 Jul 2009 22:33:04 +0400
Subject: [PATCH] Fixed re-initialization of gtk libraries on loading of
 dumped image (for now only for sbcl)

---
 glib/glib.lisp                                |   23 +++++++++++++++++++----
 glib/gobject.foreign-gobject-subclassing.lisp |   12 +++++++-----
 glib/gobject.meta.lisp                        |    2 +-
 glib/gobject.type.lisp                        |    2 +-
 glib/sbcl.lisp                                |   14 ++------------
 5 files changed, 30 insertions(+), 23 deletions(-)

diff --git a/glib/glib.lisp b/glib/glib.lisp
index 6007616..a262e07 100644
--- a/glib/glib.lisp
+++ b/glib/glib.lisp
@@ -1,6 +1,7 @@
 (defpackage :glib
   (:use :cl :cffi :iter)
-  (:export #:gsize
+  (:export #:at-init
+           #:gsize
            #:gssize
            #:goffset
            #:*glib-major-version*
@@ -26,6 +27,19 @@
 (in-package :glib)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *initializers* nil)
+  (defun register-initializer (fn)
+    (setf *initializers* (nconc *initializers* (list fn)))))
+
+(defun run-initializers ()
+  (iter (for fn in *initializers*)
+        (funcall fn)))
+
+(defmacro at-init (&body body)
+  `(progn (register-initializer (lambda () ,@body))
+          ,@body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (define-foreign-library glib
     (:unix (:or "libglib-2.0.so.0" "libglib-2.0.so"))
     (t "libglib-2.0")))
@@ -356,9 +370,10 @@
 
 (defvar *threads-initialized-p* nil)
 
-(unless *threads-initialized-p*
-  (g-thread-init (null-pointer))
-  (setf *threads-initialized-p* t))
+(at-init
+  (unless *threads-initialized-p*
+    (g-thread-init (null-pointer))
+    (setf *threads-initialized-p* t)))
 
 (defcenum g-thread-priority
   :g-thread-priority-low
diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp
index b64f451..cb9fc94 100644
--- a/glib/gobject.foreign-gobject-subclassing.lisp
+++ b/glib/gobject.foreign-gobject-subclassing.lisp
@@ -198,11 +198,13 @@
     (setf parent (g-type-name (ensure-g-type parent))))
   `(progn
      (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties))
-     (with-foreign-object (query 'g-type-query)
-       (g-type-query (g-type-from-name ,parent) query)
-       (with-foreign-slots ((class-size instance-size) query g-type-query)
-         (g-type-register-static-simple (g-type-from-name ,parent) ,name class-size (callback c-class-init) instance-size (callback c-instance-init) nil)))
-     (add-interfaces ,name)
+     (at-init
+       (format t "Registering GObject type implementation ~A for type ~A~%" ',class ,name)
+       (with-foreign-object (query 'g-type-query)
+         (g-type-query (g-type-from-name ,parent) query)
+         (with-foreign-slots ((class-size instance-size) query g-type-query)
+           (g-type-register-static-simple (g-type-from-name ,parent) ,name class-size (callback c-class-init) instance-size (callback c-instance-init) nil)))
+       (add-interfaces ,name))
      (defmethod initialize-instance :before ((object ,class) &key pointer)
        (unless (or pointer (and (slot-boundp object 'gobject::pointer)
                                 (gobject::pointer object)))
diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp
index abf61a5..c316dfb 100644
--- a/glib/gobject.meta.lisp
+++ b/glib/gobject.meta.lisp
@@ -37,7 +37,7 @@
 
 (defmethod initialize-instance :after ((object gobject-class) &key &allow-other-keys)
   (register-object-type (gobject-class-g-type-name object) (class-name object))
-  (initialize-gobject-class-g-type object))
+  (at-init (initialize-gobject-class-g-type object)))
 
 (defclass gobject-direct-slot-definition (standard-direct-slot-definition)
   ((g-property-type :initform nil
diff --git a/glib/gobject.type.lisp b/glib/gobject.type.lisp
index 12dff51..e863517 100644
--- a/glib/gobject.type.lisp
+++ b/glib/gobject.type.lisp
@@ -5,7 +5,7 @@
 
 (defcfun (%g-type-init "g_type_init") :void)
 
-(%g-type-init)
+(at-init (%g-type-init))
 
 (defcfun (g-type-name "g_type_name") :string
   (type g-type))
diff --git a/glib/sbcl.lisp b/glib/sbcl.lisp
index b3c5f99..c5a670b 100644
--- a/glib/sbcl.lisp
+++ b/glib/sbcl.lisp
@@ -4,11 +4,7 @@
 (progn
   (defun glib-stop-thread ()
     (setf *threads-initialized-p* nil))
-  (defun glib-start-thread ()
-    (g-thread-init (null-pointer))
-    (setf *threads-initialized-p* t))
-  (pushnew 'glib-stop-thread sb-ext:*save-hooks*)
-  (pushnew 'glib-start-thread sb-ext:*init-hooks*))
+  (pushnew 'glib-stop-thread sb-ext:*save-hooks*))
 
 (defun map-inherited-classes (class fn)
   (when (symbolp class) (setf class (find-class class)))
@@ -17,10 +13,4 @@
     (iter (for subclass in (closer-mop:class-direct-subclasses class))
           (map-inherited-classes subclass fn))))
 
-(defun initialize-all-gobject-types ()
-  (map-inherited-classes 'gobject::g-object
-                         (lambda (class)
-                           (when (typep class 'gobject::gobject-class)
-                             (gobject::initialize-gobject-class-g-type class)))))
-
-(pushnew 'initialize-all-gobject-types sb-ext:*init-hooks*)
+(pushnew 'run-initializers sb-ext:*init-hooks*)
-- 
1.7.10.4