(define pffi-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 'struct) :void) (else (error "pffi-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 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 pffi-define-callback (lambda () (error "Not implemented"))) ; 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! pointer-set-c-uint8_t!) (define c-bytevector-u8-ref pointer-ref-c-uint8_t) (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)))))