From: Dmitry Kalyanov Date: Wed, 14 Oct 2009 19:43:40 +0000 (+0400) Subject: Refactoring of gobject:define-vtable X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=02c0f62d617212f4e51224a2f7e76074dac1378e;p=cl-gtk2.git Refactoring of gobject:define-vtable --- diff --git a/doc/gobject.ref.texi b/doc/gobject.ref.texi index 43daa9e..703d505 100644 --- a/doc/gobject.ref.texi +++ b/doc/gobject.ref.texi @@ -1674,23 +1674,19 @@ Unfortunately, GObject does not provide information about vtables, and does not @Macro define-vtable @lisp -(define-vtable (type-name cstruct-name) +(define-vtable (g-type-name type-name) &body item*) -item ::= (name callback-name return-type &rest arg*) +item ::= (method-name return-type &rest arg*) item ::= (:skip cffi-structure-item) arg ::= (arg-name arg-type) @end lisp @table @var -@item @var{type-name} +@item @var{g-type-name} A string naming the GObject type of interface -@item @var{cstruct-name} -A name for a generated CFFI foreign structure -@item @var{name} +@item @var{method-name} A name for implementation generic function -@item @var{callback-name} -A name for generated callback function @item @var{return-type} A CFFI specifier for foreign function return type @item @var{arg-name} @@ -1699,11 +1695,11 @@ A symbol naming the argument of interface method A CFFI specifier for foreign function argument type @end table -Macro that specifies the vtable for an interface. This macro defines generic functions (named by @code{name}) that correspond to methods of an interface. On these generic functions methods should be defined that implement the interface method. @code{item}s specify the CFFI foreign structure for vtable. Vtable contains not only function pointers, but other slots. Such slots should be specified here with @code{:skip} prepended to them. This is needed to be able to correctly calculate offsets to function pointers in vtable. +Macro that specifies the vtable for an interface. This macro defines generic functions (named by concatenatinag @var{type-name}, @var{name} and @code{impl}; e.g., @code{get-flags} method of class @code{tree-model} will have generic function named @code{tree-model-get-flags-impl}) that correspond to methods of an interface. On these generic functions methods should be defined that implement the interface method. @code{item}s specify the CFFI foreign structure for vtable. Vtable contains not only function pointers, but other slots. Such slots should be specified here with @code{:skip} prepended to them. This is needed to be able to correctly calculate offsets to function pointers in vtable. Example: @lisp -(define-vtable ("GtkTreeModel" c-gtk-tree-model) +(define-vtable ("GtkTreeModel" tree-model) (:skip parent-instance g-type-interface) ;;some signals (:skip tree-model-row-changed :pointer) @@ -1712,48 +1708,42 @@ Example: (:skip tree-model-row-deleted :pointer) (:skip tree-model-rows-reordered :pointer) ;;methods - (tree-model-get-flags-impl tree-model-get-flags-cb - tree-model-flags + (get-flags tree-model-flags (tree-model g-object)) - (tree-model-get-n-columns-impl tree-model-get-n-columns-cb - :int + (get-n-columns :int (tree-model g-object)) - (tree-model-get-column-type-impl tree-model-get-column-type-cb - g-type-designator + (get-column-type g-type-designator (tree-model g-object) (index :int)) - (tree-model-get-iter-impl tree-model-get-iter-cb - :boolean - (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (path (g-boxed-foreign tree-path))) - (tree-model-get-path-impl tree-model-get-path-cb - (g-boxed-foreign tree-path :return) + (get-iter :boolean + (tree-model g-object) (iter (g-boxed-foreign tree-iter)) + (path (g-boxed-foreign tree-path))) + (get-path (g-boxed-foreign tree-path :return) (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-get-value-impl tree-model-get-value-cb - :void - (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (n :int) (value (:pointer g-value))) - (tree-model-iter-next-impl tree-model-iter-next-cb - :boolean + (get-value :void + (tree-model g-object) (iter (g-boxed-foreign tree-iter)) + (n :int) (value (:pointer g-value))) + (iter-next :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-iter-children-impl tree-model-iter-children-cb - :boolean - (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (parent (g-boxed-foreign tree-iter))) - (tree-model-iter-has-child-impl tree-model-iter-has-child-cb - :boolean + (iter-children :boolean + (tree-model g-object) (iter (g-boxed-foreign tree-iter)) + (parent (g-boxed-foreign tree-iter))) + (iter-has-child :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-iter-n-children-impl tree-model-iter-n-children-cb - :int + (iter-n-children :int (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-iter-nth-child-impl tree-model-iter-nth-child-cb - :boolean - (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (parent (g-boxed-foreign tree-iter)) (n :int)) - (tree-model-iter-parent-impl tree-model-iter-parent-cb - :boolean - (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (child (g-boxed-foreign tree-iter))) - (tree-model-ref-node-impl tree-model-ref-node-cb - :void + (iter-nth-child :boolean + (tree-model g-object) (iter (g-boxed-foreign tree-iter)) + (parent (g-boxed-foreign tree-iter)) (n :int)) + (iter-parent :boolean + (tree-model g-object) (iter (g-boxed-foreign tree-iter)) + (child (g-boxed-foreign tree-iter))) + (ref-node :void (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-unref-node-impl tree-model-unref-node-cb - :void + (unref-node :void (tree-model g-object) (iter (g-boxed-foreign tree-iter)))) + +(defmethod tree-model-get-flags-impl ((model array-list-store)) + '(:list-only)) @end lisp @node register-object-type-implementation diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp index b5f4cd0..9914135 100644 --- a/glib/gobject.foreign-gobject-subclassing.lisp +++ b/glib/gobject.foreign-gobject-subclassing.lisp @@ -78,37 +78,51 @@ (rest item) (list (first item) :pointer))) -(defstruct vtable-method-info name return-type args callback-name) +(defstruct vtable-method-info slot-name name return-type args callback-name) (defmethod make-load-form ((object vtable-method-info) &optional environment) (declare (ignore environment)) - `(make-vtable-method-info :name ',(vtable-method-info-name object) + `(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 (items) +(defun vtable-methods (iface-name items) (iter (for item in items) (when (eq :skip (first item)) (next-iteration)) - (destructuring-bind (name callback-name return-type &rest args) item - (collect (make-vtable-method-info :name name :return-type return-type :args args :callback-name callback-name))))) + (destructuring-bind (name return-type &rest args) 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))))) (defvar *vtables* (make-hash-table :test 'equal)) (defstruct vtable-description type-name cstruct-name methods) -(defmacro define-vtable ((type-name cstruct-name) &body 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 (vtable-methods items))))) - ,@(iter (for method in (vtable-methods items)) - (collect `(defgeneric ,(vtable-method-info-name method) (,@(mapcar #'first (vtable-method-info-args method))))) - (collect `(glib-defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method) - (,@(vtable-method-info-args method)) - (restart-case - (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method))) - (return-from-interface-method-implementation (v) :interactive (lambda () (list (eval (read)))) v))))))) +(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) + (collect `(defgeneric ,(vtable-method-info-name method) + (,@(mapcar #'first (vtable-method-info-args method))))) + (collect `(glib-defcallback ,(vtable-method-info-callback-name method) + ,(vtable-method-info-return-type method) + (,@(vtable-method-info-args method)) + (restart-case + (,(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)) @@ -117,7 +131,10 @@ (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)) - (setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method))))))) + (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)) diff --git a/gtk/gtk.tree-model.lisp b/gtk/gtk.tree-model.lisp index 3f257e3..8b6b6f5 100644 --- a/gtk/gtk.tree-model.lisp +++ b/gtk/gtk.tree-model.lisp @@ -1,6 +1,6 @@ (in-package :gtk) -(define-vtable ("GtkTreeModel" c-gtk-tree-model) +(define-vtable ("GtkTreeModel" tree-model) (:skip parent-instance g-type-interface) ;;some signals (:skip tree-model-row-changed :pointer) @@ -9,20 +9,20 @@ (:skip tree-model-row-deleted :pointer) (:skip tree-model-rows-reordered :pointer) ;;methods - (tree-model-get-flags-impl tree-model-get-flags-cb tree-model-flags (tree-model g-object)) - (tree-model-get-n-columns-impl tree-model-get-n-columns-cb :int (tree-model g-object)) - (tree-model-get-column-type-impl tree-model-get-column-type-cb g-type-designator (tree-model g-object) (index :int)) - (tree-model-get-iter-impl tree-model-get-iter-cb :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (path (g-boxed-foreign tree-path))) - (tree-model-get-path-impl tree-model-get-path-cb (g-boxed-foreign tree-path :return) (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-get-value-impl tree-model-get-value-cb :void (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (n :int) (value (:pointer g-value))) - (tree-model-iter-next-impl tree-model-iter-next-cb :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-iter-children-impl tree-model-iter-children-cb :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (parent (g-boxed-foreign tree-iter))) - (tree-model-iter-has-child-impl tree-model-iter-has-child-cb :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-iter-n-children-impl tree-model-iter-n-children-cb :int (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-iter-nth-child-impl tree-model-iter-nth-child-cb :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (parent (g-boxed-foreign tree-iter)) (n :int)) - (tree-model-iter-parent-impl tree-model-iter-parent-cb :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (child (g-boxed-foreign tree-iter))) - (tree-model-ref-node-impl tree-model-ref-node-cb :void (tree-model g-object) (iter (g-boxed-foreign tree-iter))) - (tree-model-unref-node-impl tree-model-unref-node-cb :void (tree-model g-object) (iter (g-boxed-foreign tree-iter)))) + (get-flags tree-model-flags (tree-model g-object)) + (get-n-columns :int (tree-model g-object)) + (get-column-type g-type-designator (tree-model g-object) (index :int)) + (get-iter :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (path (g-boxed-foreign tree-path))) + (get-path (g-boxed-foreign tree-path :return) (tree-model g-object) (iter (g-boxed-foreign tree-iter))) + (get-value :void (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (n :int) (value (:pointer g-value))) + (iter-next :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter))) + (iter-children :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (parent (g-boxed-foreign tree-iter))) + (iter-has-child :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter))) + (iter-n-children :int (tree-model g-object) (iter (g-boxed-foreign tree-iter))) + (iter-nth-child :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (parent (g-boxed-foreign tree-iter)) (n :int)) + (iter-parent :boolean (tree-model g-object) (iter (g-boxed-foreign tree-iter)) (child (g-boxed-foreign tree-iter))) + (ref-node :void (tree-model g-object) (iter (g-boxed-foreign tree-iter))) + (unref-node :void (tree-model g-object) (iter (g-boxed-foreign tree-iter)))) ; TODO: GtkTreeSortable