diff options
-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 |