From fb0b64c12a40529a03c22481570a11457076b7f9 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 4 Sep 2010 14:38:20 +0200 Subject: [PATCH] Add an entertaining `procedure->pointer' test. * test-suite/tests/foreign.test ("procedure->pointer")["bijection"]: New test. --- test-suite/tests/foreign.test | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) 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)))) -- 2.20.1