111 lines
3.9 KiB
Scheme
111 lines
3.9 KiB
Scheme
(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 c-bytevector?
|
|
(lambda (object)
|
|
(cpointer? object)))
|
|
|
|
(define-syntax define-c-procedure
|
|
(syntax-rules ()
|
|
((_ scheme-name shared-object c-name return-type argument-types)
|
|
(begin
|
|
(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) :char)
|
|
((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-syntax define-c-callback
|
|
(syntax-rules ()
|
|
((_ scheme-name return-type argument-types procedure)
|
|
(define scheme-name
|
|
(%make-callback procedure
|
|
(map type->native-type argument-types)
|
|
(type->native-type return-type))))))
|
|
|
|
; FIXME
|
|
(define size-of-type
|
|
(lambda (type)
|
|
(cond ((equal? type 'int8) 1)
|
|
((equal? type 'uint8) 1)
|
|
((equal? type 'int16) 2)
|
|
((equal? type 'uint16) 2)
|
|
((equal? type 'int32) 4)
|
|
((equal? type 'uint32) 4)
|
|
((equal? type 'int64) 8)
|
|
((equal? type 'uint64) 8)
|
|
((equal? type 'char) 1)
|
|
((equal? type 'unsigned-char) 1)
|
|
((equal? type 'short) 2)
|
|
((equal? type 'unsigned-short) 2)
|
|
((equal? type 'int) 4)
|
|
((equal? type 'unsigned-int) 4)
|
|
((equal? type 'long) 8)
|
|
((equal? type 'unsigned-long) 8)
|
|
((equal? type 'float) 4)
|
|
((equal? type 'double) 8)
|
|
((equal? type 'pointer) 8))))
|
|
|
|
(define c-bytevector-u8-set!
|
|
(lambda (pointer offset value)
|
|
(cpointer-set! pointer :uint8 value offset)))
|
|
|
|
(define c-bytevector-u8-ref
|
|
(lambda (pointer offset)
|
|
(cpointer-ref pointer :uint8 offset)))
|
|
|
|
(define c-bytevector-pointer-set!
|
|
(lambda (pointer offset value)
|
|
(cpointer-set! pointer :pointer value offset)))
|
|
|
|
(define c-bytevector-pointer-ref
|
|
(lambda (pointer offset)
|
|
(cpointer-ref pointer :pointer offset)))
|