ikarus/lab/test-ffi.ss

108 lines
2.9 KiB
Scheme

(import (ikarus) (ikarus system $foreign))
(define-syntax check
(syntax-rules ()
[(_ pred expr expected)
(begin
(line)
(printf "TESTING ~s\n" 'expr)
(let ([v0 expr] [v1 expected])
(unless (pred v0 v1)
(error 'pred "failed" v0 v1)))
(printf "OK\n"))]))
(define (line)
(printf "=========================================================\n"))
(define self (dlopen #f))
(define hosym (dlsym self "ho"))
(define ho
((make-ffi 'sint32 '(pointer sint32)) hosym))
(define traced-foradd1
((make-callback 'sint32 '(sint32))
(trace-lambda add1 (n)
(collect)
(add1 n))))
(define foradd1
((make-callback 'sint32 '(sint32))
(lambda (n)
(collect)
(add1 n))))
(define foradd1-by-foreign-call
((make-callback 'sint32 '(sint32))
(trace-lambda foradd1-by-foreign-call (n)
(/ (ho traced-foradd1 n) 2))))
(check = (ho (dlsym self "cadd1") 17) (+ 18 18))
(check = (ho foradd1 17) (+ 18 18))
(check = (ho traced-foradd1 17) (+ 18 18))
(check = (ho foradd1-by-foreign-call 17) (+ 18 18))
(define test_I_I
((make-ffi 'sint32 '(pointer sint32)) (dlsym self "test_I_I")))
(define test_I_II
((make-ffi 'sint32 '(pointer sint32 sint32)) (dlsym self "test_I_II")))
(define test_I_III
((make-ffi 'sint32 '(pointer sint32 sint32 sint32)) (dlsym self "test_I_III")))
(define C_add_I_I (dlsym self "add_I_I"))
(define C_add_I_II (dlsym self "add_I_II"))
(define C_add_I_III (dlsym self "add_I_III"))
(check = (test_I_I C_add_I_I 12) (+ 12))
(check = (test_I_II C_add_I_II 12 13) (+ 12 13))
(check = (test_I_III C_add_I_III 12 13 14) (+ 12 13 14))
(define S_add_I_I ((make-callback 'sint32 '(sint32)) +))
(define S_add_I_II ((make-callback 'sint32 '(sint32 sint32)) +))
(define S_add_I_III ((make-callback 'sint32 '(sint32 sint32 sint32)) +))
(check = (test_I_I S_add_I_I 12) (+ 12))
(check = (test_I_II S_add_I_II 12 13) (+ 12 13))
(check = (test_I_III S_add_I_III 12 13 14) (+ 12 13 14))
(define test_D_D
((make-ffi 'double '(pointer double)) (dlsym self "test_D_D")))
(define test_D_DD
((make-ffi 'double '(pointer double double)) (dlsym self "test_D_DD")))
(define test_D_DDD
((make-ffi 'double '(pointer double double double)) (dlsym self "test_D_DDD")))
(define C_add_D_D (dlsym self "add_D_D"))
(define C_add_D_DD (dlsym self "add_D_DD"))
(define C_add_D_DDD (dlsym self "add_D_DDD"))
(check = (test_D_D C_add_D_D 12.0) (+ 12.0))
(check = (test_D_DD C_add_D_DD 12.0 13.0) (+ 12.0 13.0))
(check = (test_D_DDD C_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0))
(define S_add_D_D ((make-callback 'double '(double)) +))
(define S_add_D_DD ((make-callback 'double '(double double)) +))
(define S_add_D_DDD ((make-callback 'double '(double double double)) +))
(check = (test_D_D S_add_D_D 12.0) (+ 12.0))
(check = (test_D_DD S_add_D_DD 12.0 13.0) (+ 12.0 13.0))
(check = (test_D_DDD S_add_D_DDD 12.0 13.0 14.0) (+ 12.0 13.0 14.0))
(line)
(printf "Happy Happy Joy Joy\n")