Hack to make TYPE-FROM-NUMBER work with types that are registered multiple times...

[clg] / glib / gtype.lisp

diff --git a/glib/gtype.lisp b/glib/gtype.lisp
index ea24580..b13bc6d 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.32 2005-04-23 16:48:51 espen Exp $
+;; $Id: gtype.lisp,v 1.34 2006-02-01 14:17:37 espen Exp $
 
 (in-package "GLIB")
 
@@ -167,12 +167,18 @@
 (defun type-from-number (type-number &optional error)
   (multiple-value-bind (type found)
       (gethash type-number *type-number-to-lisp-type*)
-    (when (and error (not found))
+    (if found
+       type
       (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))
+       (cond
+        ((and name (type-number-from-glib-name name nil))
+         ;; This is a hack because GdkEvent seems to be registered
+         ;; multiple times
+         (type-from-number (type-number-from-glib-name name)))
+        ((and error name)
+         (error "Type number not registered: ~A (~A)" type-number name))
+        ((and error)
+         (error "Invalid type number: ~A" type-number)))))))
 
 (defbinding (find-foreign-type-name "g_type_name") (type) (copy-of string)
   ((find-type-number type t) type-number))
@@ -234,6 +240,40 @@
                (substitute #\_ #\- (string-downcase type)))))
 
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass type-info (struct)
+    ((class-size :allocation :alien :type (unsigned 16) :initarg :class-size)
+     (base-init :allocation :alien :type pointer)
+     (base-finalize :allocation :alien :type pointer)
+     (class-init :allocation :alien :type pointer)
+     (class-finalize :allocation :alien :type pointer)
+     (class-data :allocation :alien :type pointer)
+     (instance-size :allocation :alien :type (unsigned 16) 
+                   :initarg :instance-size)
+     (n-preallocs :allocation :alien :type (unsigned 16))
+     (instance-init :allocation :alien :type pointer)
+     (value-table :allocation :alien :type pointer))
+    (:metaclass struct-class)))
+
+(defbinding %type-register-static () type-number
+  (parent-type type-number)
+  (name string)
+  (info type-info)
+  (0 unsigned-int))
+
+(defun register-new-type (type parent)
+  (let ((parent-info (type-query parent)))
+    (with-slots ((parent-number type-number) class-size instance-size) parent-info
+      (let ((type-number 
+            (%type-register-static 
+             parent-number
+             (default-alien-type-name type)
+             (make-instance 'type-info :class-size class-size :instance-size instance-size))))
+       (setf (gethash type *lisp-type-to-type-number*) type-number)
+       (setf (gethash type-number *type-number-to-lisp-type*) type)
+       type-number))))
+
+
 
 ;;;; Metaclass for subclasses of ginstance