3 (defcstruct lisp-closure
4 (:parent-instance g-closure)
5 (:function-id :pointer))
7 (defun finalize-lisp-closure (closure)
8 (let ((function-id (foreign-slot-value closure 'lisp-closure :function-id)))
9 (free-stable-pointer function-id)))
11 (defcallback lisp-closure-finalize :void ((data :pointer)
12 (closure (:pointer lisp-closure)))
13 (declare (ignore data))
14 (finalize-lisp-closure closure))
16 (defun call-with-restarts (fn args)
19 (return-from-g-closure (&optional v) :report "Return value from closure" v)))
21 (defcallback lisp-closure-marshal :void ((closure (:pointer lisp-closure))
22 (return-value (:pointer g-value))
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)))
35 (set-g-value return-value fn-result return-type :g-value-init nil))))
37 (defun parse-closure-arguments (count-of-args args)
39 for i from 0 below count-of-args
40 collect (parse-g-value (mem-aref args 'g-value i))))
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))