chiark / gitweb /
Changes necessary to allow saving of core images with clg.
authorespen <espen>
Sun, 6 Mar 2005 17:26:22 +0000 (17:26 +0000)
committerespen <espen>
Sun, 6 Mar 2005 17:26:22 +0000 (17:26 +0000)
12 files changed:
gdk/gdkevents.lisp
gdk/gdktypes.lisp
glib/gboxed.lisp
glib/genums.lisp
glib/ginterface.lisp
glib/gobject.lisp
glib/gparam.lisp
glib/gtype.lisp
gtk/gtkobject.lisp
gtk/gtktypes.lisp
pango/pango.asd
pango/pango.lisp

index 8ef0f4439ea9ee39748cf3d4411c0c8ff48219c6..ecc57173ad46318d73402b5f38303ca8d44a393f 100644 (file)
@@ -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)
index e8cd686f93889dc51c9250d2639dd7127c2eb549..fdda99d95570cbbaec54a037e90208fc8bc70ebd 100644 (file)
 ;; 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)
index 4b36115a9f46d25690f842caf6ba527bfd0ad866..c5dd25379e217a50c18d6d6e0f4879f8868e3441 100644 (file)
@@ -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|)
index 4e4e766342c5cedcff0e0ef3ca56663868fff9c2..3a670e6ed34cb5d132ff8b8bca28895c71cb9b21 100644 (file)
@@ -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))))))
index 8001f72b43da932109f012f2a74124fb565aa45b..a48c552262a29f0f72179a0f576e439ca8b9117a 100644 (file)
@@ -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 
index 823a7eab5be8729bd7e1fe7cebe466b575fb572e..deba03b46a2ceccfeb5ab9ff2f51c322ed6ab353 100644 (file)
@@ -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 
index a0a0883c022b5c8be7e33593d3a75a546f7b84a9..a9d5a754d9c7881208c132b5834ac95da1855ef2 100644 (file)
@@ -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
 ;; 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"))
index 8a3b275c0eea62d8c1390497106834a3e3c2bd68..e05dfd0e2e6debdbc3dd2867ea595224863337ec 100644 (file)
@@ -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
index 191b8e60cf197cd517f24a60265f1b2fd956f289..54e7640913c72e9ee03ef6ab2f276d0022c770c4 100644 (file)
@@ -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)
index 38da84b98366635e254e30fbe2c12022e942e5d3..9bdf71933e2011fb7be1707bd27f0b0008a85083 100644 (file)
@@ -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))))
index 96b1e2cedd1e58007429e6bf96ab9deece720537..b5b9cb5c0ef3b48cb7b2fe0bbb8ab7d2fbbbd509 100644 (file)
@@ -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"))))
 
index 9fdd0164c9904550fba7976d656becb160e840e0..aa2a381d17fec48901355416d265044c1033ee18 100644 (file)
@@ -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")