(define-vtable (g-type-name type-name)
&body item*)
-item ::= (method-name return-type &rest arg*)
item ::= (:skip cffi-structure-item)
+item ::= (method-name (return-type &rest arg*) &key impl-call)
arg ::= (arg-name arg-type)
+impl-call ::= ((arg-name*) &body call-code)
@end lisp
@table @var
@item @var{g-type-name}
A string naming the GObject type of interface
+@item @var{cffi-structure-item}
+A structure item that is inserted verbatim into foreign structure definition of vtable and is not used as a pointer to method
@item @var{method-name}
A name for implementation generic function
@item @var{return-type}
A symbol naming the argument of interface method
@item @var{arg-type}
A CFFI specifier for foreign function argument type
+@item @var{call-code}
+A body of code that is used to convert arguments and return values between interface signature and desired implementor generic function signature
@end table
-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.
+Macro that specifies the vtable for an interface. Vtable for an interface is a structure that contains pointer to implementations of interface methods. Vtable is used to dispach method calls to corresponding method implementations. In cl-gtk2-gobject, vtables are needed to create classes that implement GObject interfaces.
+
+GObject interfaces are implemented in the following way. For every method, an implementor generic function is defined. This generic function is called by interface method callback, and CLOS classes specialize on this generic function to implement an interface. The generic function has the same signature as the interface's function, but signatures may differ.
+
+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.
+
+In some cases, the signature of interface method is not very lispy: it may pass @code{void*} pointers, pointers to places where return values should be stored. To conceal such unlispy things, you specify your own code that will call the generic function and translate arguments for implementor generic function. This is implemented by specifying @var{impl-call} method option. @var{impl-call} specifies the signature of implementor function and code that calls the generic function and returns its result. The code is put in return position of callback, and it has access to the arguments of callback and its return value becomes the return value of callback.
Example:
@lisp
(:skip tree-model-row-deleted :pointer)
(:skip tree-model-rows-reordered :pointer)
;;methods
- (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))))
+ (get-flags (tree-model-flags (tree-model g-object)))
+ (get-value (:void
+ (tree-model g-object)
+ (iter (g-boxed-foreign tree-iter))
+ (n :int)
+ (value (:pointer g-value)))
+ :impl-call
+ ((tree-model iter n)
+ (multiple-value-bind (v type) (tree-model-get-value-impl tree-model iter n)
+ (set-g-value value v type)))))
(defmethod tree-model-get-flags-impl ((model array-list-store))
'(:list-only))
+
+(defmethod tree-model-get-value-impl ((model array-list-store) iter n)
+ (let ((n-row (tree-iter-user-data iter)))
+ (values (funcall (aref (store-getters model) n)
+ (aref (store-items model) n-row))
+ (aref (store-types model) n))))
@end lisp
@node register-object-type-implementation
(rest item)
(list (first item) :pointer)))
-(defstruct vtable-method-info slot-name name return-type args callback-name)
+(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))
(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) item
+ (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)))))
+ :callback-name callback-name
+ :impl-call impl-call)))))
(defvar *vtables* (make-hash-table :test 'equal))
: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)))))
+ (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
- (,(vtable-method-info-name method) ,@(mapcar #'first (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))))))))
(:skip tree-model-row-deleted :pointer)
(:skip tree-model-rows-reordered :pointer)
;;methods
- (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))))
+ (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)))
+ :impl-call
+ ((tree-model iter n)
+ (multiple-value-bind (v type) (tree-model-get-value-impl tree-model iter n)
+ (set-g-value value v type))))
+ (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)))))
(define-vtable ("GtkTreeSortable" tree-sortable)
(:skip parent-instance g-type-interface)
;; signal
(:skip sort-columns-changed :pointer)
;; methods
- (get-sort-column-id :boolean (sortable (g-object tree-sortable)) (sort-column-id (:pointer :int)) (order (:pointer sort-type)))
- (set-sort-column-id :void (sortable (g-object tree-sortable)) (sort-column-id :int) (order sort-type))
- (set-sort-func :void (sortable (g-object tree-sortable)) (sort-column-id :int) (func :pointer) (data :pointer) (destroy-notify :pointer))
- (set-default-sort-func :void (sortable (g-object tree-sortable)) (func :pointer) (data :pointer) (destroy-notify :pointer))
- (has-default-sort-func :boolean (sortable (g-object tree-sortable))))
-
-; TODO: GtkTreeSortable
+ (get-sort-column-id
+ (:boolean (sortable (g-object tree-sortable))
+ (sort-column-id (:pointer :int))
+ (order (:pointer sort-type)))
+ :impl-call ((sortable)
+ (multiple-value-bind (sorted-p r-sort-column-id r-order) (tree-sortable-get-sort-column-id-impl sortable)
+ (unless (null-pointer-p sort-column-id)
+ (setf (mem-ref sort-column-id :int) r-sort-column-id))
+ (unless (null-pointer-p order)
+ (setf (mem-ref order 'sort-type) r-order))
+ sorted-p)))
+ (set-sort-column-id (:void (sortable (g-object tree-sortable)) (sort-column-id :int) (order sort-type)))
+ (set-sort-func (:void (sortable (g-object tree-sortable)) (sort-column-id :int) (func :pointer) (data :pointer) (destroy-notify :pointer)))
+ (set-default-sort-func (:void (sortable (g-object tree-sortable)) (func :pointer) (data :pointer) (destroy-notify :pointer)))
+ (has-default-sort-func (:boolean (sortable (g-object tree-sortable)))))
; TODO: GtkTreeModelSort
; TODO: GtkTreeModelFilter
-
(defclass array-list-store (tree-model)
((items :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-items)
(columns-getters :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-getters)
(export 'tree-model-item)
-(defmethod tree-model-get-value-impl ((model array-list-store) iter n value)
+(defmethod tree-model-get-value-impl ((model array-list-store) iter n)
(let ((n-row (tree-iter-user-data iter)))
- (set-g-value value
- (funcall (aref (store-getters model) n)
- (aref (store-items model) n-row))
- (aref (store-types model) n))))
+ (values (funcall (aref (store-getters model) n)
+ (aref (store-items model) n-row))
+ (aref (store-types model) n))))
(defcfun (tree-model-flags "gtk_tree_model_get_flags") tree-model-flags
(tree-model g-object))
(setf (tree-path-indices path) indices)
path))
-(defmethod tree-model-get-value-impl ((store tree-lisp-store) iter n value)
+(defmethod tree-model-get-value-impl ((store tree-lisp-store) iter n)
(let* ((node (get-node-by-iter store iter))
(getter (aref (tree-lisp-store-getters store) n))
(type (aref (tree-lisp-store-types store) n)))
- (set-g-value value (funcall getter (tree-node-item node)) type)))
+ (values (funcall getter (tree-node-item node))
+ type)))
(defmethod tree-model-iter-next-impl ((store tree-lisp-store) iter)
(let* ((node (get-node-by-iter store iter))
projects / cl-gtk2.git / commitdiff