+ (log-for :subclass "installing property ~A~%" property)
+ (g-object-class-install-property class property-id param-spec))))
+
+(defun vtable-item->cstruct-item (item)
+ (if (eq :skip (first item))
+ (rest item)
+ (list (first item) :pointer)))
+
+(defstruct vtable-method-info slot-name name return-type args callback-name impl-call)
+
+(defmethod make-load-form ((object vtable-method-info) &optional environment)
+ (declare (ignore environment))
+ `(make-vtable-method-info :slot-name ',(vtable-method-info-slot-name object)
+ :name ',(vtable-method-info-name object)
+ :return-type ',(vtable-method-info-return-type object)
+ :args ',(vtable-method-info-args object)
+ :callback-name ',(vtable-method-info-callback-name object)))
+
+(defun vtable-methods (iface-name items)
+ (iter (for item in items)
+ (when (eq :skip (first item)) (next-iteration))
+ (destructuring-bind (name (return-type &rest args) &key impl-call) item
+ (for method-name = (intern (format nil "~A-~A-IMPL" (symbol-name iface-name) (symbol-name name))))
+ (for callback-name = (intern (format nil "~A-~A-CALLBACK" (symbol-name iface-name) (symbol-name name))))
+ (collect (make-vtable-method-info :slot-name name
+ :name method-name
+ :return-type return-type
+ :args args
+ :callback-name callback-name
+ :impl-call impl-call)))))
+
+(defvar *vtables* (make-hash-table :test 'equal))
+
+(defstruct vtable-description type-name cstruct-name methods)
+
+(defmacro define-vtable ((type-name name) &body items)
+ (let ((cstruct-name (intern (format nil "~A-VTABLE" (symbol-name name))))
+ (methods (vtable-methods name items)))
+ `(progn
+ (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items))
+ (setf (gethash ,type-name *vtables*)
+ (make-vtable-description :type-name ,type-name
+ :cstruct-name ',cstruct-name
+ :methods (list ,@(mapcar #'make-load-form methods))))
+ ,@(iter (for method in methods)
+ (for args =
+ (if (vtable-method-info-impl-call method)
+ (first (vtable-method-info-impl-call method))
+ (mapcar #'first (vtable-method-info-args method))))
+ (collect `(defgeneric ,(vtable-method-info-name method) (,@args)))
+ (collect `(glib-defcallback ,(vtable-method-info-callback-name method)
+ ,(vtable-method-info-return-type method)
+ (,@(vtable-method-info-args method))
+ (restart-case
+ ,(if (vtable-method-info-impl-call method)
+ `(progn ,@(rest (vtable-method-info-impl-call method)))
+ `(,(vtable-method-info-name method)
+ ,@(mapcar #'first (vtable-method-info-args method))))
+ (return-from-interface-method-implementation (v)
+ :interactive (lambda () (list (eval (read)))) v))))))))
+
+(defun interface-init (iface data)
+ (destructuring-bind (class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data))
+ (declare (ignorable class-name))
+ (let* ((vtable (gethash interface-name *vtables*))
+ (vtable-cstruct (vtable-description-cstruct-name vtable)))
+ (log-for :subclass "interface-init for class ~A and interface ~A~%" class-name interface-name)
+ (iter (for method in (vtable-description-methods vtable))
+ (for cb = (get-callback (vtable-method-info-callback-name method)))
+ (for slot-name = (vtable-method-info-slot-name method))
+ (log-for :subclass "->setting method ~A to ~A~%" method cb)
+ (setf (foreign-slot-value iface vtable-cstruct slot-name) cb)))))
+
+(defcallback c-interface-init :void ((iface :pointer) (data :pointer))
+ (interface-init iface data))
+
+(defun add-interface (name interface)
+ (let* ((interface-info (list name interface))
+ (interface-info-ptr (allocate-stable-pointer interface-info)))
+ (with-foreign-object (info 'g-interface-info)
+ (setf (foreign-slot-value info 'g-interface-info :interface-init) (callback c-interface-init)
+ (foreign-slot-value info 'g-interface-info :interface-data) interface-info-ptr)
+ (g-type-add-interface-static (g-type-from-name name) (ensure-g-type interface) info))))
+
+(defun add-interfaces (name)
+ (let* ((lisp-type-info (gethash name *registered-types*))
+ (interfaces (object-type-interfaces lisp-type-info)))
+ (iter (for interface in interfaces)
+ (add-interface name interface))))
+
+(defun class-init (class data)
+ (declare (ignore data))
+ (log-for :subclass "class-init for ~A~%" (g-type-name (g-type-from-class class)))
+ (setf (foreign-slot-value class 'g-object-class :get-property)
+ (callback c-object-property-get)
+ (foreign-slot-value class 'g-object-class :set-property)
+ (callback c-object-property-set))
+
+ (install-properties class))