From: Kalyanov Dmitry <Kalyanov.Dmitry@gmail.com>
Date: Thu, 8 Oct 2009 14:23:06 +0000 (+0400)
Subject: gobject: use more portable approach for injecting base class for metaclass
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5953ac4d60cff5f1fbdc0229d2c5acc0876d8bbb;p=cl-gtk2.git

gobject: use more portable approach for injecting base class for metaclass
---

diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp
index aaa54b2..5b0c3e6 100755
--- a/glib/gobject.meta.lisp
+++ b/glib/gobject.meta.lisp
@@ -37,6 +37,35 @@
         (warn "Declared GType name '~A' for class '~A' is invalid (g_type_name returned 0)"
               (gobject-class-direct-g-type-name class) (class-name class)))))
 
+(defun filter-from-initargs (initargs removed-key)
+  (loop
+     for (key value) on initargs by #'cddr
+     unless (eq key removed-key)
+     collect key and collect value))
+
+(defun initargs-have-base-in-superclass (initargs base-class)
+  (let ((d-s (getf initargs :direct-superclasses)))
+    (loop
+       for class in d-s
+       thereis (subtypep class base-class))))
+
+(defun compute-new-initargs-for-metaclass (initargs base-class)
+  (if (initargs-have-base-in-superclass initargs base-class)
+      initargs
+      (append (filter-from-initargs initargs :direct-superclasses)
+	      (list :direct-superclasses
+		    (append (getf initargs :direct-superclasses)
+			    (list (find-class base-class)))))))
+
+(defmethod initialize-instance :around ((class gobject-class) &rest initargs)
+  (apply #'call-next-method class (compute-new-initargs-for-metaclass initargs 'g-object)))
+
+(defmethod reinitialize-instance :around ((class gobject-class) &rest initargs &key (direct-superclasses nil d-s-p) &allow-other-keys)
+  (declare (ignore direct-superclasses))
+  (if d-s-p
+      (call-next-method)
+      (apply #'call-next-method class (compute-new-initargs-for-metaclass initargs 'g-object))))
+
 (defmethod initialize-instance :after ((object gobject-class) &key &allow-other-keys)
   (when (gobject-class-direct-g-type-name object)
     (register-object-type (gobject-class-direct-g-type-name object) (class-name object))
@@ -93,12 +122,6 @@
 (defmethod validate-superclass ((class gobject-class) (superclass standard-class))
   t)
 
-(defmethod compute-class-precedence-list ((class gobject-class))
-  (let ((classes (call-next-method)))
-    (if (member (find-class 'g-object) classes)
-        classes
-        `(,class ,(find-class 'g-object) ,@(rest classes)))))
-
 (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs &key allocation)
   (declare (ignore initargs))
   (case allocation