glib/gobject.foreign-closures.lisp

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