170 lines
6.7 KiB
Scheme
170 lines
6.7 KiB
Scheme
(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 pffi-pointer?
|
|
(lambda (object)
|
|
(display "HERE: ")
|
|
(write object)
|
|
(newline)
|
|
(write (cpointer? object))
|
|
(newline)
|
|
(cpointer? object)))
|
|
|
|
(define-syntax pffi-define-function
|
|
(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 pffi-pointer-allocate
|
|
(lambda (size)
|
|
(allocate-bytes size)))
|
|
|
|
;; FIXME
|
|
(define pffi-pointer-address
|
|
(lambda (pointer)
|
|
0))
|
|
|
|
;; FIXME
|
|
(define pffi-pointer-null
|
|
(lambda ()
|
|
(let ((p (allocate-bytes 0)))
|
|
(free-bytes p)
|
|
p)))
|
|
|
|
#;(define pffi-pointer-free
|
|
(lambda (pointer)
|
|
(free-bytes pointer)))
|
|
|
|
(define pffi-pointer-null?
|
|
(lambda (pointer)
|
|
(and (cpointer? pointer)
|
|
(cpointer-null? 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)))))
|