Added documentation skeleton and merged skeleton with exisiting docs

[cl-gtk2.git] / glib / gobject.meta.lisp

diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp
index e4fc5e3..2b67e7e 100644 (file)
--- a/glib/gobject.meta.lisp
+++ b/glib/gobject.meta.lisp
@@ -1,9 +1,11 @@
 (in-package :gobject)
 
 (defclass gobject-class (standard-class)
-  ((g-type-name :initform (error "G-TYPE-NAME must be specified")
-                :initarg :g-type-name
-                :reader gobject-class-g-type-name)
+  ((g-type-name :initform nil
+                :accessor gobject-class-g-type-name)
+   (direct-g-type-name :initform nil
+                       :initarg :g-type-name
+                       :accessor gobject-class-direct-g-type-name)
    (g-type-initializer :initform nil
                        :initarg :g-type-initializer
                        :reader gobject-class-g-type-initializer)
@@ -20,24 +22,33 @@
                                               g-type))))
         (if (null initializer-fn-ptr)
             (warn "Type initializer for class '~A' (GType '~A') is invalid: foreign symbol '~A'"
-                  (gobject-class-g-type-name class) (class-name class) (gobject-class-g-type-initializer class))
+                  (gobject-class-direct-g-type-name class) (class-name class) (gobject-class-g-type-initializer class))
             (progn
               (when (g-type= +g-type-invalid+ type)
                 (warn "Declared GType name '~A' for class '~A' is invalid ('~A' returned 0)"
-                      (gobject-class-g-type-name class) (class-name class)
+                      (gobject-class-direct-g-type-name class) (class-name class)
                       (gobject-class-g-type-initializer class)))
-              (unless (g-type= (gobject-class-g-type-name class) type)
+              (unless (g-type= (gobject-class-direct-g-type-name class) type)
                 (warn "Declared GType name '~A' for class '~A' does not match actual GType name '~A'"
-                      (gobject-class-g-type-name class)
+                      (gobject-class-direct-g-type-name class)
                       (class-name class)
                       (g-type-name type))))))
-      (unless (g-type-from-name (gobject-class-g-type-name class))
+      (unless (g-type-from-name (gobject-class-direct-g-type-name class))
         (warn "Declared GType name '~A' for class '~A' is invalid (g_type_name returned 0)"
-              (gobject-class-g-type-name class) (class-name class)))))
+              (gobject-class-direct-g-type-name class) (class-name class)))))
 
 (defmethod initialize-instance :after ((object gobject-class) &key &allow-other-keys)
-  (register-object-type (gobject-class-g-type-name object) (class-name object))
-  (at-init (object) (initialize-gobject-class-g-type object)))
+  (when (gobject-class-direct-g-type-name object)
+    (register-object-type (gobject-class-direct-g-type-name object) (class-name object))
+    (at-init (object) (initialize-gobject-class-g-type object))))
+
+(defmethod finalize-inheritance :after ((class gobject-class))
+  (setf (gobject-class-g-type-name class)
+        (or (gobject-class-direct-g-type-name class)
+            (let ((gobject-superclass (iter (for superclass in (class-direct-superclasses class))
+                                            (finding superclass such-that (typep superclass 'gobject-class)))))
+              (assert gobject-superclass)
+              (gobject-class-g-type-name gobject-superclass)))))
 
 (defclass gobject-direct-slot-definition (standard-direct-slot-definition)
   ((g-property-type :initform nil
@@ -82,9 +93,6 @@
 (defmethod validate-superclass ((class gobject-class) (superclass standard-class))
   t)
 
-(defmethod validate-superclass ((class standard-class) (superclass gobject-class))
-  t)
-
 (defmethod compute-class-precedence-list ((class gobject-class))
   (let ((classes (call-next-method)))
     (if (member (find-class 'g-object) classes)
@@ -201,8 +209,11 @@
       (progn
         (assert (= (length initargs) 2) nil "POINTER can not be combined with other initargs (~A)" initargs)
         (call-next-method))
-      (let ((pointer (create-gobject-from-class-and-initargs class initargs)))
-        (apply #'call-next-method class :pointer pointer initargs))))
+      (let* ((default-initargs (iter (for (arg value) in (class-default-initargs class))
+                                     (nconcing (list arg value))))
+             (effective-initargs (append initargs default-initargs))
+             (pointer (create-gobject-from-class-and-initargs class effective-initargs)))
+        (apply #'call-next-method class :pointer pointer effective-initargs))))
 
 (defmethod slot-boundp-using-class ((class gobject-class) object (slot gobject-property-effective-slot-definition))
   (handler-case