From 6dfb20397142408cc4adfa437bb12d8aa300270e Mon Sep 17 00:00:00 2001
From: Rupert Swarbrick <rswarbrick@gmail.com>
Date: Tue, 8 Jun 2010 11:43:53 +0100
Subject: [PATCH] Fix compilation for Gtk with the new, stricter inheritance
 rules. Also, change the prefix lookup so that it's possible to bind
 "GtkClutterFoo", without it landing in :gtk.

---
 gffi/interface.lisp | 20 ++++++++++++--------
 gtk/gtktypes.lisp   |  5 +++++
 2 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/gffi/interface.lisp b/gffi/interface.lisp
index 084ed47..d89e9a7 100644
--- a/gffi/interface.lisp
+++ b/gffi/interface.lisp
@@ -72,15 +72,19 @@
       #'string-capitalize    
       (cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
 
-(defun default-type-name (alien-name)
-  (let ((parts
-	 (mapcar
-	  #'string-upcase
-	  (split-string-if alien-name #'upper-case-p))))
-    (intern
-     (concatenate-strings (rest parts) #\-)
-     (find-prefix-package (first parts)))))
+(defun split-alien-name (alien-name)
+  (let ((parts (split-string-if alien-name #'upper-case-p)))
+    (do ((prefix (first parts) (concatenate 'string prefix (first rest)))
+         (rest (rest parts) (cdr rest)))
+        ((null rest)
+         (error "Couldn't split alien name '~A' to find a registered prefix"
+                alien-name))
+      (when (find-prefix-package prefix)
+        (return (values (string-upcase (concatenate-strings rest #\-))
+                        (find-prefix-package prefix)))))))
 
+(defun default-type-name (alien-name)
+  (multiple-value-call #'intern (split-alien-name alien-name)))
 
 (defun in-arg-p (style)
   (find style '(:in :in/out :in/return :in-out :return)))
diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp
index dfa9c05..1155977 100644
--- a/gtk/gtktypes.lisp
+++ b/gtk/gtktypes.lisp
@@ -145,6 +145,11 @@
   (declare (ignore type ref))
   (reader-function 'int))
 
+;; Register GtkObject in advance so that eg GtkTooltips, which inherits from it,
+;; gets a proper supertype. TODO: This is a hack. Where is it supposed to
+;; happen?
+(register-type '%object "GtkObject")
+
 (define-types-by-introspection "Gtk"
   ;; Manually defined
   ("GtkObject" :ignore t)
-- 
2.11.0