[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-20-g46d80ca

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=46d80cae0876b63b460b2997c7e3bfab94461166

The branch, stable-2.0 has been updated
       via  46d80cae0876b63b460b2997c7e3bfab94461166 (commit)
       via  449c4d44d0dd82749ca1eb8cfeb2ba025caf6eaa (commit)
      from  4b4b1e0b7044d47adcfabf28d57a31b2126e54ee (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 46d80cae0876b63b460b2997c7e3bfab94461166
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 16 23:53:58 2011 +0100

    FFI: Hold a weak reference to the CIF made by `procedure->pointer'.
    
    * libguile/foreign.c (scm_procedure_to_pointer): Keep a weak reference
      to CIF so that it is not reclaimed before POINTER.  Before that it
      could be reclaimed and typically reused to store the CIF of another
      procedure with the same arity, leading to obscure wrong-type-arg
      errors.

commit 449c4d44d0dd82749ca1eb8cfeb2ba025caf6eaa
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 16 23:51:34 2011 +0100

    FFI: Add a `procedure->pointer' test.
    
    * test-suite/tests/foreign.test ("procedure->pointer")["procedures
      returning a pointer"]: New test.

-----------------------------------------------------------------------

Summary of changes:
 libguile/foreign.c            |   14 +++++++++++---
 test-suite/tests/foreign.test |   10 ++++++++++
 2 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/libguile/foreign.c b/libguile/foreign.c
index 68e0efa..021c183 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -1127,7 +1127,7 @@ SCM_DEFINE (scm_procedure_to_pointer, 
"procedure->pointer", 3, 0, 0,
            "type should match @var{return-type} and @var{arg-types}.\n")
 #define FUNC_NAME s_scm_procedure_to_pointer
 {
-  SCM pointer;
+  SCM cif_pointer, pointer;
   ffi_cif *cif;
   ffi_status err;
   void *closure, *executable;
@@ -1144,8 +1144,16 @@ SCM_DEFINE (scm_procedure_to_pointer, 
"procedure->pointer", 3, 0, 0,
       SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL);
     }
 
+  /* CIF points to GC-managed memory and it should remain as long as
+     POINTER (see below) is live.  Wrap it in a Scheme pointer to then
+     hold a weak reference on it.  */
+  cif_pointer = scm_from_pointer (cif, NULL);
+
   if (closure == executable)
-    pointer = scm_from_pointer (executable, ffi_closure_free);
+    {
+      pointer = scm_from_pointer (executable, ffi_closure_free);
+      register_weak_reference (pointer, cif_pointer);
+    }
   else
     {
       /* CLOSURE needs to be freed eventually.  However, since
@@ -1158,7 +1166,7 @@ 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, friend);
+      register_weak_reference (pointer, scm_list_2 (cif_pointer, friend));
     }
 
   return pointer;
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 5ddd31c..5657977 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -254,6 +254,16 @@
                   (map proc* arg1 arg2 arg3)))
         (throw 'unresolved)))
 
+  (pass-if "procedures returning a pointer"
+    (if (defined? 'procedure->pointer)
+        (let* ((called? #f)
+               (proc    (lambda (i) (set! called? #t) (make-pointer i)))
+               (pointer (procedure->pointer '* proc (list int)))
+               (proc*   (pointer->procedure '* pointer (list int)))
+               (result  (proc* 777)))
+          (and called? (equal? result (make-pointer 777))))
+        (throw 'unresolved)))
+
   (pass-if "procedures returning void"
     (if (defined? 'procedure->pointer)
         (let* ((called? #f)


hooks/post-receive
-- 
GNU Guile