Add define-cb-methods and create-fn-ref (Object-bound closures)

diff --git a/doc/gobject.ref.texi b/doc/gobject.ref.texi
index 6df156d..73eb95e 100644 (file)
--- a/doc/gobject.ref.texi
+++ b/doc/gobject.ref.texi
@@ -1074,11 +1074,18 @@ Example:
 
 @node Closures
 @chapter Closures
 
 @node Closures
 @chapter Closures

+@menu
+* create-signal-handler-closure::
+* Object-bound foreign functions::
+@end menu

 
 Closure are anonymous functions that capture their lexical environment.
 
 GObject supports using closures (as instances of type GClosure) as signal handlers and in some other places where a function is expected. Function @code{create-signal-handler-closure} create closure from lisp function that can be used a signal handler. The GClosure is finalized automatically when GObject no longer needs it (e.g., when GClosure is disconnected from signal).
 
 
 Closure are anonymous functions that capture their lexical environment.
 
 GObject supports using closures (as instances of type GClosure) as signal handlers and in some other places where a function is expected. Function @code{create-signal-handler-closure} create closure from lisp function that can be used a signal handler. The GClosure is finalized automatically when GObject no longer needs it (e.g., when GClosure is disconnected from signal).
 

+(TODO: GObject defines finer closure API: g_closure_ref, g_closure_unref, g_closure_invoke. It should be bound.)
+
+@node create-signal-handler-closure

 @section create-signal-handler-closure
 @Function create-signal-handler-closure
 @lisp
 @section create-signal-handler-closure
 @Function create-signal-handler-closure
 @lisp

@@ -1112,7 +1119,45 @@ Example of usage from GObject binding code:
                             after))
 @end lisp
 
                             after))
 @end lisp
 

-(TODO: GObject defines finer closure API: g_closure_ref, g_closure_unref, g_closure_invoke. It should be bound.)
+@node Object-bound foreign functions
+@section Object-bound foreign functions
+
+A common idiom for Gtk+ for passing user-defined function is as follows. Callback function has (besides its 'useful' arguments) an additional argument at the end - the 'data' pointer. This 'data' pointer, along with the pointer to 'destroy-notify' function is specified when passing the function. Destroy-notify function allows to free the function object (the Lisp closure) when it is not used by an object.
+
+@RMacro define-cb-methods
+@lisp
+(define-cb-methods name return-type ((arg-1 type-1) ... (arg-n type-n)))
+@end lisp
+
+Defines two CFFI callbacks assosiated with the callback function type @var{name}. Creates @var{name}-cb - a callback to be passed as an function and create @var{name}-destroy-notify - a callback to be passed as 'destroy-notify' function. These callbacks are intended to work together with @ref{create-fn-ref}.
+
+Arguments and return-type are the same as CFFI arguments and return-type for callbacks. Arguments do not include the last 'data' pointer.
+
+@RFunction create-fn-ref
+@lisp
+(create-fn-ref object function) @result{} foreign-pointer
+@end lisp
+
+This function creates a foreign structure containing the data neccesary for callbacks defined by @ref{define-cb-methods} to call and dispose of the @var{function}. The @var{function} is bound to the @var{object}. This is neccesary for correct work of garbage collector. The created structure is freed by 'destroy-notify' function.
+
+Example:
+@lisp
+(defcfun gtk-assistant-set-forward-page-func :void
+  (assistant (g-object assistant))
+  (page-func :pointer)
+  (data :pointer)
+  (destroy-notify :pointer))
+
+(define-cb-methods assistant-page-func :int ((current-page :int)))
+
+(defun set-assistant-forward-page-function (assistant function)
+  (if function
+      (gtk-assistant-set-forward-page-func assistant
+                                           (callback assistant-page-func-cb)
+                                           (create-fn-ref assistant function)
+                                           (callback assistant-page-func-destroy-notify))
+      (gtk-assistant-set-forward-page-func assistant (null-pointer) (null-pointer) (null-pointer))))
+@end lisp

 
 @node GObject low-level
 @chapter GObject low-level
 
 @node GObject low-level
 @chapter GObject low-level

