140 lines
5.4 KiB
Scheme
140 lines
5.4 KiB
Scheme
(define foreign-c:string-split
|
|
(lambda (str mark)
|
|
(let* ((str-l (string->list str))
|
|
(res (list))
|
|
(last-index 0)
|
|
(index 0)
|
|
(splitter (lambda (c)
|
|
(cond ((char=? c mark)
|
|
(begin
|
|
(set! res (append res (list (string-copy str last-index index))))
|
|
(set! last-index (+ index 1))))
|
|
((equal? (length str-l) (+ index 1))
|
|
(set! res (append res (list (string-copy str last-index (+ index 1)))))))
|
|
(set! index (+ index 1)))))
|
|
(for-each splitter str-l)
|
|
res)))
|
|
|
|
(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)
|
|
(and (not (void? 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))))))
|
|
|
|
(define size-of-type
|
|
(lambda (type)
|
|
(cond ((equal? type 'int8) (c-size-of :int8))
|
|
((equal? type 'uint8) (c-size-of :uint8))
|
|
((equal? type 'int16) (c-size-of :int16))
|
|
((equal? type 'uint16) (c-size-of :uint16))
|
|
((equal? type 'int32) (c-size-of :int32))
|
|
((equal? type 'uint32) (c-size-of :uint32))
|
|
((equal? type 'int64) (c-size-of :int64))
|
|
((equal? type 'uint64) (c-size-of :uint64))
|
|
((equal? type 'char) (c-size-of :char))
|
|
((equal? type 'unsigned-char) (c-size-of :uchar))
|
|
((equal? type 'short) (c-size-of :short))
|
|
((equal? type 'unsigned-short) (c-size-of :ushort))
|
|
((equal? type 'int) (c-size-of :int))
|
|
((equal? type 'unsigned-int) (c-size-of :uint))
|
|
((equal? type 'long) (c-size-of :long))
|
|
((equal? type 'unsigned-long) (c-size-of :ulong))
|
|
((equal? type 'float) (c-size-of :float))
|
|
((equal? type 'double) (c-size-of :double))
|
|
((equal? type 'pointer) (c-size-of :pointer)))))
|
|
|
|
;; FIXME
|
|
(define align-of-type
|
|
(lambda (type)
|
|
(size-of-type type)))
|
|
|
|
(define c-bytevector-u8-set!
|
|
(lambda (pointer offset value)
|
|
(cpointer-set-abs! pointer :uint8 value offset)))
|
|
|
|
(define c-bytevector-u8-ref
|
|
(lambda (pointer offset)
|
|
(cpointer-ref-abs pointer :uint8 offset)))
|
|
|
|
(define c-bytevector-pointer-set!
|
|
(lambda (pointer offset value)
|
|
(cpointer-set-abs! pointer :pointer value offset)))
|
|
|
|
(define c-bytevector-pointer-ref
|
|
(lambda (pointer offset)
|
|
(cpointer-ref-abs pointer :pointer offset)))
|
|
|
|
#;(define c-bytevector-pointer-ref
|
|
(lambda (c-bytevector k)
|
|
(address->c-bytevector (c-bytevector-uint-ref c-bytevector
|
|
0
|
|
(native-endianness)
|
|
(size-of-type 'pointer)))))
|