mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Add an entertaining `procedure->pointer' test.

Browse source 
* test-suite/tests/foreign.test ("procedure->pointer")["bijection"]: New
  test.
This commit is contained in:
Ludovic Courtès 2010-09-04 14:38:20 +02:00
parent bf08e10f59
commit fb0b64c12a
1 changed files with 18 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

18
test-suite/tests/foreign.test
View file

@ -24,6 +24,7 @@
#:use-module (system foreign) #:use-module (system foreign)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (test-suite lib)) #:use-module (test-suite lib))
@ -144,6 +145,23 @@
(qsort (bytevector->pointer bv) (bytevector-length bv) 1 (qsort (bytevector->pointer bv) (bytevector-length bv) 1
(procedure->pointer int cmp (list '* '*))) (procedure->pointer int cmp (list '* '*)))
#f) #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)))) (throw 'unresolved))))