3 (defcstruct lisp-closure
4 (parent-instance g-closure)
5 (function-id :pointer))
7 (defcallback lisp-closure-finalize :void ((data :pointer)
8 (closure (:pointer lisp-closure)))
9 (declare (ignore data))
10 (finalize-lisp-closure closure))
12 (defun call-with-restarts (fn args)
15 (return-from-g-closure (&optional v) :report "Return value from closure" v)))
17 (defcallback lisp-closure-marshal :void ((closure (:pointer lisp-closure))
18 (return-value (:pointer g-value))
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)))
31 (set-g-value return-value fn-result return-type :g-value-init nil))))
33 (defun parse-closure-arguments (count-of-args args)
35 for i from 0 below count-of-args
36 collect (parse-gvalue (mem-aref args 'g-value i))))
38 (defun create-closure (fn)
39 (let ((function-id (allocate-stable-pointer fn))
40 (closure (g-closure-new-simple (foreign-type-size 'lisp-closure)
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))
48 (defun g-signal-connect (object signal handler &key after)
49 (g-signal-connect-closure (ensure-object-pointer object)
51 (create-closure handler)
54 (defun finalize-lisp-closure (closure)
55 (let ((function-id (foreign-slot-value closure 'lisp-closure 'function-id)))
56 (free-stable-pointer function-id)))