From: espen <espen>
Date: Sun, 6 Mar 2005 17:26:22 +0000 (+0000)
Subject: Changes necessary to allow saving of core images with clg.
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/dfa4f31424800fdb6fb63514121b9cc893269276

Changes necessary to allow saving of core images with clg.
---

diff --git a/gdk/gdkevents.lisp b/gdk/gdkevents.lisp
index e369c80..8de9d9a 100644
--- a/gdk/gdkevents.lisp
+++ b/gdk/gdkevents.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gdkevents.lisp,v 1.8 2005-02-26 17:55:27 espen Exp $
+;; $Id: gdkevents.lisp,v 1.9 2005-03-06 17:26:22 espen Exp $
 
 (in-package "GDK")
 
@@ -44,7 +44,7 @@ (define-flags-type event-mask
   :scroll
   (:all-events #x3FFFFE))
 
-(register-type 'event-mask "GdkEventMask")
+(register-type 'event-mask '|gdk_event_mask_get_type|)
 
 
 ;;;; Metaclass for event classes
@@ -61,11 +61,12 @@   (defmethod validate-superclass ((class event-class) (super standard-class))
 
 
 (defmethod shared-initialize ((class event-class) names &key name type)
+  (let ((class-name (or name (class-name class))))
+    (unless (eq class-name 'event)
+      (register-type-alias class-name 'event)))
   (call-next-method)
   (setf (slot-value class 'event-type) (first type))
-  (setf (gethash (first type) *event-classes*) class)
-  (let ((class-name (or name (class-name class))))
-    (register-type class-name 'event)))
+  (setf (gethash (first type) *event-classes*) class))
   
 (let ((reader (reader-function 'event-type)))
   (defun %event-class (location)
diff --git a/gdk/gdktypes.lisp b/gdk/gdktypes.lisp
index 509c7b3..6cfbc7f 100644
--- a/gdk/gdktypes.lisp
+++ b/gdk/gdktypes.lisp
@@ -15,17 +15,14 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gdktypes.lisp,v 1.15 2005-02-26 18:53:33 espen Exp $
+;; $Id: gdktypes.lisp,v 1.16 2005-03-06 17:26:22 espen Exp $
 
 (in-package "GDK")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (init-types-in-library #.(concatenate 'string
 			    (pkg-config:pkg-variable "gtk+-2.0" "libdir")
-			    "/libgdk-x11-2.0.so") :prefix "gdk_")
-  (init-types-in-library #.(concatenate 'string
-			    (pkg-config:pkg-variable "gtk+-2.0" "libdir")
-			    "/libgdk-x11-2.0.so") :prefix "_gdk_")
+			    "/libgdk-x11-2.0.so") :prefix ("gdk_" "_gdk_"))
   (init-types-in-library #.(concatenate 'string
 			    (pkg-config:pkg-variable "gtk+-2.0" "libdir")
 			    "/libgdk_pixbuf-2.0.so") :prefix "gdk_"))
@@ -47,8 +44,7 @@ (defclass color (boxed)
     :allocation :alien
     :accessor color-blue
     :type unsigned-short))
-  (:metaclass boxed-class)
-  (:alien-name "GdkColor"))
+  (:metaclass boxed-class))
 
 
 (deftype point () '(vector int 2))
@@ -79,8 +75,7 @@ (defclass rectangle (boxed)
     :accessor rectangle-height
     :initarg :height
     :type int))
-  (:metaclass boxed-class)
-  (:alien-name "GdkRectangle"))
+  (:metaclass boxed-class))
 
 
 (define-types-by-introspection "Gdk"
@@ -206,8 +201,7 @@ (defclass cursor (boxed)
     :getter "gdk_cursor_get_display"
     :reader cursor-display
     :type display))
-  (:metaclass boxed-class)
-  (:alien-name "GdkCursor"))
+  (:metaclass boxed-class))
 
 
 (defclass geometry (struct)
diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp
index ceae18f..1bb152b 100644
--- a/glib/gboxed.lisp
+++ b/glib/gboxed.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gboxed.lisp,v 1.16 2005-02-14 00:44:26 espen Exp $
+;; $Id: gboxed.lisp,v 1.17 2005-03-06 17:26:23 espen Exp $
 
 (in-package "GLIB")
 
@@ -42,17 +42,13 @@   (defmethod validate-superclass ((class boxed-class) (super standard-class))
     (subtypep (class-name super) 'boxed)))
 
 
-(defmethod shared-initialize ((class boxed-class) names
-			      &rest initargs &key name alien-name)
-  (declare (ignore initargs names))
+(defmethod shared-initialize ((class boxed-class) names &key name gtype)
+  (declare (ignore names))
   (call-next-method)
-  
-  (let* ((class-name (or name (class-name class)))
-	 (type-number
-	  (find-type-number
-	   (or (first alien-name) (default-alien-type-name class-name)))))
-    (register-type class-name type-number)))
-
+  (let ((class-name (or name (class-name class))))
+    (unless (find-type-number class-name)
+      (register-type class-name 
+       (or (first gtype) (default-type-init-name class-name))))))
 
 (defbinding %boxed-copy () pointer
   (type-number type-number)
@@ -76,7 +72,7 @@ (defun expand-boxed-type (type-number forward-p slots)
      ,(unless forward-p
 	slots)
      (:metaclass boxed-class)
-     (:alien-name ,(find-type-name type-number))))
+     (:gtype ,(find-type-init-function type-number))))
 
 (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
 
@@ -115,4 +111,4 @@ (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
 ;;;; NULL terminated vector of strings
 
 (deftype strings () '(null-terminated-vector string))
-(register-type 'strings "GStrv")
+(register-type 'strings '|g_strv_get_type|)
diff --git a/glib/genums.lisp b/glib/genums.lisp
index 406a1a5..06985c6 100644
--- a/glib/genums.lisp
+++ b/glib/genums.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: genums.lisp,v 1.11 2005-02-25 17:20:25 espen Exp $
+;; $Id: genums.lisp,v 1.12 2005-03-06 17:26:23 espen Exp $
 
 (in-package "GLIB")
   
@@ -331,7 +331,7 @@ (defun expand-enum-type (type-number forward-p options)
 	   (remove-if
 	    #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
     `(progn
-       (register-type ',type ,(find-type-name type-number))
+       (register-type ',type ',(find-type-init-function type-number))
        ,(ecase super
 	  (enum `(define-enum-type ,type ,@expanded-mappings))
 	  (flags `(define-flags-type ,type ,@expanded-mappings))))))
diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp
index dcf74c6..b9a42b5 100644
--- a/glib/ginterface.lisp
+++ b/glib/ginterface.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: ginterface.lisp,v 1.8 2005-02-10 00:20:02 espen Exp $
+;; $Id: ginterface.lisp,v 1.9 2005-03-06 17:26:23 espen Exp $
 
 (in-package "GLIB")
 
@@ -54,14 +54,12 @@ (defmethod compute-effective-slot-definition-initargs ((class ginterface-class)
     (call-next-method)))
 
 
-(defmethod shared-initialize ((class ginterface-class) names
-			      &rest initargs &key name alien-name)
-  (declare (ignore initargs names))
-  (let* ((class-name (or name (class-name class)))
-	 (type-number
-	  (find-type-number
-	   (or (first alien-name) (default-alien-type-name class-name)) t)))
-    (register-type class-name type-number))
+(defmethod shared-initialize ((class ginterface-class) names &key name gtype)
+  (declare (ignore names))
+  (let ((class-name (or name (class-name class))))
+    (unless (find-type-number class-name)
+      (register-type class-name 
+        (or (first gtype) (default-type-init-name class-name)))))
   (call-next-method))
 
 
@@ -144,7 +142,7 @@ (defun expand-ginterface-type (type forward-p options &rest args)
        ,(unless forward-p
 	  (slot-definitions class (query-object-interface-properties type) slots))
       (:metaclass ginterface-class)
-      (:alien-name ,(find-type-name type)))))
+      (:gtype ,(find-type-init-function type)))))
 
 (defun ginterface-dependencies (type)
   (delete-duplicates 
diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index 0014b4d..5b5bf4e 100644
--- a/glib/gobject.lisp
+++ b/glib/gobject.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Copyright (C) 2000-2005 Espen S. Johnsen <espen@users.sf.net>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gobject.lisp,v 1.33 2005-02-27 15:14:38 espen Exp $
+;; $Id: gobject.lisp,v 1.34 2005-03-06 17:26:23 espen Exp $
 
 (in-package "GLIB")
 
@@ -102,17 +102,16 @@ (defmethod compute-effective-slot-definition-initargs ((class gobject-class) dir
 
 
 (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition))
-  (let* ((type (slot-definition-type slotd))
-	 (pname (slot-definition-pname slotd))
-	 (type-number (find-type-number type)))
+  (let ((type (slot-definition-type slotd))
+	(pname (slot-definition-pname slotd)))
     (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
       (setf 
        (slot-value slotd 'getter)
-       (let ((reader nil)) ;(reader-function type)))
+       (let ((reader nil))
 	 #'(lambda (object)
 	     (unless reader
 	       (setq reader (reader-function type)))
-	     (let ((gvalue (gvalue-new type-number)))
+	     (let ((gvalue (gvalue-new type)))
 	       (%object-get-property object pname gvalue)
 	       (unwind-protect
 		 (funcall reader  gvalue +gvalue-value-offset+)
@@ -121,11 +120,11 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
     (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
       (setf 
        (slot-value slotd 'setter)
-       (let ((writer nil)) ;(writer-function type)))
+       (let ((writer nil))
 	 #'(lambda (value object)
 	     (unless writer
 	       (setq writer (writer-function type)))
-	     (let ((gvalue (gvalue-new type-number)))
+	     (let ((gvalue (gvalue-new type)))
 	       (funcall writer value gvalue +gvalue-value-offset+)
 	       (%object-set-property object pname gvalue)
 	       (gvalue-free gvalue t)
@@ -159,7 +158,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass gobject (ginstance)
     ()
     (:metaclass gobject-class)
-    (:alien-name "GObject")))
+    (:gtype "GObject")))
 
 
 (defun initial-add (object function initargs key pkey)
@@ -431,7 +430,7 @@ (defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject
        ,(unless forward-p
 	  (slot-definitions class (query-object-class-properties type) slots))
       (:metaclass ,metaclass)
-      (:alien-name ,(find-type-name type)))))
+      (:gtype ,(find-type-init-function type)))))
 
 (defun gobject-dependencies (type)
   (delete-duplicates 
diff --git a/glib/gparam.lisp b/glib/gparam.lisp
index d2a4b01..2307924 100644
--- a/glib/gparam.lisp
+++ b/glib/gparam.lisp
@@ -1,5 +1,5 @@
 ;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Copyright (C) 2000-2005 Espen S. Johnsen <espen@users.sf.net>
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -15,13 +15,13 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gparam.lisp,v 1.15 2005-02-03 23:09:04 espen Exp $
+;; $Id: gparam.lisp,v 1.16 2005-03-06 17:26:23 espen Exp $
 
 (in-package "GLIB")
 
 (deftype gvalue () 'pointer)
 
-(register-type 'gvalue "GValue")
+(register-type 'gvalue '|g_value_get_type|)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defbinding (size-of-gvalue "size_of_gvalue") () unsigned-int))
@@ -145,7 +145,8 @@ (defclass param (ginstance)
     :getter "g_param_spec_get_blurb"
     :reader param-documentation
     :type (copy-of string)))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParam"))
 
 
 (defclass param-char (param)
@@ -161,7 +162,8 @@    (default-value
     :allocation :alien
     :reader param-char-default-value
     :type char))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamChar"))
 
 (defclass param-unsigned-char (param)
   (
@@ -179,14 +181,15 @@ (defclass param-unsigned-char (param)
 ;     :type unsigned-char)
    )
   (:metaclass param-spec-class)
-  (:alien-name "GParamUChar"))
+  (:gtype "GParamUChar"))
 
 (defclass param-boolean (param)
   ((default-value
      :allocation :alien
      :reader param-boolean-default-value
      :type boolean))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamBoolean"))
 
 (defclass param-int (param)
   ((minimum
@@ -201,7 +204,8 @@    (default-value
     :allocation :alien
     :reader param-int-default-value
     :type int))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamInt"))
 
 (defclass param-unsigned-int (param)
   ((minimum
@@ -217,7 +221,7 @@    (default-value
     :reader param-unsigned-int-default-value
     :type unsigned-int))
   (:metaclass param-spec-class)
-  (:alien-name "GParamUInt"))
+  (:gtype "GParamUInt"))
 
 (defclass param-long (param)
   ((minimum
@@ -232,7 +236,8 @@    (default-value
     :allocation :alien
     :reader param-long-default-value
     :type long))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParam"))
 
 (defclass param-unsigned-long (param)
   ((minimum
@@ -248,11 +253,12 @@    (default-value
     :reader param-unsigned-long-default-value
     :type unsigned-long))
   (:metaclass param-spec-class)
-  (:alien-name "GParamULong"))
+  (:gtype "GParamULong"))
 
 (defclass param-unichar (param)
   ()
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamUnichar"))
 
 (defclass param-enum (param)
   ((class
@@ -263,7 +269,8 @@    (default-value
     :allocation :alien
     :reader param-enum-default-value
     :type long))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamEnum"))
 
 (defclass param-flags (param)
   ((class
@@ -274,7 +281,8 @@    (default-value
     :allocation :alien
     :reader param-flags-default-value
     :type long))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamFlags"))
 
 (defclass param-single-float (param)
   ((minimum
@@ -294,7 +302,7 @@    (default-value
     :reader param-single-float-epsilon
     :type single-float))
   (:metaclass param-spec-class)
-  (:alien-name "GParamFloat"))
+  (:gtype "GParamFloat"))
 
 (defclass param-double-float (param)
   ((minimum
@@ -314,26 +322,30 @@    (default-value
     :reader param-double-float-epsilon
     :type double-float))
   (:metaclass param-spec-class)
-  (:alien-name "GParamDouble"))
+  (:gtype "GParamDouble"))
 
 (defclass param-string (param)
   ((default-value
     :allocation :alien
     :reader param-string-default-value
     :type string))
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamString"))
 
 (defclass param-param (param)
   ()
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamParam"))
 
 (defclass param-boxed (param)
   ()
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamBoxed"))
 
 (defclass param-pointer (param)
   ()
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamPointer"))
 
 (defclass param-value-array (param)
   ((element-spec
@@ -344,12 +356,15 @@ (defclass param-value-array (param)
     :allocation :alien
     :reader param-value-array-length
     :type unsigned-int))
-  (:metaclass param-spec-class))
-
-;; (defclass param-closure (param)
-;;   ()
-;;   (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamValueArray"))
 
 (defclass param-object (param)
   ()
-  (:metaclass param-spec-class))
+  (:metaclass param-spec-class)
+  (:gtype "GParamObject"))
+
+(defclass param-overrride (param)
+  ()
+  (:metaclass param-spec-class)
+  (:gtype "GParamOverride"))
diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index 9006d32..33c8baf 100644
--- a/glib/gtype.lisp
+++ b/glib/gtype.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtype.lisp,v 1.26 2005-02-10 00:20:02 espen Exp $
+;; $Id: gtype.lisp,v 1.27 2005-03-06 17:26:23 espen Exp $
 
 (in-package "GLIB")
 
@@ -99,62 +99,85 @@ (defbinding type-class-peek (type) pointer
 
 ;;;; Mapping between lisp types and glib types
 
-(defvar *type-to-number-hash* (make-hash-table))
-(defvar *number-to-type-hash* (make-hash-table))
-
-(defun register-type (type id)
-  (let ((type-number
-	 (etypecase id
-	   (integer id)
-	   (string (find-type-number id t))
-	   (symbol (gethash id *type-to-number-hash*)))))
-    (setf (gethash type *type-to-number-hash*) type-number)
-    (unless (symbolp id)
-      (setf (gethash type-number *number-to-type-hash*) type))
-    type-number))
+(defvar *registered-types* ())
+(defvar *registered-type-aliases* ())
+(defvar *lisp-type-to-type-number* (make-hash-table))
+(defvar *type-number-to-lisp-type* (make-hash-table))
 
 (defbinding %type-from-name () type-number
   (name string))
 
-(defun find-type-number (type &optional error)
+(defun type-number-from-glib-name (name &optional (error-p t))
+  (let ((type-number (%type-from-name name)))
+    (cond
+     ((not (zerop type-number)) type-number)
+     (error-p (error "Invalid gtype name: ~A" name)))))
+
+(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))
+	   (symbol (funcall id)))))
+       (setf (gethash type *lisp-type-to-type-number*) type-number)
+       (setf (gethash type-number *type-number-to-lisp-type*) type)
+       type-number))
+
+(defun register-type-alias (type alias)
+  (pushnew (cons type alias) *registered-type-aliases* :key #'car)
+  (setf 
+   (gethash type *lisp-type-to-type-number*)
+   (find-type-number alias t)))
+
+(defun reinitialize-all-types ()
+  (clrhash *lisp-type-to-type-number*)
+  (clrhash *type-number-to-lisp-type*)
+  (type-init) ; initialize the glib type system
+  (mapc #'(lambda (type) 
+	    (register-type (car type) (cdr type)))
+	*registered-types*)
+  (mapc #'(lambda (type) 
+	    (register-type-alias (car type) (cdr type)))
+	*registered-type-aliases*))
+
+(pushnew 'reinitialize-all-types 
+  #+cmu *after-save-initializations*
+  #+sbcl *init-hooks*)
+
+#+cmu
+(pushnew 'system::reinitialize-global-table ; we shouldn't have to do this?
+ *after-save-initializations*)
+
+
+(defun find-type-number (type &optional error-p)
   (etypecase type
     (integer type)
-    (string
-     (let ((type-number (%type-from-name type)))
-       (cond
-	((and (zerop type-number) error)
-	 (error "Invalid gtype name: ~A" type))
-	((zerop type-number) nil)
-	(t type-number))))
+    (string (type-number-from-glib-name type error-p))
     (symbol
-     (let ((type-number (gethash type *type-to-number-hash*)))
-       (or
-	type-number
-	(and error (error "Type not registered: ~A" type)))))
-    (class (find-type-number (class-name type) error))))
+     (or
+      (gethash type *lisp-type-to-type-number*)
+      (and error-p (error "Type not registered: ~A" type))))
+    (class (find-type-number (class-name type) error-p))))
  
 (defun type-from-number (type-number &optional error)
   (multiple-value-bind (type found)
-      (gethash type-number *number-to-type-hash*)
+      (gethash type-number *type-number-to-lisp-type*)
     (when (and error (not found))
-      (let ((name (find-type-name type-number)))
+      (let ((name (find-foreign-type-name type-number)))
 	(if name
 	    (error "Type number not registered: ~A (~A)" type-number name)
 	  (error "Invalid type number: ~A" type-number))))
     type))
 
-(defun type-from-name (name)
-  (etypecase name
-    (string (type-from-number (find-type-number name t)))))
-
-(defbinding (find-type-name "g_type_name") (type) (copy-of string)
+(defbinding (find-foreign-type-name "g_type_name") (type) (copy-of string)
   ((find-type-number type t) type-number))
 
 (defun type-number-of (object)
   (find-type-number (type-of object) t))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun %find-types-in-library (pathname prefix ignore)
+  (defvar *type-initializers* ())
+  (defun %find-types-in-library (pathname prefixes ignore)
     (let ((process (run-program
 		    "/usr/bin/nm" (list "--defined-only" "-D" (namestring (truename pathname)))
 		    :output :stream :wait nil)))
@@ -164,9 +187,15 @@   (defun %find-types-in-library (pathname prefix ignore)
 			 (when line (subseq line 11)))			  
 	   while symbol
 	   when (and
-		 (> (length symbol) (length prefix))
-		 (string= prefix symbol :end2 (length prefix))
-		 (search "_get_type" symbol)
+		 (> (length symbol) 9)
+		 (or 
+		  (not prefixes)
+		  (some #'(lambda (prefix)
+			    (and
+			     (> (length symbol) (length prefix))
+			     (string= prefix symbol :end2 (length prefix))))
+			(mklist prefixes)))
+		 (string= "_get_type" symbol :start2 (- (length symbol) 9))
 		 (not (member symbol ignore :test #'string=)))
 	   collect symbol)
 	(process-close process)))))
@@ -178,9 +207,23 @@ (defmacro init-types-in-library (filename &key (prefix "") ignore)
        ,@(mapcar #'(lambda (name)
 		     `(progn
 			(defbinding (,(intern name) ,name) () type-number)
-			(,(intern name))))
+			(,(intern name))
+			(pushnew ',(intern name) *type-initializers*)))
 		 names))))
 
+(defun find-type-init-function (type-number)
+  (or
+   (loop
+    for type-init in *type-initializers*
+    when (= type-number (funcall type-init))
+    do (return type-init))
+   (error "Can't find init function for type number ~D" type-number)))
+
+(defun default-type-init-name (type)
+  (find-symbol (format nil "~A_~A_get_type" 
+		(package-prefix *package*)
+		(substitute #\_ #\- (string-downcase type)))))
+
 
 
 ;;;; Metaclass for subclasses of ginstance
@@ -190,18 +233,17 @@   (defclass ginstance-class (proxy-class)
     ()))
 
 
-(defmethod shared-initialize ((class ginstance-class) names
-			      &rest initargs &key name alien-name)
+(defmethod shared-initialize ((class ginstance-class) names &key name gtype)
   (declare (ignore names))
   (let* ((class-name (or name (class-name class)))
-	 (type-number
-	  (find-type-number
-	   (or (first alien-name) (default-alien-type-name class-name)) t)))
-    (register-type class-name type-number)
-    (if (getf initargs :size)
-	(call-next-method)
-      (let ((size (type-instance-size type-number)))
-	(apply #'call-next-method class names :size (list size) initargs)))))
+	 (type-number 
+	  (or 
+	   (find-type-number class-name)
+	   (register-type class-name 
+	     (or (first gtype) (default-type-init-name class-name))))))
+    (call-next-method)
+    (when (slot-boundp class 'size)
+      (setf (slot-value class 'size) (type-instance-size type-number)))))
 
 
 (defmethod validate-superclass ((class ginstance-class) (super standard-class))
@@ -248,8 +290,8 @@ (register-type 'pointer "gpointer")
 (register-type 'char "gchar")
 (register-type 'unsigned-char "guchar")
 (register-type 'boolean "gboolean")
-(register-type 'fixnum "gint")
 (register-type 'int "gint")
+(register-type-alias 'fixnum 'int)
 (register-type 'unsigned-int "guint")
 (register-type 'long "glong")
 (register-type 'unsigned-long "gulong")
@@ -320,7 +362,7 @@ (defun map-subtypes (function type &optional prefix)
 	   #'(lambda (type-number)
 	       (when (or
 		      (not prefix)
-		      (string-prefix-p prefix (find-type-name type-number)))
+		      (string-prefix-p prefix (find-foreign-type-name type-number)))
 		 (funcall function type-number))
 	       (map-subtypes function type-number prefix))
 	   array 'type-number length)
@@ -374,14 +416,14 @@ (defun %sort-types-topologicaly (types)
 
 
 (defun expand-type-definitions (prefix &optional args)
- (flet ((type-options (type-number)
-	   (let ((name (find-type-name type-number)))
+  (flet ((type-options (type-number)
+	   (let ((name (find-foreign-type-name type-number)))
 	     (cdr (assoc name args :test #'string=)))))
 
    (let ((type-list
 	  (delete-if
 	   #'(lambda (type-number)
-	       (let ((name (find-type-name type-number)))
+	       (let ((name (find-foreign-type-name type-number)))
 		 (or
 		  (getf (type-options type-number) :ignore)
 		  (find-if
@@ -397,10 +439,10 @@ (defun expand-type-definitions (prefix &optional args)
 	   (find-types prefix))))
 
      (dolist (type-number type-list)
-       (let ((name (find-type-name type-number)))
+       (let ((name (find-foreign-type-name type-number)))
 	 (register-type
 	  (getf (type-options type-number) :type (default-type-name name))
-	  type-number)))
+	  (find-type-init-function type-number))))
 
      (let ((sorted-type-list (%sort-types-topologicaly type-list)))
        `(progn
diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp
index e643681..d759227 100644
--- a/gtk/gtkobject.lisp
+++ b/gtk/gtkobject.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtkobject.lisp,v 1.23 2005-02-03 23:09:09 espen Exp $
+;; $Id: gtkobject.lisp,v 1.24 2005-03-06 17:26:23 espen Exp $
 
 
 (in-package "GTK")
@@ -36,13 +36,12 @@ (in-package "GTK")
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (init-types-in-library 
    #.(concatenate 'string (pkg-config:pkg-variable "gtk+-2.0" "libdir") 
-		          "/libgtk-x11-2.0.so")
-   :ignore ("gtk_window_get_type_hint"))
+		          "/libgtk-x11-2.0.so"))
 
   (defclass %object (gobject)
     ()
     (:metaclass gobject-class)
-    (:alien-name "GtkObject")))
+    (:gtype |gtk_object_get_type|)))
 
 
 (defmethod initialize-instance ((object %object) &rest initargs &key signal)
@@ -133,14 +132,13 @@   (defun %container-child-set-property (parent child pname gvalue)))
 
 
 (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-definition))
-  (let* ((type (slot-definition-type slotd))
-	 (pname (slot-definition-pname slotd))
-	 (type-number (find-type-number type)))
+  (let ((type (slot-definition-type slotd))
+	(pname (slot-definition-pname slotd)))
     (setf 
      (slot-value slotd 'getter)
      #'(lambda (object)
 	 (with-slots (parent child) object	   
-	   (let ((gvalue (gvalue-new type-number)))
+	   (let ((gvalue (gvalue-new type)))
 	     (%container-child-get-property parent child pname gvalue)
 	     (unwind-protect
 		 (funcall (reader-function type) gvalue +gvalue-value-offset+)
@@ -150,7 +148,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-defin
      (slot-value slotd 'setter)
      #'(lambda (value object)
 	 (with-slots (parent child) object	   
-	   (let ((gvalue (gvalue-new type-number)))
+	   (let ((gvalue (gvalue-new type)))
 	     (funcall (writer-function type) value gvalue +gvalue-value-offset+)
 	     (%container-child-set-property parent child pname gvalue)
 	     (gvalue-free gvalue t)
diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp
index 4474226..aeab0f6 100644
--- a/gtk/gtktypes.lisp
+++ b/gtk/gtktypes.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtktypes.lisp,v 1.33 2005-02-27 15:39:52 espen Exp $
+;; $Id: gtktypes.lisp,v 1.34 2005-03-06 17:26:23 espen Exp $
 
 (in-package "GTK")
 
@@ -123,7 +123,7 @@ (defclass tree-iter (boxed)
 ;;   (:metaclass boxed-class))
 
 (deftype tree-path () '(vector integer))
-(register-type 'tree-path "GtkTreePath")
+(register-type 'tree-path '|gtk_tree_path_get_type|)
 
 (deftype position () 
   '(or int (enum (:start 0) (:end -1) (:first 0) (:last -1))))
diff --git a/pango/pango.asd b/pango/pango.asd
index 96b1e2c..b5b9cb5 100644
--- a/pango/pango.asd
+++ b/pango/pango.asd
@@ -12,7 +12,9 @@
 (defsystem pango
     :depends-on (glib)
     :components ((:library "libpango-1.0" :libdir #.(pkg-variable "pango" "libdir"))
-		 (:library "libpangoxft-1.0" :libdir #.(pkg-variable "pango" "libdir"))		 (:file "defpackage")
+		 (:library "libpangoxft-1.0" :libdir #.(pkg-variable "pango" "libdir"))
+		 (:library "libpangoft2-1.0" :libdir #.(pkg-variable "pango" "libdir"))
+		 (:file "defpackage")
 		 (:file "pango" :depends-on ("defpackage" "libpango-1.0" "libpangoxft-1.0"))
 		 (:file "export" :depends-on ("pango"))))
 
diff --git a/pango/pango.lisp b/pango/pango.lisp
index c0f30fb..18f5be0 100644
--- a/pango/pango.lisp
+++ b/pango/pango.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: pango.lisp,v 1.7 2005-02-03 23:09:06 espen Exp $
+;; $Id: pango.lisp,v 1.8 2005-03-06 17:26:23 espen Exp $
 
 (in-package "PANGO")
 
@@ -25,6 +25,9 @@ (eval-when (:compile-toplevel :load-toplevel :execute)
 		          "/libpango-1.0.so") :prefix "pango_")
   (init-types-in-library #.(concatenate 'string 
 			  (pkg-config:pkg-variable "pango" "libdir")
-		          "/libpangoxft-1.0.so") :prefix "pango_xft"))
+		          "/libpangoxft-1.0.so") :prefix "pango_xft")
+  (init-types-in-library #.(concatenate 'string 
+			  (pkg-config:pkg-variable "pango" "libdir")
+		          "/libpangoft2-1.0.so") :prefix "pango_fc"))
 
 (define-types-by-introspection "Pango")