diff --git a/doc/gobject.texi b/doc/gobject.texi
index 4ae0c56..2a00eca 100644 (file)
--- a/doc/gobject.texi
+++ b/doc/gobject.texi
@@ -21,6 +21,11 @@
 @end defmac
 @end macro
 
 @end defmac
 @end macro
 

+@macro RMacro {args}
+@anchor{\args\}@defmac \args\
+@end defmac
+@end macro
+

 @macro Struct {args}
 @deftp {Structure} \args\
 @end deftp
 @macro Struct {args}
 @deftp {Structure} \args\
 @end deftp

diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd
index 88a1241..0007491 100644 (file)
--- a/glib/cl-gtk2-glib.asd
+++ b/glib/cl-gtk2-glib.asd
@@ -33,6 +33,7 @@
                (:file "gobject.object-defs")
                (:file "gobject.cffi-callbacks")
                (:file "gobject.foreign-gobject-subclassing")
                (:file "gobject.object-defs")
                (:file "gobject.cffi-callbacks")
                (:file "gobject.foreign-gobject-subclassing")

-
-               (:file "gobject.boxed"))
+               
+               (:file "gobject.boxed")
+               (:file "gobject.object-function"))

   :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop))
\ No newline at end of file
   :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop))
\ No newline at end of file

diff --git a/glib/gobject.object-function.lisp b/glib/gobject.object-function.lisp
new file mode 100644 (file)
index 0000000..7c17faf
--- /dev/null
+++ b/glib/gobject.object-function.lisp
@@ -0,0 +1,35 @@
+(in-package :gobject)
+
+(defcstruct object-func-ref
+  (:object :pointer)
+  (:fn-id :int))
+
+(defmacro define-cb-methods (name return-type (&rest args))
+  (flet ((make-name (control-string) (intern (format nil control-string (symbol-name name)) (symbol-package name))))
+    (let ((call-cb (make-name "~A-CB"))
+          (destroy-cb (make-name "~A-DESTROY-NOTIFY"))
+          (object (gensym "OBJECT"))
+          (fn-id (gensym "FN-ID"))
+          (fn (gensym "FN"))
+          (data (gensym "DATA"))
+          (arg-names (mapcar #'first args)))
+      `(progn
+         (defcallback ,call-cb ,return-type (,@args (,data :pointer))
+           (let* ((,object (convert-from-foreign (foreign-slot-value ,data 'object-func-ref :object) 'g-object))
+                  (,fn-id (foreign-slot-value ,data 'object-func-ref :fn-id))
+                  (,fn (retrieve-handler-from-object ,object ,fn-id)))
+             (funcall ,fn ,@arg-names)))
+         (defcallback ,destroy-cb :void ((,data :pointer))
+           (let* ((,object (convert-from-foreign (foreign-slot-value ,data 'object-func-ref :object) 'g-object))
+                  (,fn-id (foreign-slot-value ,data 'object-func-ref :fn-id)))
+             (delete-handler-from-object ,object ,fn-id))
+           (foreign-free ,data))))))
+
+(defun create-fn-ref (object function)
+  (let ((ref (foreign-alloc 'object-func-ref))
+        (fn-id (save-handler-to-object object function)))
+    (setf (foreign-slot-value ref 'object-func-ref :object)
+          (pointer object)
+          (foreign-slot-value ref 'object-func-ref :fn-id)
+          fn-id)
+    ref))

diff --git a/glib/gobject.package.lisp b/glib/gobject.package.lisp
index 92401a5..cad6804 100644 (file)
--- a/glib/gobject.package.lisp
+++ b/glib/gobject.package.lisp
@@ -191,7 +191,9 @@
            #:save-handler-to-object
            #:retrieve-handler-from-object
            #:delete-handler-from-object
            #:save-handler-to-object
            #:retrieve-handler-from-object
            #:delete-handler-from-object

-           #:disconnect-signal)
+           #:disconnect-signal
+           #:define-cb-methods
+           #:create-fn-ref)

   (:documentation
    "CL-GTK2-GOBJECT is a binding to GObject type system.
 For information on GObject, see its @a[http://library.gnome.org/devel/gobject/stable/]{documentation}.
   (:documentation
    "CL-GTK2-GOBJECT is a binding to GObject type system.
 For information on GObject, see its @a[http://library.gnome.org/devel/gobject/stable/]{documentation}.