X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.meta.lisp;h=120a958dc12bfa2ec4edd13092ccf0a9c2e8fab6;hb=96aa7293addaacdfe29ce32e60e2feac7df6ffce;hp=5b0c3e6473a345c10ed3c79b57d666e789646db5;hpb=5953ac4d60cff5f1fbdc0229d2c5acc0876d8bbb;p=cl-gtk2.git diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp old mode 100755 new mode 100644 index 5b0c3e6..120a958 --- a/glib/gobject.meta.lisp +++ b/glib/gobject.meta.lisp @@ -19,21 +19,21 @@ (let* ((initializer-fn-ptr (foreign-symbol-pointer (gobject-class-g-type-initializer class))) (type (when initializer-fn-ptr (foreign-funcall-pointer initializer-fn-ptr nil - g-type)))) + g-type-designator)))) (if (null initializer-fn-ptr) (warn "Type initializer for class '~A' (GType '~A') is invalid: foreign symbol '~A'" (gobject-class-direct-g-type-name class) (class-name class) (gobject-class-g-type-initializer class)) (progn - (when (g-type= +g-type-invalid+ type) + (when (eq (gtype +g-type-invalid+) type) (warn "Declared GType name '~A' for class '~A' is invalid ('~A' returned 0)" (gobject-class-direct-g-type-name class) (class-name class) (gobject-class-g-type-initializer class))) - (unless (g-type= (gobject-class-direct-g-type-name class) type) + (unless (eq (gtype (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-direct-g-type-name class) (class-name class) - (g-type-name type)))))) - (unless (g-type-from-name (gobject-class-direct-g-type-name class)) + (gtype-name type)))))) + (when (zerop (gtype-id (gtype (gobject-class-direct-g-type-name class)))) (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))))) @@ -63,8 +63,8 @@ (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)))) + (apply #'call-next-method class (compute-new-initargs-for-metaclass initargs 'g-object)) + (call-next-method))) (defmethod initialize-instance :after ((object gobject-class) &key &allow-other-keys) (when (gobject-class-direct-g-type-name object) @@ -72,6 +72,8 @@ (at-init (object) (initialize-gobject-class-g-type object)))) (defmethod finalize-inheritance :after ((class gobject-class)) + (iter (for superclass in (class-direct-superclasses class)) + (unless (class-finalized-p superclass) (finalize-inheritance superclass))) (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)) @@ -122,22 +124,27 @@ (defmethod validate-superclass ((class gobject-class) (superclass standard-class)) t) -(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs &key allocation) +(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs &key allocation &allow-other-keys) (declare (ignore initargs)) (case allocation - (:gobject-property 'gobject-property-direct-slot-definition) - (:gobject-fn 'gobject-fn-direct-slot-definition) + (:gobject-property (find-class 'gobject-property-direct-slot-definition)) + (:gobject-fn (find-class 'gobject-fn-direct-slot-definition)) (otherwise (call-next-method)))) -(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs &key allocation) +(defvar *e-s-d* nil) + +(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs) (declare (ignore initargs)) - (case allocation - (:gobject-property 'gobject-property-effective-slot-definition) - (:gobject-fn 'gobject-fn-effective-slot-definition) - (otherwise (call-next-method)))) + (or *e-s-d* (call-next-method))) (defmethod compute-effective-slot-definition ((class gobject-class) name direct-slots) - (let ((effective-slot (call-next-method))) + (let ((effective-slot (let ((*e-s-d* (loop + for slot in direct-slots + when (typep slot 'gobject-direct-slot-definition) + return (etypecase slot + (gobject-property-direct-slot-definition (find-class 'gobject-property-effective-slot-definition)) + (gobject-fn-direct-slot-definition (find-class 'gobject-fn-effective-slot-definition)))))) + (call-next-method)))) (when (typep effective-slot 'gobject-effective-slot-definition) (let ((allocation (loop for direct-slot in direct-slots @@ -176,31 +183,28 @@ (gobject-fn-effective-slot-definition-g-getter-fn effective-slot) (and property-getter (if (stringp property-getter) - (if (foreign-symbol-pointer property-getter) - (compile nil `(lambda (object) - (foreign-funcall ,property-getter - g-object object - ,property-type))) - (progn - (warn "Property reader function '~A' has not been found" property-getter) - (lambda (object) - (declare (ignore object)) - (error "Property reader function '~A' has not been found" property-getter)))) + (compile nil (if (foreign-symbol-pointer property-getter) + `(lambda (object) + (foreign-funcall ,property-getter + g-object object + ,property-type)) + `(lambda (object) + (declare (ignore object)) + (error "Property getter ~A is not available" ,property-getter)) + )) property-getter)) (gobject-fn-effective-slot-definition-g-setter-fn effective-slot) (and property-setter (if (stringp property-setter) - (if (foreign-symbol-pointer property-setter) - (compile nil `(lambda (object new-value) - (foreign-funcall ,property-setter - g-object object - ,property-type new-value - :void))) - (progn - (warn "Property writer function '~A' has not been found" property-setter) - (lambda (object) - (declare (ignore object)) - (error "Property writer function '~A' has not been found" property-setter)))) + (compile nil (if (foreign-symbol-pointer property-setter) + `(lambda (object new-value) + (foreign-funcall ,property-setter + g-object object + ,property-type new-value + :void)) + `(lambda (object) + (declare (ignore object)) + (error "Property setter ~A is not avaiable" ,property-setter)))) property-setter))))))) effective-slot))