glib/gobject.closure.lisp

   1 (in-package :gobject)
   2
   3 (defcstruct lisp-closure
   4   (:parent-instance g-closure)
   5   (:function-id :pointer))
   6
   7 (defun finalize-lisp-closure (closure)
   8   (let ((function-id (foreign-slot-value closure 'lisp-closure :function-id)))
   9     (free-stable-pointer function-id)))
  10
  11 (defcallback lisp-closure-finalize :void ((data :pointer)
  12                                           (closure (:pointer lisp-closure)))
  13   (declare (ignore data))
  14   (finalize-lisp-closure closure))
  15
  16 (defun call-with-restarts (fn args)
  17   (restart-case
  18       (apply fn args)
  19     (return-from-g-closure (&optional v) :report "Return value from closure" v)))
  20
  21 (defcallback lisp-closure-marshal :void ((closure (:pointer lisp-closure))
  22                                          (return-value (:pointer g-value))
  23                                          (count-of-args :uint)
  24                                          (args (:pointer g-value))
  25                                          (invocation-hint :pointer)
  26                                          (marshal-data :pointer))
  27   (declare (ignore invocation-hint marshal-data))
  28   (let* ((args (parse-closure-arguments count-of-args args))
  29          (function-id (foreign-slot-value closure 'lisp-closure :function-id))
  30          (return-type (and (not (null-pointer-p return-value))
  31                            (g-value-type return-value)))
  32          (fn (get-stable-pointer-value function-id))
  33          (fn-result (call-with-restarts fn args)))
  34     (when return-type
  35       (set-g-value return-value fn-result return-type :g-value-init nil))))
  36
  37 (defun parse-closure-arguments (count-of-args args)
  38   (loop
  39      for i from 0 below count-of-args
  40      collect (parse-g-value (mem-aref args 'g-value i))))
  41
  42 (defun create-g-closure (fn)
  43   (let ((function-id (allocate-stable-pointer fn))
  44         (closure (g-closure-new-simple (foreign-type-size 'lisp-closure) (null-pointer))))
  45     (setf (foreign-slot-value closure 'lisp-closure :function-id) function-id)
  46     (g-closure-add-finalize-notifier closure (null-pointer)
  47                                      (callback lisp-closure-finalize))
  48     (g-closure-set-marshal closure (callback lisp-closure-marshal))
  49     closure))