108 lines
2.9 KiB
Scheme
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")
|