diff options
author | Ludovic Courtès <ludo@gnu.org> | 2011-11-26 22:27:32 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2011-11-26 22:27:32 +0100 |
commit | 59a0273338ca52dd920eef90439f95d313214a6b (patch) | |
tree | 34052f3557ed5a7f523b68b275b695f7418468b6 | |
parent | 4855c63441c5f11a58b8157c877e5890a7b0ffe1 (diff) | |
download | guile-59a0273338ca52dd920eef90439f95d313214a6b.tar.gz |
FFI: Hold a weak reference to the procedure passed to `procedure->pointer'.
* libguile/foreign.c (scm_procedure_to_pointer): Keep a weak reference
to PROC.
* test-suite/tests/foreign.test ("procedure->pointer")["procedure is
retained"]: New test.
-rw-r--r-- | libguile/foreign.c | 6 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 16 |
2 files changed, 20 insertions, 2 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index 021c183cf..f3af157b3 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -1152,7 +1152,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0, if (closure == executable) { pointer = scm_from_pointer (executable, ffi_closure_free); - register_weak_reference (pointer, cif_pointer); + register_weak_reference (pointer, + scm_list_2 (proc, cif_pointer)); } else { @@ -1166,7 +1167,8 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0, pointer = scm_from_pointer (executable, NULL); friend = scm_from_pointer (closure, ffi_closure_free); - register_weak_reference (pointer, scm_list_2 (cif_pointer, friend)); + register_weak_reference (pointer, + scm_list_3 (proc, cif_pointer, friend)); } return pointer; diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 5657977d7..2c326c98e 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -272,6 +272,22 @@ (proc* (pointer->procedure void pointer '()))) (proc*) called?) + (throw 'unresolved))) + + (pass-if "procedure is retained" + ;; The lambda passed to `procedure->pointer' must remain live. + (if (defined? 'procedure->pointer) + (let* ((ptr (procedure->pointer int + (lambda (x) (+ x 7)) + (list int))) + (procs (unfold (cut >= <> 10000) + (lambda (i) + (pointer->procedure int ptr (list int))) + 1+ + 0))) + (gc) (gc) (gc) + (every (cut = <> 9) + (map (lambda (f) (f 2)) procs))) (throw 'unresolved)))) |