mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-01 23:30:28 +02:00
Code Activity

Improve type checking when invoking foreign functions.

Browse source 
* libguile/foreign.c (unpack): Make sure X is a pointer before using
  `SCM_POINTER_VALUE'.

* test-suite/tests/foreign.test ("pointer->procedure"): New test prefix.
This commit is contained in:
Ludovic Courtès 2011-02-09 00:08:14 +01:00
parent 6090483143
commit 9970cf6708
2 changed files with 12 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/foreign.c
View file

@ -814,6 +814,7 @@ cif_to_procedure (SCM cif, SCM func_ptr)
/* Set *LOC to the foreign representation of X with TYPE. */ /* Set *LOC to the foreign representation of X with TYPE. */
static void static void
unpack (const ffi_type *type, void *loc, SCM x) unpack (const ffi_type *type, void *loc, SCM x)
#define FUNC_NAME "scm_i_foreign_call"
{ {
switch (type->type) switch (type->type)
{ {
@ -848,15 +849,18 @@ unpack (const ffi_type *type, void *loc, SCM x)
*(scm_t_int64 *) loc = scm_to_int64 (x); *(scm_t_int64 *) loc = scm_to_int64 (x);
break; break;
case FFI_TYPE_STRUCT: case FFI_TYPE_STRUCT:
SCM_VALIDATE_POINTER (1, x);
memcpy (loc, SCM_POINTER_VALUE (x), type->size); memcpy (loc, SCM_POINTER_VALUE (x), type->size);
break; break;
case FFI_TYPE_POINTER: case FFI_TYPE_POINTER:
SCM_VALIDATE_POINTER (1, x);
*(void **) loc = SCM_POINTER_VALUE (x); *(void **) loc = SCM_POINTER_VALUE (x);
break; break;
default: default:
abort (); abort ();
} }
} }
#undef FUNC_NAME
/* Return a Scheme representation of the foreign value at LOC of type TYPE. */ /* Return a Scheme representation of the foreign value at LOC of type TYPE. */
static SCM static SCM

8
test-suite/tests/foreign.test
View file

@ -136,6 +136,14 @@
(let ((s "Szép jó napot!")) (let ((s "Szép jó napot!"))
(string=? s (pointer->string (string->pointer s))))))) (string=? s (pointer->string (string->pointer s)))))))
(with-test-prefix "pointer->procedure"
(pass-if-exception "object instead of pointer"
exception:wrong-type-arg
(let ((p (pointer->procedure '* %null-pointer '(*))))
(p #t))))
(with-test-prefix "procedure->pointer" (with-test-prefix "procedure->pointer"