Started splitting the tests
This commit is contained in:
parent
66ded0d1ee
commit
ed96fcad0b
7
Makefile
7
Makefile
|
|
@ -67,15 +67,16 @@ ypsilon:
|
|||
test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
|
||||
make ${COMPILE_R7RS}
|
||||
cp -r retropikzel tmp/test/
|
||||
cp tests/compliance.scm tmp/test/
|
||||
cp tests/*.sld tmp/test/
|
||||
cp tests/*.scm tmp/test/
|
||||
cp tests/c-include/libtest.h tmp/test/
|
||||
cd tmp/test && \
|
||||
COMPILE_R7RS_GAMBIT="-cc-options \"-ltest -I. -L\" -ld-options \"-L.\"" \
|
||||
COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." \
|
||||
compile-r7rs -I . -o compliance compliance.scm
|
||||
compile-r7rs -I . -o ${TESTNAME} ${TESTNAME}.scm
|
||||
cd tmp/test && \
|
||||
LD_LIBRARY_PATH=. \
|
||||
./compliance
|
||||
./${TESTNAME}
|
||||
|
||||
test-compile-r7rs-docker:
|
||||
docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=r7rs-pffi-test-${COMPILE_R7RS} -f dockerfiles/test .
|
||||
|
|
|
|||
|
|
@ -85,7 +85,8 @@
|
|||
(primitives std-ffi)
|
||||
(primitives foreign-procedure)
|
||||
(primitives foreign-file)
|
||||
(primitives foreign-stdlib)))
|
||||
(primitives foreign-stdlib)
|
||||
(primitives system-interface)))
|
||||
(mosh
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
|
|
@ -176,9 +177,11 @@
|
|||
pointer-ref-c-pointer
|
||||
void?))
|
||||
(export make-external-function
|
||||
calculate-struct-size-and-offsets
|
||||
struct-make
|
||||
pffi:string-split))
|
||||
; calculate-struct-size-and-offsets
|
||||
;struct-make
|
||||
pffi:string-split
|
||||
c-bytevector-pointer-set!
|
||||
c-bytevector-pointer-ref))
|
||||
(tr7
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
|
|
@ -200,10 +203,13 @@
|
|||
c-size-of
|
||||
define-c-library
|
||||
define-c-procedure
|
||||
;pffi-define-callback; define-c-callback (?)
|
||||
define-c-callback
|
||||
c-bytevector?
|
||||
pffi-pointer-set!;c-bytevector-u8-set! and so on
|
||||
pffi-pointer-get;c-bytevector-u8-ref and so on
|
||||
c-bytevector-u8-ref
|
||||
|
||||
;; c-bytevector
|
||||
;pffi-pointer-set!;c-bytevector-u8-set! and so on
|
||||
;pffi-pointer-get;c-bytevector-u8-ref and so on
|
||||
native-endianness
|
||||
;; TODO Docs for all of these
|
||||
c-bytevector->address
|
||||
|
|
@ -211,7 +217,6 @@
|
|||
c-bytevector-s8-set!
|
||||
c-bytevector-s8-ref
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
c-bytevector-s16-set!
|
||||
c-bytevector-s16-native-set!
|
||||
c-bytevector-s16-ref
|
||||
|
|
@ -237,13 +242,9 @@
|
|||
c-bytevector-u64-ref
|
||||
c-bytevector-u64-native-ref
|
||||
c-bytevector-sint-set!
|
||||
c-bytevector-sint-native-set!
|
||||
c-bytevector-sint-ref
|
||||
c-bytevector-sint-native-ref
|
||||
c-bytevector-uint-set!
|
||||
c-bytevector-uint-native-set!
|
||||
c-bytevector-uint-ref
|
||||
c-bytevector-uint-native-ref
|
||||
c-bytevector-ieee-single-set!
|
||||
c-bytevector-ieee-single-native-set!
|
||||
c-bytevector-ieee-single-ref
|
||||
|
|
@ -271,22 +272,22 @@
|
|||
;c-bytevector-u8-ref ;; TODO Documentation, Testing
|
||||
|
||||
;; c-struct
|
||||
pffi-define-struct;define-c-struct
|
||||
pffi-struct-pointer;c-struct-bytevector
|
||||
pffi-struct-offset-get;c-struct-offset
|
||||
pffi-struct-set!;c-struct-set!
|
||||
pffi-struct-get;c-struct-get
|
||||
;pffi-define-struct;define-c-struct
|
||||
;pffi-struct-pointer;c-struct-bytevector
|
||||
;pffi-struct-offset-get;c-struct-offset
|
||||
;pffi-struct-set!;c-struct-set!
|
||||
;pffi-struct-get;c-struct-get
|
||||
|
||||
;; c-array
|
||||
;define-c-array (?)
|
||||
pffi-array-allocate;make-c-array
|
||||
pffi-array-pointer;c-array-pointer
|
||||
pffi-array?;c-array?
|
||||
pffi-pointer->array;c-bytevector->array
|
||||
pffi-array-get;c-array-get
|
||||
pffi-array-set!;c-array-set!
|
||||
pffi-list->array;list->c-array
|
||||
pffi-array->list;c-array->list
|
||||
;pffi-array-allocate;make-c-array
|
||||
;pffi-array-pointer;c-array-pointer
|
||||
;pffi-array?;c-array?
|
||||
;pffi-pointer->array;c-bytevector->array
|
||||
;pffi-array-get;c-array-get
|
||||
;pffi-array-set!;c-array-set!
|
||||
;pffi-list->array;list->c-array
|
||||
;pffi-array->list;c-array->list
|
||||
|
||||
;; c-variable
|
||||
;define-c-variable (?)
|
||||
|
|
@ -313,15 +314,17 @@
|
|||
(skint (include "pffi/skint.scm"))
|
||||
(stklos (include "pffi/stklos.scm"))
|
||||
(tr7 (include "pffi/tr7.scm"))
|
||||
(ypsilon (export c-function)
|
||||
(ypsilon (export c-function c-callback)
|
||||
(include "pffi/ypsilon.scm")))
|
||||
(cond-expand
|
||||
(chicken-6 (include-relative "pffi/shared/main.scm")
|
||||
(include-relative "pffi/shared/pointer.scm")
|
||||
(include-relative "pffi/shared/array.scm")
|
||||
(include-relative "pffi/shared/struct.scm"))
|
||||
;(include-relative "pffi/shared/array.scm")
|
||||
;(include-relative "pffi/shared/struct.scm")
|
||||
)
|
||||
(else (include "pffi/shared/main.scm")
|
||||
(include "pffi/shared/struct.scm")
|
||||
;(include "pffi/shared/struct.scm")
|
||||
(include "pffi/shared/c-bytevectors.scm")
|
||||
(include "pffi/shared/pointer.scm")
|
||||
(include "pffi/shared/array.scm"))))
|
||||
;(include "pffi/shared/array.scm")
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@
|
|||
(pointer-free pointer)))
|
||||
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
|
||||
(define pffi-type->native-type ; Chicken has this procedure in three places
|
||||
(define type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
|
|
@ -23,7 +23,7 @@
|
|||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
|
|
@ -32,15 +32,15 @@
|
|||
(define-syntax define-c-procedure
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type ; Chicken has this procedure in three places
|
||||
(let* ((type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
|
|
@ -56,13 +56,13 @@
|
|||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (list-ref expr 1))
|
||||
(c-name (symbol->string (cadr (list-ref expr 3))))
|
||||
(return-type (pffi-type->native-type (cadr (list-ref expr 4))))
|
||||
(return-type (type->native-type (cadr (list-ref expr 4))))
|
||||
(argument-types (if (null? (cdr (list-ref expr 5)))
|
||||
(list)
|
||||
(map pffi-type->native-type
|
||||
(map type->native-type
|
||||
(cadr (list-ref expr 5))))))
|
||||
(if (null? argument-types)
|
||||
`(define ,scheme-name
|
||||
|
|
@ -70,18 +70,18 @@
|
|||
`(define ,scheme-name
|
||||
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(define-syntax define-c-callback
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((pffi-type->native-type ; Chicken has this procedure in three places
|
||||
(let* ((type->native-type ; Chicken has this procedure in three places
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'byte)
|
||||
((equal? type 'uint8) 'unsigned-byte)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32)
|
||||
((equal? type 'uint32) 'unsigned-int32)
|
||||
((equal? type 'int64) 'integer-64)
|
||||
((equal? type 'int16) 'short)
|
||||
((equal? type 'uint16) 'unsigned-short)
|
||||
((equal? type 'int32) 'integer32)
|
||||
((equal? type 'uint32) 'unsigned-integer32)
|
||||
((equal? type 'int64) 'integer64)
|
||||
((equal? type 'uint64) 'unsigned-integer64)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'unsigned-char)
|
||||
|
|
@ -97,10 +97,10 @@
|
|||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
((equal? type 'struct) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
(scheme-name (list-ref expr 1))
|
||||
(return-type (pffi-type->native-type (cadr (list-ref expr 2))))
|
||||
(argument-types (map pffi-type->native-type (cadr (list-ref expr 3))))
|
||||
(return-type (type->native-type (cadr (list-ref expr 2))))
|
||||
(argument-types (map type->native-type (cadr (list-ref expr 3))))
|
||||
(argument-names (cadr (list-ref expr 4)))
|
||||
(arguments (map
|
||||
(lambda (name type)
|
||||
|
|
@ -145,9 +145,9 @@
|
|||
((_ scheme-name headers object-name options)
|
||||
(begin
|
||||
(define scheme-name #t)
|
||||
(pffi-shared-object-load headers)))))
|
||||
(shared-object-load headers)))))
|
||||
|
||||
(define-syntax pffi-shared-object-load
|
||||
(define-syntax shared-object-load
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((headers (cadr (car (cdr expr)))))
|
||||
|
|
@ -167,13 +167,13 @@
|
|||
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(pointer-s8-ref (pointer+ c-bytevector k))))
|
||||
(pointer-u8-ref (pointer+ c-bytevector k))))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
#;(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(pointer-s8-set! (pointer+ c-bytevector k) byte)))
|
||||
(pointer-u8-set! (pointer+ c-bytevector k) byte)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
#;(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
|
|
@ -195,7 +195,7 @@
|
|||
((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
#;(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
|
||||
|
|
|
|||
|
|
@ -345,7 +345,7 @@
|
|||
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
|
||||
return_closcall1(data, k, &opq);")
|
||||
|
||||
(define c-bytevector-u8-set! pffi-pointer-uint8-set!)
|
||||
#;(define c-bytevector-u8-set! pffi-pointer-uint8-set!)
|
||||
(define c-bytevector-u8-ref pffi-pointer-uint8-get)
|
||||
|
||||
(define pffi-pointer-get
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@
|
|||
(lambda (x) #f)
|
||||
(lambda () (pointer? object)))))))
|
||||
|
||||
(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
#;(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
(define c-bytevector-u8-ref (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));"))
|
||||
|
||||
(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;"))
|
||||
|
|
|
|||
|
|
@ -1,15 +1,18 @@
|
|||
(define-module retropikzel.pffi.gauche
|
||||
(export size-of-type
|
||||
pffi-shared-object-load
|
||||
c-bytevector-u8-set!
|
||||
c-bytevector-u8-ref
|
||||
;pffi-pointer-null
|
||||
;pffi-pointer-null?
|
||||
make-c-bytevector
|
||||
pffi-pointer-address
|
||||
;pffi-pointer-address
|
||||
c-bytevector?
|
||||
c-free
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
define-c-procedure))
|
||||
define-c-procedure
|
||||
define-c-callback))
|
||||
|
||||
(select-module retropikzel.pffi.gauche)
|
||||
(dynamic-load "retropikzel/pffi/gauche-pffi")
|
||||
|
|
@ -55,6 +58,9 @@
|
|||
(lambda (pointer)
|
||||
(pointer-free pointer)))
|
||||
|
||||
;(define c-bytevector-u8-set! pointer-set-uint8!)
|
||||
(define c-bytevector-u8-ref pointer-get-uint8)
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-int8! pointer offset value))
|
||||
|
|
@ -99,7 +105,7 @@
|
|||
((equal? type 'void) (pointer-get-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-get-pointer pointer offset)))))
|
||||
|
||||
(define pffi-type->libffi-type
|
||||
(define type->libffi-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (get-ffi-type-int8))
|
||||
((equal? type 'uint8) (get-ffi-type-uint8))
|
||||
|
|
@ -144,8 +150,8 @@
|
|||
0
|
||||
(size-of-type return-type)))))
|
||||
(internal-ffi-call (length argument-types)
|
||||
(pffi-type->libffi-type return-type)
|
||||
(map pffi-type->libffi-type argument-types)
|
||||
(type->libffi-type return-type)
|
||||
(map type->libffi-type argument-types)
|
||||
c-function
|
||||
return-value
|
||||
(map argument->pointer
|
||||
|
|
@ -167,7 +173,7 @@
|
|||
(lambda (return-type argument-types procedure)
|
||||
(scheme-procedure-to-pointer procedure)))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@
|
|||
((equal? type 'double) double)
|
||||
((equal? type 'pointer) '*)
|
||||
((equal? type 'void) void)
|
||||
((equal? type 'string) '*)
|
||||
((equal? type 'callback) '*)
|
||||
((equal? type 'struct) '*)
|
||||
(else #f))))
|
||||
|
|
@ -38,7 +37,7 @@
|
|||
#:return-type (pffi-type->native-type return-type)
|
||||
#:arg-types (map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
|
|
@ -57,7 +56,7 @@
|
|||
(lambda (path options)
|
||||
(load-foreign-library path)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
#;(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(let ((p (pointer->bytevector c-bytevector (+ k 100))))
|
||||
(bytevector-u8-set! p k byte))))
|
||||
|
|
|
|||
|
|
@ -48,7 +48,6 @@
|
|||
((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4))
|
||||
((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8))
|
||||
((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'string) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1))
|
||||
((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8))
|
||||
|
|
@ -89,7 +88,7 @@
|
|||
(looper (+ count 1) (append result (list count)))))))
|
||||
(looper from (list)))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
(require 'std-ffi)
|
||||
(require 'ffi-load)
|
||||
|
||||
;; FIXME
|
||||
(define size-of-type
|
||||
|
|
@ -21,67 +22,23 @@
|
|||
((eq? type 'unsigned-long) 4)
|
||||
((eq? type 'float) 4)
|
||||
((eq? type 'double) 8)
|
||||
((eq? type 'pointer) 4)
|
||||
((eq? type 'pointer) sizeof:pointer)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'callback) 4)
|
||||
((eq? type 'callback) sizeof:pointer)
|
||||
(else (error "Can not get size of unknown type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
;(void*? object)
|
||||
(number? object)
|
||||
))
|
||||
(number? object)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (headers path . options)
|
||||
(foreign-file path)))
|
||||
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
0
|
||||
#;(cond ((equal? type 'int8) (%poke8 (+ pointer offset) value))
|
||||
((equal? type 'uint8) (%poke8u (+ pointer offset) value))
|
||||
((equal? type 'int16) (%poke16 (+ pointer offset) value))
|
||||
((equal? type 'uint16) (%poke16u (+ pointer offset) value))
|
||||
((equal? type 'int32) (%poke32 (+ pointer offset) value))
|
||||
((equal? type 'uint32) (%poke32u (+ pointer offset) value))
|
||||
;((equal? type 'int64) (%poke64 (+ pointer offset) value))
|
||||
;((equal? type 'uint64) (%poke64u (+ pointer offset) value))
|
||||
((equal? type 'char) (%poke8 (+ pointer offset) value))
|
||||
((equal? type 'short) (%poke-short (+ pointer offset) value))
|
||||
((equal? type 'unsigned-short) (%poke-ushort (+ pointer offset) value))
|
||||
((equal? type 'int) (%poke-int (+ pointer offset) value))
|
||||
((equal? type 'unsigned-int) (%poke-uint (+ pointer offset) value))
|
||||
((equal? type 'long) (%poke-long (+ pointer offset) value))
|
||||
((equal? type 'unsigned-long) (%poke-ulong (+ pointer offset) value))
|
||||
;((equal? type 'float) (%poke-ulong (+ pointer offset) value))
|
||||
;((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void) (%poke-pointer (+ pointer offset) value))
|
||||
((equal? type 'pointer) (%poke-pointer (+ pointer offset) value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
0
|
||||
#;(cond ((equal? type 'int8) (%peek8 (+ pointer offset)))
|
||||
((equal? type 'uint8) (%peek8u (+ pointer offset)))
|
||||
((equal? type 'int16) (%peek16 (+ pointer offset)))
|
||||
((equal? type 'uint16) (%peek16u (+ pointer offset)))
|
||||
((equal? type 'int32) (%peek32 (+ pointer offset)))
|
||||
((equal? type 'uint32) (%peek32u (+ pointer offset)))
|
||||
;((equal? type 'int64) (%peek64 (+ pointer offset)))
|
||||
;((equal? type 'uint64) (%peek64u (+ pointer offset)))
|
||||
((equal? type 'char) (%peek8 (+ pointer offset)))
|
||||
((equal? type 'short) (%peek-short (+ pointer offset)))
|
||||
((equal? type 'unsigned-short) (%peek-ushort (+ pointer offset)))
|
||||
((equal? type 'int) (%peek-int (+ pointer offset)))
|
||||
((equal? type 'unsigned-int) (%peek-uint (+ pointer offset)))
|
||||
((equal? type 'long) (%peek-long (+ pointer offset)))
|
||||
((equal? type 'unsigned-long) (%peek-ulong (+ pointer offset)))
|
||||
;((equal? type 'float) (%peek-ulong (+ pointer offset)))
|
||||
;((equal? type 'double) (pointer-set-c-double! pointer offset))
|
||||
((equal? type 'void) (%peek-pointer (+ pointer offset)))
|
||||
((equal? type 'pointer) (%peek-pointer (+ pointer offset))))))
|
||||
(define c-bytevector-u8-ref
|
||||
(lambda (c-bytevector k)
|
||||
(peek-bytes c-bytevector k (c-size-of 'uint8))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8!)
|
||||
;(define c-bytevector-u8-set! pointer-set-c-uint8!)
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8)
|
||||
|
||||
(define pffi-pointer-set!
|
||||
|
|
@ -100,7 +100,6 @@
|
|||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'char*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
((equal? type 'struct) 'void*)
|
||||
|
|
@ -115,7 +114,7 @@
|
|||
c-name
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@
|
|||
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
|
||||
(pffi-type->native-type return-type)))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(define scheme-name (function-ptr procedure
|
||||
|
|
@ -61,7 +61,7 @@
|
|||
(list #f))))
|
||||
(ffi-lib path))))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
#;(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(ptr-set! c-bytevector _uint8 'abs k byte)))
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@
|
|||
((eq? type 'double) size-of-double)
|
||||
((eq? type 'pointer) size-of-void*)
|
||||
((eq? type 'void) 0)
|
||||
((eq? type 'string) size-of-void*)
|
||||
((eq? type 'callback) size-of-void*)
|
||||
(else #f))))
|
||||
|
||||
|
|
@ -49,10 +48,8 @@
|
|||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'callback)
|
||||
((and (pair? type) (equal? 'struct (car type))) 'void*)
|
||||
(else #f))))
|
||||
|
||||
(define-syntax define-c-procedure
|
||||
|
|
@ -64,7 +61,7 @@
|
|||
c-name
|
||||
(map pffi-type->native-type argument-types))))))
|
||||
|
||||
(define-syntax pffi-define-callback
|
||||
(define-syntax define-c-callback
|
||||
(syntax-rules ()
|
||||
((_ scheme-name return-type argument-types procedure)
|
||||
(define scheme-name
|
||||
|
|
@ -76,9 +73,8 @@
|
|||
(lambda (object)
|
||||
(pointer? object)))
|
||||
|
||||
;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
|
|
|
|||
|
|
@ -24,7 +24,8 @@
|
|||
|
||||
(define c-size-of
|
||||
(lambda (object)
|
||||
(cond ((pffi-struct? object) (pffi-struct-size object))
|
||||
(size-of-type object)
|
||||
#;(cond ((pffi-struct? object) (pffi-struct-size object))
|
||||
((pffi-type? object) (size-of-type object))
|
||||
(else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
(define-c-procedure pffi-pointer-allocate-calloc libc 'calloc 'pointer '(int int))
|
||||
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))
|
||||
(define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))
|
||||
(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int))
|
||||
(define-c-procedure c-printf libc 'printf 'int '(pointer pointer))
|
||||
(define-c-procedure c-malloc libc 'malloc 'pointer '(int))
|
||||
(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
|
||||
|
|
@ -111,6 +112,14 @@
|
|||
(native-endianness)
|
||||
(c-size-of 'pointer)))))
|
||||
|
||||
(cond-expand
|
||||
(kawa #t) ; Defined in kawa.scm
|
||||
(else
|
||||
(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(let ((address (c-memset-pointer->address c-bytevector 0 0)))
|
||||
(c-memset-address (+ address k) byte 1))))))
|
||||
|
||||
(define-syntax call-with-address-of-c-bytevector
|
||||
(syntax-rules ()
|
||||
((_ input-pointer thunk)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(define pffi-type->native-type
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :char)
|
||||
((equal? type 'uint8) :char)
|
||||
|
|
@ -20,8 +20,8 @@
|
|||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'void) :void)
|
||||
((equal? type 'struct) :void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
((equal? type 'callback) :pointer)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
|
||||
(define c-bytevector?
|
||||
(lambda (object)
|
||||
|
|
@ -31,39 +31,38 @@
|
|||
(syntax-rules ()
|
||||
((_ scheme-name shared-object c-name return-type argument-types)
|
||||
(begin
|
||||
(define pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :int)
|
||||
((equal? type 'uint8) :uint)
|
||||
((equal? type 'int16) :int)
|
||||
((equal? type 'uint16) :uint)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :int)
|
||||
((equal? type 'uint64) :uint)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :uchar)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'string) :string)
|
||||
((equal? type 'void) :void)
|
||||
((equal? type 'struct) :void)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||
(define scheme-name
|
||||
(make-external-function
|
||||
(symbol->string c-name)
|
||||
(map pffi-type->native-type argument-types)
|
||||
(pffi-type->native-type return-type)
|
||||
shared-object))))))
|
||||
(define type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) :char)
|
||||
((equal? type 'uint8) :char)
|
||||
((equal? type 'int16) :short)
|
||||
((equal? type 'uint16) :ushort)
|
||||
((equal? type 'int32) :int)
|
||||
((equal? type 'uint32) :uint)
|
||||
((equal? type 'int64) :long)
|
||||
((equal? type 'uint64) :ulong)
|
||||
((equal? type 'char) :char)
|
||||
((equal? type 'unsigned-char) :uchar)
|
||||
((equal? type 'short) :short)
|
||||
((equal? type 'unsigned-short) :ushort)
|
||||
((equal? type 'int) :int)
|
||||
((equal? type 'unsigned-int) :uint)
|
||||
((equal? type 'long) :long)
|
||||
((equal? type 'unsigned-long) :ulong)
|
||||
((equal? type 'float) :float)
|
||||
((equal? type 'double) :double)
|
||||
((equal? type 'pointer) :pointer)
|
||||
((equal? type 'void) :void)
|
||||
((equal? type 'callback) :pointer)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
(define scheme-name
|
||||
(make-external-function
|
||||
(symbol->string c-name)
|
||||
(map type->native-type argument-types)
|
||||
(type->native-type return-type)
|
||||
shared-object))))))
|
||||
|
||||
(define pffi-define-callback
|
||||
(define define-c-callback
|
||||
(lambda ()
|
||||
(error "Not implemented")))
|
||||
|
||||
|
|
@ -90,7 +89,7 @@
|
|||
((equal? type 'double) 8)
|
||||
((equal? type 'pointer) 8))))
|
||||
|
||||
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
|
||||
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
|
||||
|
||||
(define pffi-pointer-set!
|
||||
|
|
|
|||
|
|
@ -19,7 +19,6 @@
|
|||
((eq? type 'float) (c-sizeof float))
|
||||
((eq? type 'double) (c-sizeof double))
|
||||
((eq? type 'pointer) (c-sizeof void*))
|
||||
((eq? type 'string) (c-sizeof void*))
|
||||
((eq? type 'struct) (c-sizeof void*))
|
||||
((eq? type 'callback) (c-sizeof void*))
|
||||
((eq? type 'void) 0)
|
||||
|
|
@ -29,7 +28,7 @@
|
|||
(lambda (object)
|
||||
(number? object)))
|
||||
|
||||
(define c-bytevector-u8-set!
|
||||
#;(define c-bytevector-u8-set!
|
||||
(lambda (c-bytevector k byte)
|
||||
(bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
|
||||
(c-size-of 'uint8))
|
||||
|
|
@ -93,7 +92,7 @@
|
|||
(load-shared-object path)))
|
||||
|
||||
#;(define-macro
|
||||
(pffi-type->native-type type)
|
||||
(type->native-type type)
|
||||
`(cond ((equal? ,type 'int8) 'int8_t)
|
||||
((equal? ,type 'uint8) 'uint8_t)
|
||||
;((equal? ,type 'int16) 'int16_t)
|
||||
|
|
@ -113,15 +112,14 @@
|
|||
;((equal? ,type 'float) 'float)
|
||||
;((equal? ,type 'double) 'double)
|
||||
((equal? ,type 'pointer) 'void*)
|
||||
;((equal? ,type 'string) 'void*)
|
||||
((equal? ,type 'void) 'void)
|
||||
;((equal? ,type 'callback) 'void*)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" ,type))))
|
||||
(else (error "type->native-type -- No such pffi type" ,type))))
|
||||
|
||||
(define-macro
|
||||
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
|
||||
(begin
|
||||
(let ((pffi-type->native-type
|
||||
(let ((type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
|
|
@ -142,43 +140,41 @@
|
|||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type))))))
|
||||
(else (error "type->native-type -- No such pffi type" type))))))
|
||||
`(define ,scheme-name
|
||||
(c-function ,(pffi-type->native-type (cadr return-type))
|
||||
(c-function ,(type->native-type (cadr return-type))
|
||||
,(cadr c-name)
|
||||
,(map pffi-type->native-type (cadr argument-types)))))))
|
||||
,(map type->native-type (cadr argument-types)))))))
|
||||
|
||||
(define-macro
|
||||
(pffi-define-callback scheme-name return-type argument-types procedure)
|
||||
(let ((pffi-type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'string) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type))))))
|
||||
(define-c-callback scheme-name return-type argument-types procedure)
|
||||
(let* ((type->native-type
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) 'int8_t)
|
||||
((equal? type 'uint8) 'uint8_t)
|
||||
((equal? type 'int16) 'int16_t)
|
||||
((equal? type 'uint16) 'uint16_t)
|
||||
((equal? type 'int32) 'int32_t)
|
||||
((equal? type 'uint32) 'uint32_t)
|
||||
((equal? type 'int64) 'int64_t)
|
||||
((equal? type 'uint64) 'uint64_t)
|
||||
((equal? type 'char) 'char)
|
||||
((equal? type 'unsigned-char) 'char)
|
||||
((equal? type 'short) 'short)
|
||||
((equal? type 'unsigned-short) 'unsigned-short)
|
||||
((equal? type 'int) 'int)
|
||||
((equal? type 'unsigned-int) 'unsigned-int)
|
||||
((equal? type 'long) 'long)
|
||||
((equal? type 'unsigned-long) 'unsigned-long)
|
||||
((equal? type 'float) 'float)
|
||||
((equal? type 'double) 'double)
|
||||
((equal? type 'pointer) 'void*)
|
||||
((equal? type 'void) 'void)
|
||||
((equal? type 'callback) 'void*)
|
||||
(else (error "type->native-type -- No such pffi type" type)))))
|
||||
(native-return-type (type->native-type (cadr return-type)))
|
||||
(native-argument-types (map type->native-type (cadr argument-types))))
|
||||
`(define ,scheme-name
|
||||
(c-callback ,(pffi-type->native-type return-type)
|
||||
,(map pffi-type->native-type (cdr argument-types))
|
||||
,procedure))))
|
||||
(c-callback ,native-return-type ,native-argument-types ,procedure))))
|
||||
|
|
|
|||
|
|
@ -560,56 +560,56 @@
|
|||
|
||||
; pffi-define-struct
|
||||
|
||||
(print-header "pffi-define-struct")
|
||||
;(print-header "pffi-define-struct")
|
||||
;
|
||||
;(pffi-define-struct test-struct1 'teststruct1 '((int . r) (int . g) (int . b)))
|
||||
;(define struct1 (test-struct1))
|
||||
;(debug struct1)
|
||||
;(debug (c-size-of struct1))
|
||||
;(assert = (c-size-of struct1) 12)
|
||||
;
|
||||
;(pffi-define-struct test-struct2 'test2 '((int8 . r) (int8 . g) (int . b)))
|
||||
;(define struct2 (test-struct2))
|
||||
;(debug struct2)
|
||||
;(debug (c-size-of struct2))
|
||||
;(assert = (c-size-of struct2) 8)
|
||||
;
|
||||
;(pffi-define-struct test-struct3 'test3 '((int8 . r) (int8 . g) (int . b)))
|
||||
;(define struct3 (test-struct3))
|
||||
;(debug struct3)
|
||||
;(debug (c-size-of struct3))
|
||||
;(assert = (c-size-of struct3) 8)
|
||||
;
|
||||
;(pffi-define-struct test-struct4 'test4 '((int8 . r) (pointer . a) (int8 . g) (int . b)))
|
||||
;(define struct4 (test-struct4))
|
||||
;(debug struct4)
|
||||
;(debug (c-size-of struct4))
|
||||
;(assert = (c-size-of struct4) 24)
|
||||
;
|
||||
;(pffi-define-struct test-struct5 'test5 '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))
|
||||
;(define struct5 (test-struct5))
|
||||
;(debug struct5)
|
||||
;(debug (c-size-of struct5))
|
||||
;(assert = (c-size-of struct5) 24)
|
||||
|
||||
(pffi-define-struct test-struct1 'teststruct1 '((int . r) (int . g) (int . b)))
|
||||
(define struct1 (test-struct1))
|
||||
(debug struct1)
|
||||
(debug (c-size-of struct1))
|
||||
(assert = (c-size-of struct1) 12)
|
||||
|
||||
(pffi-define-struct test-struct2 'test2 '((int8 . r) (int8 . g) (int . b)))
|
||||
(define struct2 (test-struct2))
|
||||
(debug struct2)
|
||||
(debug (c-size-of struct2))
|
||||
(assert = (c-size-of struct2) 8)
|
||||
|
||||
(pffi-define-struct test-struct3 'test3 '((int8 . r) (int8 . g) (int . b)))
|
||||
(define struct3 (test-struct3))
|
||||
(debug struct3)
|
||||
(debug (c-size-of struct3))
|
||||
(assert = (c-size-of struct3) 8)
|
||||
|
||||
(pffi-define-struct test-struct4 'test4 '((int8 . r) (pointer . a) (int8 . g) (int . b)))
|
||||
(define struct4 (test-struct4))
|
||||
(debug struct4)
|
||||
(debug (c-size-of struct4))
|
||||
(assert = (c-size-of struct4) 24)
|
||||
|
||||
(pffi-define-struct test-struct5 'test5 '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))
|
||||
(define struct5 (test-struct5))
|
||||
(debug struct5)
|
||||
(debug (c-size-of struct5))
|
||||
(assert = (c-size-of struct5) 24)
|
||||
|
||||
(pffi-define-struct test-struct6 'test6 '((int8 . a)
|
||||
(char . b)
|
||||
(double . c)
|
||||
(char . d)
|
||||
(pointer . e)
|
||||
(float . f)
|
||||
(pointer . g)
|
||||
(int8 . h)
|
||||
(pointer . i)
|
||||
(int . j)
|
||||
(int . k)
|
||||
(int . l)
|
||||
(double . m)
|
||||
(float . n)))
|
||||
(define struct6 (test-struct6))
|
||||
(debug struct6)
|
||||
(debug (c-size-of struct6))
|
||||
(assert = (c-size-of struct6) 96)
|
||||
;(pffi-define-struct test-struct6 'test6 '((int8 . a)
|
||||
; (char . b)
|
||||
; (double . c)
|
||||
; (char . d)
|
||||
; (pointer . e)
|
||||
; (float . f)
|
||||
; (pointer . g)
|
||||
; (int8 . h)
|
||||
; (pointer . i)
|
||||
; (int . j)
|
||||
; (int . k)
|
||||
; (int . l)
|
||||
; (double . m)
|
||||
; (float . n)))
|
||||
;(define struct6 (test-struct6))
|
||||
;(debug struct6)
|
||||
;(debug (c-size-of struct6))
|
||||
;(assert = (c-size-of struct6) 96)
|
||||
|
||||
;; bytevector->c-bytevector c-bytevector->bytevector
|
||||
|
||||
|
|
@ -628,112 +628,112 @@
|
|||
|
||||
;; pffi-struct-get
|
||||
|
||||
(print-header 'pffi-struct-get)
|
||||
|
||||
(define-c-procedure c-init-struct c-testlib 'init_struct 'pointer '(pointer))
|
||||
(define-c-procedure c-check-offset c-testlib 'check_offset 'void '(int int))
|
||||
(pffi-define-struct struct-test-get1 'test_get1
|
||||
'((int8 . a)
|
||||
(char . b)
|
||||
(double . c)
|
||||
(char . d)
|
||||
(pointer . e)
|
||||
(float . f)
|
||||
(pointer . g)
|
||||
(int8 . h)
|
||||
(pointer . i)
|
||||
(int . j)
|
||||
(int . k)
|
||||
(int . l)
|
||||
(double . m)
|
||||
(float . n)))
|
||||
(define struct-test (struct-test-get1))
|
||||
(c-check-offset 1 (pffi-struct-offset-get struct-test 'a))
|
||||
(c-check-offset 2 (pffi-struct-offset-get struct-test 'b))
|
||||
(c-check-offset 3 (pffi-struct-offset-get struct-test 'c))
|
||||
(c-check-offset 4 (pffi-struct-offset-get struct-test 'd))
|
||||
(c-check-offset 5 (pffi-struct-offset-get struct-test 'e))
|
||||
(c-check-offset 6 (pffi-struct-offset-get struct-test 'f))
|
||||
(c-check-offset 7 (pffi-struct-offset-get struct-test 'g))
|
||||
(c-check-offset 8 (pffi-struct-offset-get struct-test 'h))
|
||||
(c-check-offset 9 (pffi-struct-offset-get struct-test 'i))
|
||||
(c-check-offset 10 (pffi-struct-offset-get struct-test 'j))
|
||||
(c-check-offset 11 (pffi-struct-offset-get struct-test 'k))
|
||||
(c-check-offset 12 (pffi-struct-offset-get struct-test 'l))
|
||||
(c-check-offset 13 (pffi-struct-offset-get struct-test 'm))
|
||||
(c-check-offset 14 (pffi-struct-offset-get struct-test 'n))
|
||||
(debug struct-test)
|
||||
(c-init-struct (pffi-struct-pointer struct-test))
|
||||
(debug struct-test)
|
||||
|
||||
(debug (pffi-struct-get struct-test 'a))
|
||||
(assert = (pffi-struct-get struct-test 'a) 1)
|
||||
(debug (pffi-struct-get struct-test 'b))
|
||||
(assert char=? (pffi-struct-get struct-test 'b) #\b)
|
||||
(debug (pffi-struct-get struct-test 'c))
|
||||
(assert = (pffi-struct-get struct-test 'c) 3.0)
|
||||
(debug (pffi-struct-get struct-test 'd))
|
||||
(assert char=? (pffi-struct-get struct-test 'd) #\d)
|
||||
(debug (pffi-struct-get struct-test 'e))
|
||||
(debug (c-null? (pffi-struct-get struct-test 'e)))
|
||||
(assert equal? (c-null? (pffi-struct-get struct-test 'e)) #t)
|
||||
(debug (pffi-struct-get struct-test 'f))
|
||||
(assert = (pffi-struct-get struct-test 'f) 6.0)
|
||||
(debug (pffi-struct-get struct-test 'g))
|
||||
(debug (c-utf8->string (pffi-struct-get struct-test 'g)))
|
||||
(assert equal? (string=? (c-utf8->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t)
|
||||
(debug (pffi-struct-get struct-test 'h))
|
||||
(assert = (pffi-struct-get struct-test 'h) 8)
|
||||
(debug (pffi-struct-get struct-test 'i))
|
||||
(debug (c-null? (pffi-struct-get struct-test 'i)))
|
||||
(assert equal? (c-null? (pffi-struct-get struct-test 'i)) #t)
|
||||
(debug (pffi-struct-get struct-test 'j))
|
||||
(assert = (pffi-struct-get struct-test 'j) 10)
|
||||
(debug (pffi-struct-get struct-test 'k))
|
||||
(assert = (pffi-struct-get struct-test 'k) 11)
|
||||
(debug (pffi-struct-get struct-test 'l))
|
||||
(assert = (pffi-struct-get struct-test 'l) 12)
|
||||
(debug (pffi-struct-get struct-test 'm))
|
||||
(assert = (pffi-struct-get struct-test 'm) 13.0)
|
||||
(debug (pffi-struct-get struct-test 'n))
|
||||
(assert = (pffi-struct-get struct-test 'n) 14.0)
|
||||
|
||||
;; pffi-struct-set! 1
|
||||
|
||||
(print-header "pffi-struct-set! 1")
|
||||
|
||||
(define-c-procedure c-test-check c-testlib 'test_check 'int '(pointer))
|
||||
(pffi-define-struct struct-test-set1 'test_set1
|
||||
'((int8 . a)
|
||||
(char . b)
|
||||
(double . c)
|
||||
(char . d)
|
||||
(pointer . e)
|
||||
(float . f)
|
||||
(pointer . g)
|
||||
(int8 . h)
|
||||
(pointer . i)
|
||||
(int . j)
|
||||
(int . k)
|
||||
(int . l)
|
||||
(double . m)
|
||||
(float . n)))
|
||||
(define struct-test1 (struct-test-set1))
|
||||
(pffi-struct-set! struct-test1 'a 1)
|
||||
(pffi-struct-set! struct-test1 'b #\b)
|
||||
(pffi-struct-set! struct-test1 'c 3.0)
|
||||
(pffi-struct-set! struct-test1 'd #\d)
|
||||
(pffi-struct-set! struct-test1 'e (make-c-null))
|
||||
(pffi-struct-set! struct-test1 'f 6.0)
|
||||
(pffi-struct-set! struct-test1 'g (string->c-utf8 "foo"))
|
||||
(pffi-struct-set! struct-test1 'h 8)
|
||||
(pffi-struct-set! struct-test1 'i (make-c-null))
|
||||
(pffi-struct-set! struct-test1 'j 10)
|
||||
(pffi-struct-set! struct-test1 'k 11)
|
||||
(pffi-struct-set! struct-test1 'l 12)
|
||||
(pffi-struct-set! struct-test1 'm 13.0)
|
||||
(pffi-struct-set! struct-test1 'n 14.0)
|
||||
(c-test-check (pffi-struct-pointer struct-test1))
|
||||
;(print-header 'pffi-struct-get)
|
||||
;
|
||||
;(define-c-procedure c-init-struct c-testlib 'init_struct 'pointer '(pointer))
|
||||
;(define-c-procedure c-check-offset c-testlib 'check_offset 'void '(int int))
|
||||
;(pffi-define-struct struct-test-get1 'test_get1
|
||||
; '((int8 . a)
|
||||
; (char . b)
|
||||
; (double . c)
|
||||
; (char . d)
|
||||
; (pointer . e)
|
||||
; (float . f)
|
||||
; (pointer . g)
|
||||
; (int8 . h)
|
||||
; (pointer . i)
|
||||
; (int . j)
|
||||
; (int . k)
|
||||
; (int . l)
|
||||
; (double . m)
|
||||
; (float . n)))
|
||||
;(define struct-test (struct-test-get1))
|
||||
;(c-check-offset 1 (pffi-struct-offset-get struct-test 'a))
|
||||
;(c-check-offset 2 (pffi-struct-offset-get struct-test 'b))
|
||||
;(c-check-offset 3 (pffi-struct-offset-get struct-test 'c))
|
||||
;(c-check-offset 4 (pffi-struct-offset-get struct-test 'd))
|
||||
;(c-check-offset 5 (pffi-struct-offset-get struct-test 'e))
|
||||
;(c-check-offset 6 (pffi-struct-offset-get struct-test 'f))
|
||||
;(c-check-offset 7 (pffi-struct-offset-get struct-test 'g))
|
||||
;(c-check-offset 8 (pffi-struct-offset-get struct-test 'h))
|
||||
;(c-check-offset 9 (pffi-struct-offset-get struct-test 'i))
|
||||
;(c-check-offset 10 (pffi-struct-offset-get struct-test 'j))
|
||||
;(c-check-offset 11 (pffi-struct-offset-get struct-test 'k))
|
||||
;(c-check-offset 12 (pffi-struct-offset-get struct-test 'l))
|
||||
;(c-check-offset 13 (pffi-struct-offset-get struct-test 'm))
|
||||
;(c-check-offset 14 (pffi-struct-offset-get struct-test 'n))
|
||||
;(debug struct-test)
|
||||
;(c-init-struct (pffi-struct-pointer struct-test))
|
||||
;(debug struct-test)
|
||||
;
|
||||
;(debug (pffi-struct-get struct-test 'a))
|
||||
;(assert = (pffi-struct-get struct-test 'a) 1)
|
||||
;(debug (pffi-struct-get struct-test 'b))
|
||||
;(assert char=? (pffi-struct-get struct-test 'b) #\b)
|
||||
;(debug (pffi-struct-get struct-test 'c))
|
||||
;(assert = (pffi-struct-get struct-test 'c) 3.0)
|
||||
;(debug (pffi-struct-get struct-test 'd))
|
||||
;(assert char=? (pffi-struct-get struct-test 'd) #\d)
|
||||
;(debug (pffi-struct-get struct-test 'e))
|
||||
;(debug (c-null? (pffi-struct-get struct-test 'e)))
|
||||
;(assert equal? (c-null? (pffi-struct-get struct-test 'e)) #t)
|
||||
;(debug (pffi-struct-get struct-test 'f))
|
||||
;(assert = (pffi-struct-get struct-test 'f) 6.0)
|
||||
;(debug (pffi-struct-get struct-test 'g))
|
||||
;(debug (c-utf8->string (pffi-struct-get struct-test 'g)))
|
||||
;(assert equal? (string=? (c-utf8->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t)
|
||||
;(debug (pffi-struct-get struct-test 'h))
|
||||
;(assert = (pffi-struct-get struct-test 'h) 8)
|
||||
;(debug (pffi-struct-get struct-test 'i))
|
||||
;(debug (c-null? (pffi-struct-get struct-test 'i)))
|
||||
;(assert equal? (c-null? (pffi-struct-get struct-test 'i)) #t)
|
||||
;(debug (pffi-struct-get struct-test 'j))
|
||||
;(assert = (pffi-struct-get struct-test 'j) 10)
|
||||
;(debug (pffi-struct-get struct-test 'k))
|
||||
;(assert = (pffi-struct-get struct-test 'k) 11)
|
||||
;(debug (pffi-struct-get struct-test 'l))
|
||||
;(assert = (pffi-struct-get struct-test 'l) 12)
|
||||
;(debug (pffi-struct-get struct-test 'm))
|
||||
;(assert = (pffi-struct-get struct-test 'm) 13.0)
|
||||
;(debug (pffi-struct-get struct-test 'n))
|
||||
;(assert = (pffi-struct-get struct-test 'n) 14.0)
|
||||
;
|
||||
;;; pffi-struct-set! 1
|
||||
;
|
||||
;(print-header "pffi-struct-set! 1")
|
||||
;
|
||||
;(define-c-procedure c-test-check c-testlib 'test_check 'int '(pointer))
|
||||
;(pffi-define-struct struct-test-set1 'test_set1
|
||||
; '((int8 . a)
|
||||
; (char . b)
|
||||
; (double . c)
|
||||
; (char . d)
|
||||
; (pointer . e)
|
||||
; (float . f)
|
||||
; (pointer . g)
|
||||
; (int8 . h)
|
||||
; (pointer . i)
|
||||
; (int . j)
|
||||
; (int . k)
|
||||
; (int . l)
|
||||
; (double . m)
|
||||
; (float . n)))
|
||||
;(define struct-test1 (struct-test-set1))
|
||||
;(pffi-struct-set! struct-test1 'a 1)
|
||||
;(pffi-struct-set! struct-test1 'b #\b)
|
||||
;(pffi-struct-set! struct-test1 'c 3.0)
|
||||
;(pffi-struct-set! struct-test1 'd #\d)
|
||||
;(pffi-struct-set! struct-test1 'e (make-c-null))
|
||||
;(pffi-struct-set! struct-test1 'f 6.0)
|
||||
;(pffi-struct-set! struct-test1 'g (string->c-utf8 "foo"))
|
||||
;(pffi-struct-set! struct-test1 'h 8)
|
||||
;(pffi-struct-set! struct-test1 'i (make-c-null))
|
||||
;(pffi-struct-set! struct-test1 'j 10)
|
||||
;(pffi-struct-set! struct-test1 'k 11)
|
||||
;(pffi-struct-set! struct-test1 'l 12)
|
||||
;(pffi-struct-set! struct-test1 'm 13.0)
|
||||
;(pffi-struct-set! struct-test1 'n 14.0)
|
||||
;(c-test-check (pffi-struct-pointer struct-test1))
|
||||
|
||||
;; pffi-struct constructor with pointer
|
||||
|
||||
|
|
@ -794,31 +794,34 @@
|
|||
|
||||
; Array utilities
|
||||
|
||||
(print-header "Array utilities")
|
||||
|
||||
(define test-list1 (list 1 2 3))
|
||||
(debug test-list1)
|
||||
(debug (pffi-list->array 'int test-list1))
|
||||
(assert equal? (pffi-array->list (pffi-list->array 'int test-list1)) test-list1)
|
||||
|
||||
(define test-array1 (make-c-bytevector (* (c-size-of 'int) 3)))
|
||||
(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 0) 4)
|
||||
(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 1) 5)
|
||||
(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 2) 6)
|
||||
(debug test-array1)
|
||||
(debug (pffi-array->list (pffi-pointer->array test-array1 'int 3)))
|
||||
(define check-list1 (list 4 5 6))
|
||||
(assert equal? (pffi-array->list (pffi-pointer->array test-array1 'int 3)) check-list1)
|
||||
|
||||
(define test-array2 (pffi-array-allocate 'int 5))
|
||||
(debug (pffi-array->list test-array2))
|
||||
(assert equal? (pffi-array->list test-array2) (list 0 0 0 0 0))
|
||||
(pffi-array-set! test-array2 2 1)
|
||||
(debug (pffi-array->list test-array2))
|
||||
(assert equal? (pffi-array->list test-array2) (list 0 0 1 0 0))
|
||||
(assert = (pffi-array-get test-array2 1) 0)
|
||||
(assert = (pffi-array-get test-array2 2) 1)
|
||||
(assert = (pffi-array-get test-array2 3) 0)
|
||||
;(print-header "Array utilities")
|
||||
;
|
||||
;(define test-list1 (list 1 2 3))
|
||||
;(debug test-list1)
|
||||
;(debug (pffi-list->array 'int test-list1))
|
||||
;(assert equal? (pffi-array->list (pffi-list->array 'int test-list1)) test-list1)
|
||||
;
|
||||
;(define test-array1 (make-c-bytevector (* (c-size-of 'int) 3)))
|
||||
;;(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 0) 4)
|
||||
;(c-bytevector-s32-set! test-array1 0 4 (native-endianness))
|
||||
;;(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 1) 5)
|
||||
;(c-bytevector-s32-set! test-array1 1 5 (native-endianness))
|
||||
;;(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 2) 6)
|
||||
;(c-bytevector-s32-set! test-array1 2 6 (native-endianness))
|
||||
;(debug test-array1)
|
||||
;(define check-list1 (list 4 5 6))
|
||||
;(debug (pffi-array->list (pffi-pointer->array test-array1 'int 3)))
|
||||
;(assert equal? (pffi-array->list (pffi-pointer->array test-array1 'int 3)) check-list1)
|
||||
;
|
||||
;(define test-array2 (pffi-array-allocate 'int 5))
|
||||
;(debug (pffi-array->list test-array2))
|
||||
;(assert equal? (pffi-array->list test-array2) (list 0 0 0 0 0))
|
||||
;(pffi-array-set! test-array2 2 1)
|
||||
;(debug (pffi-array->list test-array2))
|
||||
;(assert equal? (pffi-array->list test-array2) (list 0 0 1 0 0))
|
||||
;(assert = (pffi-array-get test-array2 1) 0)
|
||||
;(assert = (pffi-array-get test-array2 2) 1)
|
||||
;(assert = (pffi-array-get test-array2 3) 0)
|
||||
|
||||
;; pffi-struct-dereference 1
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,285 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(test-util)
|
||||
(retropikzel pffi))
|
||||
|
||||
;; c-size-of
|
||||
|
||||
(print-header 'c-size-of)
|
||||
|
||||
(define size-int8 (c-size-of 'int8))
|
||||
(debug size-int8)
|
||||
(assert equal? (number? size-int8) #t)
|
||||
(assert = size-int8 1)
|
||||
|
||||
(define size-uint8 (c-size-of 'uint8))
|
||||
(debug size-uint8)
|
||||
(assert equal? (number? size-uint8) #t)
|
||||
(assert = size-uint8 1)
|
||||
|
||||
(assert equal? (number? (c-size-of 'uint8)) #t)
|
||||
(define size-int16 (c-size-of 'int16))
|
||||
(debug size-int16)
|
||||
(assert equal? (number? size-int16) #t)
|
||||
(assert = size-int16 2)
|
||||
|
||||
(assert equal? (number? (c-size-of 'int16)) #t)
|
||||
(define size-uint16 (c-size-of 'uint16))
|
||||
(debug size-uint16)
|
||||
(assert equal? (number? size-uint16) #t)
|
||||
(assert = size-uint16 2)
|
||||
|
||||
(assert equal? (number? (c-size-of 'uint16)) #t)
|
||||
(define size-int32 (c-size-of 'int32))
|
||||
(debug size-int32)
|
||||
(assert equal? (number? size-int32) #t)
|
||||
(assert = size-int32 4)
|
||||
|
||||
(assert equal? (number? (c-size-of 'int32)) #t)
|
||||
(define size-uint32 (c-size-of 'uint32))
|
||||
(debug size-uint32)
|
||||
(assert equal? (number? size-uint32) #t)
|
||||
(assert = size-uint32 4)
|
||||
|
||||
(assert equal? (number? (c-size-of 'uint32)) #t)
|
||||
(define size-int64 (c-size-of 'int64))
|
||||
(debug size-int64)
|
||||
(assert equal? (number? size-int64) #t)
|
||||
(assert = size-int64 8)
|
||||
|
||||
(assert equal? (number? (c-size-of 'int64)) #t)
|
||||
(define size-uint64 (c-size-of 'uint64))
|
||||
(debug size-uint64)
|
||||
(assert equal? (number? size-uint64) #t)
|
||||
(assert = size-uint64 8)
|
||||
|
||||
(assert equal? (number? (c-size-of 'uint64)) #t)
|
||||
(define size-char (c-size-of 'char))
|
||||
(debug size-char)
|
||||
(assert equal? (number? size-char) #t)
|
||||
(assert = size-char 1)
|
||||
|
||||
(assert equal? (number? (c-size-of 'char)) #t)
|
||||
(define size-unsigned-char (c-size-of 'unsigned-char))
|
||||
(debug size-unsigned-char)
|
||||
(assert equal? (number? size-unsigned-char) #t)
|
||||
(assert = size-unsigned-char 1)
|
||||
|
||||
(assert equal? (number? (c-size-of 'unsigned-char)) #t)
|
||||
(define size-short (c-size-of 'short))
|
||||
(debug size-short)
|
||||
(assert equal? (number? size-short) #t)
|
||||
(assert = size-short 2)
|
||||
|
||||
(assert equal? (number? (c-size-of 'short)) #t)
|
||||
(define size-unsigned-short (c-size-of 'unsigned-short))
|
||||
(debug size-unsigned-short)
|
||||
(assert equal? (number? size-unsigned-short) #t)
|
||||
(assert = size-unsigned-short 2)
|
||||
|
||||
(assert equal? (number? (c-size-of 'unsigned-short)) #t)
|
||||
(define size-int (c-size-of 'int))
|
||||
(debug size-int)
|
||||
(assert equal? (number? size-int) #t)
|
||||
(assert = size-int 4)
|
||||
|
||||
(assert equal? (number? (c-size-of 'int)) #t)
|
||||
(define size-unsigned-int (c-size-of 'unsigned-int))
|
||||
(debug size-unsigned-int)
|
||||
(assert equal? (number? size-unsigned-int) #t)
|
||||
(assert = size-unsigned-int 4)
|
||||
|
||||
(cond-expand
|
||||
(i386
|
||||
(assert equal? (number? (c-size-of 'long)) #t)
|
||||
(define size-long (c-size-of 'long))
|
||||
(debug size-long)
|
||||
(assert equal? (number? size-long) #t)
|
||||
(assert = size-long 4))
|
||||
(else
|
||||
(assert equal? (number? (c-size-of 'long)) #t)
|
||||
(define size-long (c-size-of 'long))
|
||||
(debug size-long)
|
||||
(assert equal? (number? size-long) #t)
|
||||
(assert = size-long 8)))
|
||||
|
||||
(cond-expand
|
||||
(i386
|
||||
(assert equal? (number? (c-size-of 'unsigned-long)) #t)
|
||||
(define size-unsigned-long (c-size-of 'unsigned-long))
|
||||
(debug size-unsigned-long)
|
||||
(assert equal? (number? size-unsigned-long) #t)
|
||||
(assert = size-unsigned-long 4))
|
||||
(else
|
||||
(assert equal? (number? (c-size-of 'long)) #t)
|
||||
(define size-unsigned-long (c-size-of 'unsigned-long))
|
||||
(debug size-unsigned-long)
|
||||
(assert equal? (number? size-unsigned-long) #t)
|
||||
(assert = size-unsigned-long 8)))
|
||||
|
||||
(assert equal? (number? (c-size-of 'float)) #t)
|
||||
(define size-float (c-size-of 'float))
|
||||
(debug size-float)
|
||||
(assert equal? (number? size-float) #t)
|
||||
(assert = size-float 4)
|
||||
|
||||
(assert equal? (number? (c-size-of 'double)) #t)
|
||||
(define size-double (c-size-of 'double))
|
||||
(debug size-double)
|
||||
(assert equal? (number? size-double) #t)
|
||||
(assert = size-double 8)
|
||||
|
||||
(cond-expand
|
||||
(i386
|
||||
(define size-pointer (c-size-of 'pointer))
|
||||
(debug size-pointer)
|
||||
(assert equal? (number? size-pointer) #t)
|
||||
(assert = size-pointer 4))
|
||||
(else
|
||||
(define size-pointer (c-size-of 'pointer))
|
||||
(debug size-pointer)
|
||||
(assert equal? (number? size-pointer) #t)
|
||||
(assert = size-pointer 8)))
|
||||
|
||||
;; define-c-library
|
||||
|
||||
(print-header 'pffi-define-library)
|
||||
|
||||
(cond-expand
|
||||
(windows (define-c-library libc-stdlib
|
||||
'("stdlib.h")
|
||||
"ucrtbase"
|
||||
'((additional-versions ("0" "6")))))
|
||||
(else (define-c-library libc-stdlib
|
||||
'("stdlib.h")
|
||||
"c"
|
||||
'((additional-versions ("0" "6"))))))
|
||||
|
||||
(debug libc-stdlib)
|
||||
|
||||
(cond-expand
|
||||
(windows (define-c-library libc-stdio
|
||||
'("stdio.h")
|
||||
"ucrtbase"
|
||||
'((additional-versions ("0" "6")))))
|
||||
(else (define-c-library libc-stdio
|
||||
'("stdio.h")
|
||||
"c"
|
||||
'((additional-versions ("0" "6"))))))
|
||||
|
||||
(debug libc-stdio)
|
||||
|
||||
(define-c-library c-testlib
|
||||
'("libtest.h")
|
||||
"test"
|
||||
'((additional-paths ("." "./tests"))))
|
||||
|
||||
(debug c-testlib)
|
||||
|
||||
;; define-c-procedure
|
||||
|
||||
(print-header 'define-c-procedure)
|
||||
|
||||
(define-c-procedure c-abs libc-stdlib 'abs 'int '(int))
|
||||
(debug c-abs)
|
||||
(define absoluted (c-abs -2))
|
||||
(debug absoluted)
|
||||
(assert = absoluted 2)
|
||||
|
||||
(define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer))
|
||||
(debug c-puts)
|
||||
(define chars-written (c-puts (string->c-utf8 "puts: Hello from testing, I am C function puts")))
|
||||
(debug chars-written)
|
||||
(assert = chars-written 47)
|
||||
|
||||
(define-c-procedure c-atoi libc-stdlib 'atoi 'int '(pointer))
|
||||
(assert = (c-atoi (string->c-utf8 "100")) 100)
|
||||
|
||||
(define-c-procedure c-fopen libc-stdio 'fopen 'pointer '(pointer pointer))
|
||||
(define output-file (c-fopen (string->c-utf8 "testfile.test")
|
||||
(string->c-utf8 "w")))
|
||||
(debug output-file)
|
||||
(define-c-procedure c-fprintf libc-stdio 'fprintf 'int '(pointer pointer))
|
||||
(define characters-written
|
||||
(c-fprintf output-file (string->c-utf8 "Hello world")))
|
||||
(debug characters-written)
|
||||
(assert equal? (= characters-written 11) #t)
|
||||
(define-c-procedure c-fclose libc-stdio 'fclose 'int '(pointer))
|
||||
(define closed-status (c-fclose output-file))
|
||||
(debug closed-status)
|
||||
(assert equal? (= closed-status 0) #t)
|
||||
(assert equal? (file-exists? "testfile.test") #t)
|
||||
(assert equal? (string=? (with-input-from-file "testfile.test"
|
||||
(lambda () (read-line)))
|
||||
"Hello world") #t)
|
||||
|
||||
(define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '())
|
||||
(debug c-takes-no-args)
|
||||
(c-takes-no-args)
|
||||
|
||||
(define-c-procedure c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '())
|
||||
(debug c-takes-no-args)
|
||||
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
|
||||
(assert equal? (= takes-no-args-returns-int-result 0) #t)
|
||||
|
||||
;; c-bytevector?
|
||||
|
||||
(print-header 'c-bytevector?)
|
||||
|
||||
(define is-pointer (make-c-bytevector 100))
|
||||
(debug is-pointer)
|
||||
(assert equal? (c-bytevector? is-pointer) #t)
|
||||
;(assert equal? (c-bytevector? 100) #f)
|
||||
(assert equal? (c-bytevector? 'bar) #f)
|
||||
|
||||
;; c-bytevector-u8-ref
|
||||
|
||||
(print-header "c-bytevector-u8-ref")
|
||||
|
||||
(define u8-pointer (make-c-bytevector (c-size-of 'uint8)))
|
||||
(c-bytevector-u8-set! u8-pointer 0 42)
|
||||
(debug u8-pointer)
|
||||
(debug (c-bytevector-u8-ref u8-pointer 0))
|
||||
(assert equal? (= (c-bytevector-u8-ref u8-pointer 0) 42) #t)
|
||||
|
||||
;; define-c-callback
|
||||
|
||||
(print-header 'define-c-callback)
|
||||
|
||||
(define array (make-c-bytevector (* (c-size-of 'int) 3)))
|
||||
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 0) 3)
|
||||
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2)
|
||||
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1)
|
||||
|
||||
(define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback))
|
||||
|
||||
(define-c-callback compare
|
||||
'int
|
||||
'(pointer pointer)
|
||||
(lambda (pointer-a pointer-b)
|
||||
(let ((a (c-bytevector-s32-native-ref pointer-a 0))
|
||||
(b (c-bytevector-s32-native-ref pointer-b 0)))
|
||||
(cond ((> a b) 1)
|
||||
((= a b) 0)
|
||||
((< a b) -1)))))
|
||||
(write compare)
|
||||
(newline)
|
||||
|
||||
(define unsorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
|
||||
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
|
||||
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
|
||||
(debug unsorted)
|
||||
(assert equal? unsorted (list 3 2 1))
|
||||
|
||||
(qsort array 3 (c-size-of 'int) compare)
|
||||
|
||||
(define sorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
|
||||
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
|
||||
(c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
|
||||
(debug sorted)
|
||||
(assert equal? sorted (list 1 2 3))
|
||||
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
(define header-count 1)
|
||||
|
||||
(define print-header
|
||||
(lambda (title)
|
||||
(set-tag title)
|
||||
(display "=========================================")
|
||||
(newline)
|
||||
(display header-count)
|
||||
(display " ")
|
||||
(display title)
|
||||
(newline)
|
||||
(display "=========================================")
|
||||
(newline)
|
||||
(set! header-count (+ header-count 1))))
|
||||
|
||||
(define count 0)
|
||||
(define assert-tag 'none)
|
||||
|
||||
(define set-tag
|
||||
(lambda (tag)
|
||||
(set! assert-tag tag)
|
||||
(set! count 0)))
|
||||
|
||||
(cond-expand
|
||||
(gambit
|
||||
(define assert
|
||||
(lambda (check value-a value-b)
|
||||
(let ((result (apply check (list value-a value-b))))
|
||||
(set! count (+ count 1))
|
||||
(if (not result) (display "FAIL ") (display "PASS "))
|
||||
(display "[")
|
||||
(display assert-tag)
|
||||
(display " - ")
|
||||
(display count)
|
||||
(display "]")
|
||||
(display ": ")
|
||||
(write (list 'check 'value-a 'value-b))
|
||||
(newline)
|
||||
(when (not result) (exit 1))))))
|
||||
(else
|
||||
(define-syntax assert
|
||||
(syntax-rules ()
|
||||
((_ check value-a value-b)
|
||||
(let ((result (apply check (list value-a value-b))))
|
||||
(set! count (+ count 1))
|
||||
(if (not result) (display "FAIL ") (display "PASS "))
|
||||
(display "[")
|
||||
(display assert-tag)
|
||||
(display " - ")
|
||||
(display count)
|
||||
(display "]")
|
||||
(display ": ")
|
||||
(write (list 'check 'value-a 'value-b))
|
||||
(newline)
|
||||
(when (not result) (exit 1))))))))
|
||||
|
||||
(define-syntax debug
|
||||
(syntax-rules ()
|
||||
((_ value)
|
||||
(begin
|
||||
(display 'value)
|
||||
(display ": ")
|
||||
(write value)
|
||||
(newline)))))
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
(define-library
|
||||
(test-util)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme process-context))
|
||||
(export print-header debug assert)
|
||||
(include "test-util.scm"))
|
||||
Loading…
Reference in New Issue