From 53c3986b25c1917efd0ef98a856120ab709490cb Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Sat, 29 Aug 2009 22:05:25 +0400 Subject: [PATCH] Improvement of GObject class mapping: if class specifies a NIL g-type-name then this class maps to an instance of GObject class that is mapped to by its superclass --- glib/gobject.meta.lisp | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp index e4fc5e3..086a5ac 100644 --- a/glib/gobject.meta.lisp +++ b/glib/gobject.meta.lisp @@ -1,9 +1,9 @@ (in-package :gobject) (defclass gobject-class (standard-class) - ((g-type-name :initform (error "G-TYPE-NAME must be specified") + ((g-type-name :initform nil :initarg :g-type-name - :reader gobject-class-g-type-name) + :accessor gobject-class-g-type-name) (g-type-initializer :initform nil :initarg :g-type-initializer :reader gobject-class-g-type-initializer) @@ -36,9 +36,18 @@ (gobject-class-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)) + (when (gobject-class-g-type-name object) + (register-object-type (gobject-class-g-type-name object) (class-name object))) (at-init (object) (initialize-gobject-class-g-type object))) +(defmethod finalize-inheritance :after ((class gobject-class)) + (unless (gobject-class-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) + (setf (gobject-class-g-type-name class) + (gobject-class-g-type-name gobject-superclass))))) + (defclass gobject-direct-slot-definition (standard-direct-slot-definition) ((g-property-type :initform nil :initarg :g-property-type @@ -82,9 +91,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) -- 1.7.10.4