diff options
author | Ludovic Courtès <ludo@gnu.org> | 2011-02-09 00:08:14 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2011-02-09 00:08:14 +0100 |
commit | 9970cf67080b48ec35680c70146500428b47bf3e (patch) | |
tree | f8e6b3ebb87626783d46bd6d3a6387772796a027 | |
parent | 6090483143d53a136e46186887edb3961b825682 (diff) | |
download | guile-9970cf67080b48ec35680c70146500428b47bf3e.tar.gz |
Improve type checking when invoking foreign functions.
* 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.
-rw-r--r-- | libguile/foreign.c | 4 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 8 |
2 files changed, 12 insertions, 0 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index 52da23f6e..c546c799a 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -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 diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index ba53a0d06..3569c8a52 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -137,6 +137,14 @@ (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" (define qsort |