X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.meta.lisp;h=120a958dc12bfa2ec4edd13092ccf0a9c2e8fab6;hb=96aa7293addaacdfe29ce32e60e2feac7df6ffce;hp=6874d23e9e134636d34830d04210548ff8f021e7;hpb=e626963f698d60495729620ae44e4b236010836c;p=cl-gtk2.git diff --git a/glib/gobject.meta.lisp b/glib/gobject.meta.lisp index 6874d23..120a958 100644 --- a/glib/gobject.meta.lisp +++ b/glib/gobject.meta.lisp @@ -1,29 +1,85 @@ (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) (interface-p :initform nil :initarg :g-interface-p - :reader gobject-class-interface-p))) + :reader gobject-class-interface-p)) + (:documentation "Metaclass for GObject-based classes.")) + +(defun initialize-gobject-class-g-type (class) + (if (gobject-class-g-type-initializer class) + (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-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 (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 (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) + (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))))) + +(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 + (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) - (register-object-type (gobject-class-g-type-name object) (class-name object)) - (when (gobject-class-g-type-initializer object) - (let ((type (foreign-funcall-pointer (foreign-symbol-pointer (gobject-class-g-type-initializer object)) nil - g-type))) - (assert (/= +g-type-invalid+ type) nil "Declared GType name '~A' for class '~A' is invalid (g_type_name returned 0)" - (gobject-class-g-type-name object) (class-name object)) - (assert (string= (gobject-class-g-type-name object) - (g-type-name type)) - nil "Declared GType name '~A' for class '~A' does not match actual GType name '~A'" - (gobject-class-g-type-name object) - (class-name object) - (g-type-name type))))) + (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)) + (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)) + (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 @@ -68,31 +124,27 @@ (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) - classes - `(,class ,(find-class 'g-object) ,@(rest classes))))) - -(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 @@ -131,19 +183,28 @@ (gobject-fn-effective-slot-definition-g-getter-fn effective-slot) (and property-getter (if (stringp property-getter) - (compile nil `(lambda (object) - (foreign-funcall ,property-getter - g-object object - ,property-type))) + (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) - (compile nil `(lambda (object new-value) - (foreign-funcall ,property-setter - g-object object - ,property-type new-value - :void))) + (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)) @@ -175,7 +236,7 @@ (iter (with slots = (class-slots class)) (for (arg-name arg-value) on initargs by #'cddr) (for slot = (find arg-name slots :key #'slot-definition-initargs :test 'member)) - (when (or (eq arg-name :pointer) (null slot)) + (unless (and slot (typep slot 'gobject-effective-slot-definition)) (nconcing (list arg-name arg-value))))) (defmethod initialize-instance ((instance g-object) &rest initargs &key &allow-other-keys) @@ -183,39 +244,53 @@ (apply #'call-next-method instance filtered-initargs))) (defmethod make-instance ((class gobject-class) &rest initargs &key pointer) - (if pointer - (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)))) + (log-for :subclass "(make-instance ~A ~{~A~^ ~})~%" class initargs) + (let ((*currently-making-object-p* t)) + (if pointer + (progn + (assert (= (length initargs) 2) nil "POINTER can not be combined with other initargs (~A)" initargs) + (call-next-method)) + (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 - (progn (g-object-property-type object (gobject-property-effective-slot-definition-g-property-name slot) :assert-readable t) t) + (and (slot-boundp object 'pointer) + (pointer object) + (progn (g-object-property-type (pointer object) (gobject-property-effective-slot-definition-g-property-name slot) :assert-readable t) t)) (property-unreadable-error () nil))) (defmethod slot-value-using-class ((class gobject-class) object (slot gobject-property-effective-slot-definition)) - (g-object-call-get-property object + (g-object-call-get-property (pointer object) (gobject-property-effective-slot-definition-g-property-name slot) (gobject-effective-slot-definition-g-property-type slot))) (defmethod (setf slot-value-using-class) (new-value (class gobject-class) object (slot gobject-property-effective-slot-definition)) - (g-object-call-set-property object + (g-object-call-set-property (pointer object) (gobject-property-effective-slot-definition-g-property-name slot) new-value - (gobject-effective-slot-definition-g-property-type slot))) + (gobject-effective-slot-definition-g-property-type slot)) + new-value) + +(defmethod slot-boundp-using-class ((class gobject-class) object (slot gobject-fn-effective-slot-definition)) + (and (slot-boundp object 'pointer) + (pointer object) + (not (null (gobject-fn-effective-slot-definition-g-getter-fn slot))))) (defmethod slot-value-using-class ((class gobject-class) object (slot gobject-fn-effective-slot-definition)) (let ((fn (gobject-fn-effective-slot-definition-g-getter-fn slot))) - (when fn - (funcall fn object)))) + (funcall fn object))) (defmethod (setf slot-value-using-class) (new-value (class gobject-class) object (slot gobject-fn-effective-slot-definition)) - (funcall (gobject-fn-effective-slot-definition-g-setter-fn slot) object new-value)) + (funcall (gobject-fn-effective-slot-definition-g-setter-fn slot) object new-value) + new-value) (defmethod slot-boundp-using-class ((class gobject-class) object (slot gobject-effective-slot-definition)) - t) + (slot-boundp object 'pointer)) (defmethod slot-makunbound-using-class ((class gobject-class) object (slot gobject-effective-slot-definition)) + (declare (ignore object)) nil)