From 9970cf67080b48ec35680c70146500428b47bf3e Mon Sep 17 00:00:00 2001
From: =?utf8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 9 Feb 2011 00:08:14 +0100
Subject: [PATCH] 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.
---
 libguile/foreign.c            | 4 ++++
 test-suite/tests/foreign.test | 8 ++++++++
 2 files changed, 12 insertions(+)

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
-- 
2.20.1