144 lines
6.7 KiB
Scheme
144 lines
6.7 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! cpointer-set-uint8_t!)
|
|
(define c-bytevector-u8-ref cpointer-ref-uint8_t)
|
|
(define c-bytevector-pointer-set! cpointer-set-pointer!)
|
|
(define c-bytevector-pointer-ref cpointer-ref-pointer)
|
|
|
|
#;(define pffi-pointer-set!
|
|
(lambda (pointer type offset value)
|
|
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
|
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
|
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
|
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
|
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
|
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
|
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
|
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
|
((equal? type 'char) (pointer-set-c-char! pointer offset value))
|
|
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
|
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
|
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
|
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
|
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
|
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
|
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
|
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
|
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
|
|
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
|
|
|
#;(define pffi-pointer-get
|
|
(lambda (pointer type offset)
|
|
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
|
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
|
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
|
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
|
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
|
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
|
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
|
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
|
((equal? type 'char) (pointer-ref-c-char pointer offset))
|
|
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
|
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
|
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
|
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
|
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
|
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
|
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
|
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
|
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
|
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|