@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}
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)
(: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
(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))
(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))
(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)
(: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
projects / cl-gtk2.git / commitdiff