summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-09-04 14:38:20 +0200
committerLudovic Courtès <ludo@gnu.org>2010-09-04 14:39:48 +0200
commitfb0b64c12a40529a03c22481570a11457076b7f9 (patch)
treead5a041524556691f3caed8d101134dce7ad1dcf
parentbf08e10f59c062a5d5173ed7951874ed86d302aa (diff)
downloadguile-fb0b64c12a40529a03c22481570a11457076b7f9.tar.gz
Add an entertaining `procedure->pointer' test.
* test-suite/tests/foreign.test ("procedure->pointer")["bijection"]: New test.
-rw-r--r--test-suite/tests/foreign.test18
1 files changed, 18 insertions, 0 deletions
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index fd4267761..a791602e5 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -24,6 +24,7 @@
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (test-suite lib))
@@ -144,6 +145,23 @@
(qsort (bytevector->pointer bv) (bytevector-length bv) 1
(procedure->pointer int cmp (list '* '*)))
#f)
+ (throw 'unresolved)))
+
+ (pass-if "bijection"
+ (if (defined? 'procedure->pointer)
+ (let* ((proc (lambda (x y z)
+ (+ x y z 0.0)))
+ (ret double)
+ (args (list float int16 double))
+ (proc* (make-foreign-function
+ ret
+ (procedure->pointer ret proc args)
+ args))
+ (arg1 (map (cut / <> 2.0) (iota 123)))
+ (arg2 (iota 123 32000))
+ (arg3 (map (cut / <> 4.0) (iota 123 100 4))))
+ (equal? (map proc arg1 arg2 arg3)
+ (map proc* arg1 arg2 arg3)))
(throw 'unresolved))))