From 1d46f9f4cb80cecd03a79c89daedf7a81d5dd608 Mon Sep 17 00:00:00 2001
From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Fri, 3 Jul 2009 09:19:31 +0400
Subject: [PATCH] Added ability to save and restore SBCL image with cl-gtk2
 loaded

---
 glib/cl-gtk2-glib.asd  |    4 +++-
 glib/gobject.meta.lisp |   28 +++++++++++++++-------------
 glib/sbcl.lisp         |   26 ++++++++++++++++++++++++++
 gtk/cl-gtk2-gtk.asd    |    1 +
 4 files changed, 45 insertions(+), 14 deletions(-)
 create mode 100644 glib/sbcl.lisp

diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd
index e53aed7..8ed16e6 100644
--- a/glib/cl-gtk2-glib.asd
+++ b/glib/cl-gtk2-glib.asd
@@ -27,5 +27,7 @@
                (:file "gobject.meta")
                (:file "gobject.generating")
                (:file "gobject.object-defs")
-               (:file "gobject.foreign-gobject-subclassing"))
+               (:file "gobject.foreign-gobject-subclassing")
+
+               #+sbcl (:file "sbcl"))
   :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop))
\ No newline at end of file
diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp
index 5835b49..abf61a5 100644
--- a/glib/gobject.meta.lisp
+++ b/glib/gobject.meta.lisp
@@ -11,31 +11,33 @@
                 :initarg :g-interface-p
                 :reader gobject-class-interface-p)))
 
-(defmethod initialize-instance :after ((object gobject-class) &key &allow-other-keys)
-  (register-object-type (gobject-class-g-type-name object) (class-name object))
-  (if (gobject-class-g-type-initializer object)
-      (let* ((initializer-fn-ptr (foreign-symbol-pointer (gobject-class-g-type-initializer object)))
+(defun initialize-gobject-class-g-type (class)
+  (if (gobject-class-g-type-initializer class)
+      (let* ((initializer-fn-ptr (foreign-symbol-pointer (gobject-class-g-type-initializer class)))
              (type (when initializer-fn-ptr
                      (foreign-funcall-pointer initializer-fn-ptr nil
                                               g-type))))
         (if (null initializer-fn-ptr)
             (warn "Type initializer for class '~A' (GType '~A') is invalid: foreign symbol '~A'"
-                  (gobject-class-g-type-name object) (class-name object) (gobject-class-g-type-initializer object))
-          
+                  (gobject-class-g-type-name class) (class-name class) (gobject-class-g-type-initializer class))
             (progn
               (when (= +g-type-invalid+ type)
                 (warn "Declared GType name '~A' for class '~A' is invalid ('~A' returned 0)"
-                      (gobject-class-g-type-name object) (class-name object)
-                      (gobject-class-g-type-initializer object)))
-              (unless (string= (gobject-class-g-type-name object)
+                      (gobject-class-g-type-name class) (class-name class)
+                      (gobject-class-g-type-initializer class)))
+              (unless (string= (gobject-class-g-type-name class)
                                (g-type-name type))
                 (warn "Declared GType name '~A' for class '~A' does not match actual GType name '~A'"
-                      (gobject-class-g-type-name object)
-                      (class-name object)
+                      (gobject-class-g-type-name class)
+                      (class-name class)
                       (g-type-name type))))))
-      (unless (g-type-from-name (gobject-class-g-type-name object))
+      (unless (g-type-from-name (gobject-class-g-type-name class))
         (warn "Declared GType name '~A' for class '~A' is invalid (g_type_name returned 0)"
-              (gobject-class-g-type-name object) (class-name object)))))
+              (gobject-class-g-type-name class) (class-name class)))))
+
+(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))
 
 (defclass gobject-direct-slot-definition (standard-direct-slot-definition)
   ((g-property-type :initform nil
diff --git a/glib/sbcl.lisp b/glib/sbcl.lisp
new file mode 100644
index 0000000..b3c5f99
--- /dev/null
+++ b/glib/sbcl.lisp
@@ -0,0 +1,26 @@
+(in-package :glib)
+
+#+thread-support
+(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*))
+
+(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))))
+
+(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*)
diff --git a/gtk/cl-gtk2-gtk.asd b/gtk/cl-gtk2-gtk.asd
index cea1fcd..eccb3df 100644
--- a/gtk/cl-gtk2-gtk.asd
+++ b/gtk/cl-gtk2-gtk.asd
@@ -56,6 +56,7 @@
                (:file "gtk.dialog.example")
                
                (:file "gtk.demo")
+               #+sbcl (:file "sbcl")
                (:module "demo-files"
                         :pathname "demo"
                         :components ((:static-file "demo1.glade")
-- 
1.7.10.4