(defstruct object-type name class parent interfaces properties)
(defun instance-init (instance class)
(defstruct object-type name class parent interfaces properties)
(defun instance-init (instance class)
(unless (or *current-creating-object*
(gethash (pointer-address instance) *foreign-gobjects-strong*)
(gethash (pointer-address instance) *foreign-gobjects-weak*))
(unless (or *current-creating-object*
(gethash (pointer-address instance) *foreign-gobjects-strong*)
(gethash (pointer-address instance) *foreign-gobjects-weak*))
(let* ((g-type (foreign-slot-value class 'g-type-class :type))
(type-name (g-type-name g-type))
(lisp-type-info (gethash type-name *registered-types*))
(let* ((g-type (foreign-slot-value class 'g-type-class :type))
(type-name (g-type-name g-type))
(lisp-type-info (gethash type-name *registered-types*))
(iter (for property in (object-type-properties lisp-type-info))
(for param-spec = (property->param-spec property))
(for property-id from 123)
(iter (for property in (object-type-properties lisp-type-info))
(for param-spec = (property->param-spec property))
(for property-id from 123)
(g-object-class-install-property class property-id param-spec))))
(defun vtable-item->cstruct-item (item)
(g-object-class-install-property class property-id param-spec))))
(defun vtable-item->cstruct-item (item)
(declare (ignorable class-name))
(let* ((vtable (gethash interface-name *vtables*))
(vtable-cstruct (vtable-description-cstruct-name vtable)))
(declare (ignorable class-name))
(let* ((vtable (gethash interface-name *vtables*))
(vtable-cstruct (vtable-description-cstruct-name vtable)))
(iter (for method in (vtable-description-methods vtable))
(setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method)))))))
(iter (for method in (vtable-description-methods vtable))
(setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method)))))))
(setf (foreign-slot-value class 'g-object-class :get-property)
(callback c-object-property-get)
(foreign-slot-value class 'g-object-class :set-property)
(setf (foreign-slot-value class 'g-object-class :get-property)
(callback c-object-property-get)
(foreign-slot-value class 'g-object-class :set-property)
(lisp-type-info (gethash type-name *registered-types*))
(property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
(property-get-fn (fourth property-info)))
(lisp-type-info (gethash type-name *registered-types*))
(property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
(property-get-fn (fourth property-info)))
(set-g-value g-value value property-type))))
(defcallback c-object-property-get :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
(set-g-value g-value value property-type))))
(defcallback c-object-property-get :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer))
(property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
(property-set-fn (fifth property-info))
(new-value (parse-g-value value)))
(property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first))
(property-set-fn (fifth property-info))
(new-value (parse-g-value value)))
(restart-case
(funcall property-set-fn new-value lisp-object)
(return-without-error-from-property-setter () nil))))
(restart-case
(funcall property-set-fn new-value lisp-object)
(return-without-error-from-property-setter () nil))))
`(progn
(setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties))
(at-init (',class)
`(progn
(setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties))
(at-init (',class)
(with-foreign-object (query 'g-type-query)
(g-type-query (g-type-from-name ,parent) query)
(g-type-register-static-simple (g-type-from-name ,parent)
(with-foreign-object (query 'g-type-query)
(g-type-query (g-type-from-name ,parent) query)
(g-type-register-static-simple (g-type-from-name ,parent)