mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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. */
static void
unpack (const ffi_type *type, void *loc, SCM x)
#define FUNC_NAME "scm_i_foreign_call"
{
switch (type->type)
{
@ -848,15 +849,18 @@ unpack (const ffi_type *type, void *loc, SCM x)
*(scm_t_int64 *) loc = scm_to_int64 (x);
break;
case FFI_TYPE_STRUCT:
SCM_VALIDATE_POINTER (1, x);
memcpy (loc, SCM_POINTER_VALUE (x), type->size);
break;
case FFI_TYPE_POINTER:
SCM_VALIDATE_POINTER (1, x);
*(void **) loc = SCM_POINTER_VALUE (x);
break;
default:
abort ();
}
}
#undef FUNC_NAME
/* Return a Scheme representation of the foreign value at LOC of type TYPE. */
static SCM

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

@ -136,6 +136,14 @@
(let ((s "Szép jó napot!"))
(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"