diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-09-04 14:38:20 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-09-04 14:39:48 +0200 |
commit | fb0b64c12a40529a03c22481570a11457076b7f9 (patch) | |
tree | ad5a041524556691f3caed8d101134dce7ad1dcf | |
parent | bf08e10f59c062a5d5173ed7951874ed86d302aa (diff) | |
download | guile-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.test | 18 |
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)))) |