Referencing foreign classes when loading saved images

[clg] / glib / gtype.lisp

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 17e9da7801c018c7aa158552b23eb6c722f40554..add9c8e97e7c679094afe6ea1495da0bb1118188 100644 (file)
--- a/glib/gtype.lisp
+++ b/glib/gtype.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: gtype.lisp,v 1.67 2008-12-10 02:54:17 espen Exp $
+;; $Id: gtype.lisp,v 1.69 2009-02-10 15:16:34 espen Exp $
 
 (in-package "GLIB")
 
@@ -131,7 +131,7 @@ (defun type-from-glib-name (name)
 (defun type-registered-p (type)
   (nth-value 1 (gethash type *lisp-type-to-type-number*)))
 
-(defun register-type (type id)
+(defun register-type (type id &optional (error-p t))
   (cond
    ((type-registered-p type) (find-type-number type))
    ((not id) (warn "Can't register type with no foreign id: ~A" type))
@@ -139,7 +139,7 @@ (defun register-type (type id)
     (pushnew (cons type id) *registered-types* :key #'car)
     (let ((type-number 
           (typecase id
-            (string (type-number-from-glib-name id))
+            (string (type-number-from-glib-name id error-p))
             (symbol (funcall id)))))
       (setf (gethash type *lisp-type-to-type-number*) type-number)
       (setf (gethash type-number *type-number-to-lisp-type*) type)
@@ -156,7 +156,7 @@ (defun reinitialize-all-types ()
   (clrhash *type-number-to-lisp-type*)
   (type-init) ; initialize the glib type system
   (mapc #'(lambda (type) 
-           (register-type (car type) (cdr type)))
+           (register-type (car type) (cdr type) nil))
        *registered-types*)
   (mapc #'(lambda (type) 
            (apply #'register-new-type type))
@@ -165,14 +165,11 @@ (defun reinitialize-all-types ()
            (register-type-alias (car type) (cdr type)))
        *registered-type-aliases*))
 
-(pushnew 'reinitialize-all-types 
-  #+cmu *after-save-initializations*
-  #+sbcl *init-hooks*
-  #+clisp custom:*init-hooks*)
-
 #+cmu
-(pushnew 'system::reinitialize-global-table ; we shouldn't have to do this?
- *after-save-initializations*)
+(asdf:install-init-hook 'system::reinitialize-global-table 
+ *after-save-initializations*) ; we shouldn't need to do this?
+(asdf:install-init-hook 'reinitialize-all-types)
+
 
 
 (defun find-type-number (type &optional error-p)
@@ -351,6 +348,8 @@ (defun register-new-type (type parent &optional foreign-name)
 
 ;;;; Metaclass for subclasses of ginstance
 
+(defvar *referenced-ginstance-classes* ())
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass ginstance-class (proxy-class)
     ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype))))
@@ -379,7 +378,8 @@                (default-alien-type-name class-name))))
        (type-class-ref
         (if (or (symbolp gtype) (type-number-from-glib-name gtype nil))
             (register-type class-name gtype)
-          (register-new-type class-name (class-name super) gtype))))
+          (register-new-type class-name (class-name super) gtype)))
+       (push class-name *referenced-ginstance-classes*))
       #+nil
       (when (and
             (supertype (find-type-number class))
@@ -389,6 +389,12 @@               (default-alien-type-name class-name))))
     (update-size class))
   #-clisp(call-next-method))
 
+(defun reinitialize-ginstance-classes ()
+  (mapc #'type-class-ref *referenced-ginstance-classes*))
+
+(asdf:install-init-hook 'reinitialize-ginstance-classes)
+
+
 
 (defmethod shared-initialize ((class ginstance-class) names &rest initargs)
   (declare (ignore names initargs))