glib/gobject.foreign-closures.lisp

   1 (in-package :gobject)
   2
   3 (defcstruct lisp-closure
   4   (parent-instance g-closure)
   5   (function-id :pointer))
   6
   7 (defcallback lisp-closure-finalize :void ((data :pointer)
   8                                           (closure (:pointer lisp-closure)))
   9   (declare (ignore data))
  10   (finalize-lisp-closure closure))
  11
  12 (defun call-with-restarts (fn args)
  13   (restart-case
  14       (apply fn args)
  15     (return-from-g-closure (&optional v) :report "Return value from closure" v)))
  16
  17 (defcallback lisp-closure-marshal :void ((closure (:pointer lisp-closure))
  18                                          (return-value (:pointer g-value))
  19                                          (count-of-args :uint)
  20                                          (args (:pointer g-value))
  21                                          (invocation-hint :pointer)
  22                                          (marshal-data :pointer))
  23   (declare (ignore invocation-hint marshal-data))
  24   (let* ((args (parse-closure-arguments count-of-args args))
  25          (function-id (foreign-slot-value closure 'lisp-closure 'function-id))
  26          (return-type (and (not (null-pointer-p return-value))
  27                            (gvalue-type return-value)))
  28          (fn (get-stable-pointer-value function-id))
  29          (fn-result (call-with-restarts fn args)))
  30     (when return-type
  31       (set-g-value return-value fn-result return-type :g-value-init nil))))
  32
  33 (defun parse-closure-arguments (count-of-args args)
  34   (loop
  35      for i from 0 below count-of-args
  36      collect (parse-gvalue (mem-aref args 'g-value i))))
  37
  38 (defun create-closure (fn)
  39   (let ((function-id (allocate-stable-pointer fn))
  40         (closure (g-closure-new-simple (foreign-type-size 'lisp-closure)
  41                                        (null-pointer))))
  42     (setf (foreign-slot-value closure 'lisp-closure 'function-id) function-id)
  43     (g-closure-add-finalize-notifier closure (null-pointer)
  44                                      (callback lisp-closure-finalize))
  45     (g-closure-set-marshal closure (callback lisp-closure-marshal))
  46     closure))
  47
  48 (defun g-signal-connect (object signal handler &key after)
  49   "Deprecated alias for @fun{connect-signal}"
  50   (connect-signal object signal handler :after after))
  51
  52 (defun connect-signal (object signal handler &key after)
  53   "Connects the function to a signal for a particular object.
  54 If @code{after} is true, then the function will be called after the default handler of the signal.
  55
  56 @arg[object]{an instance of @class{gobject}}
  57 @arg[signal]{a string; names the signal}
  58 @arg[handler]{a function; handles the signal. Number (and type) of arguments and return value type depends on the signal}
  59 @arg[after]{a boolean}"
  60   (g-signal-connect-closure (ensure-object-pointer object)
  61                             signal
  62                             (create-closure handler)
  63                             after))
  64
  65 (defun finalize-lisp-closure (closure)
  66   (let ((function-id (foreign-slot-value closure 'lisp-closure 'function-id)))
  67     (free-stable-pointer function-id)))