302 lines
16 KiB
Scheme
302 lines
16 KiB
Scheme
(define-library
|
|
(retropikzel r7rs-pffi version chicken)
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme file)
|
|
(scheme process-context)
|
|
(chicken foreign)
|
|
(chicken locative)
|
|
(chicken syntax)
|
|
(chicken memory)
|
|
(chicken random))
|
|
(export pffi-shared-object-load
|
|
pffi-define
|
|
pffi-define-callback
|
|
pffi-size-of
|
|
pffi-pointer-allocate
|
|
pffi-pointer-null
|
|
pffi-string->pointer
|
|
pffi-pointer->string
|
|
pffi-pointer-free
|
|
pffi-pointer?
|
|
pffi-pointer-null?
|
|
pffi-pointer-set!
|
|
pffi-pointer-get
|
|
pffi-pointer-deref)
|
|
(begin
|
|
|
|
(define pffi-type->native-type
|
|
(lambda (type)
|
|
(cond ((equal? type 'int8) 'byte)
|
|
((equal? type 'uint8) 'unsigned-byte)
|
|
((equal? type 'int16) 'int16_t)
|
|
((equal? type 'uint16) 'uint16_t)
|
|
((equal? type 'int32) 'int32)
|
|
((equal? type 'uint32) 'unsigned-int32)
|
|
((equal? type 'int64) 'integer-64)
|
|
((equal? type 'uint64) 'unsigned-integer64)
|
|
((equal? type 'char) 'char)
|
|
((equal? type 'unsigned-char) 'unsigned-char)
|
|
((equal? type 'short) 'short)
|
|
((equal? type 'unsigned-short) 'unsigned-short)
|
|
((equal? type 'int) 'int)
|
|
((equal? type 'unsigned-int) 'unsigned-int)
|
|
((equal? type 'long) 'long)
|
|
((equal? type 'unsigned-long) 'unsigned-long)
|
|
((equal? type 'float) 'float)
|
|
((equal? type 'double) 'double)
|
|
((equal? type 'pointer) 'c-pointer)
|
|
((equal? type 'string) 'c-string)
|
|
((equal? type 'void) 'void)
|
|
((equal? type 'callback) 'c-pointer)
|
|
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
|
|
|
|
(define pffi-pointer?
|
|
(lambda (object)
|
|
(pointer? object)))
|
|
|
|
(define-syntax pffi-define
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let* ((pffi-type->native-type
|
|
(lambda (type)
|
|
(cond ((equal? type 'int8) 'byte)
|
|
((equal? type 'uint8) 'unsigned-byte)
|
|
((equal? type 'int16) 'int16_t)
|
|
((equal? type 'uint16) 'uint16_t)
|
|
((equal? type 'int32) 'int32)
|
|
((equal? type 'uint32) 'unsigned-int32)
|
|
((equal? type 'int64) 'integer-64)
|
|
((equal? type 'uint64) 'unsigned-integer64)
|
|
((equal? type 'char) 'char)
|
|
((equal? type 'unsigned-char) 'unsigned-char)
|
|
((equal? type 'short) 'short)
|
|
((equal? type 'unsigned-short) 'unsigned-short)
|
|
((equal? type 'int) 'int)
|
|
((equal? type 'unsigned-int) 'unsigned-int)
|
|
((equal? type 'long) 'long)
|
|
((equal? type 'unsigned-long) 'unsigned-long)
|
|
((equal? type 'float) 'float)
|
|
((equal? type 'double) 'double)
|
|
((equal? type 'pointer) 'c-pointer)
|
|
((equal? type 'string) 'c-string)
|
|
((equal? type 'void) 'void)
|
|
((equal? type 'callback) 'c-pointer)
|
|
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
|
(scheme-name (car (cdr expr)))
|
|
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
|
|
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
|
(argument-types
|
|
(let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
|
|
(if (null? types)
|
|
'()
|
|
(map pffi-type->native-type (map car (map cdr types)))))))
|
|
(if (null? argument-types)
|
|
`(define ,scheme-name
|
|
(foreign-safe-lambda ,return-type ,c-name))
|
|
`(define ,scheme-name
|
|
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
|
|
|
|
(define-syntax pffi-define-callback
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let* ((pffi-type->native-type
|
|
(lambda (type)
|
|
(cond ((equal? type 'int8) 'byte)
|
|
((equal? type 'uint8) 'unsigned-byte)
|
|
((equal? type 'int16) 'int16_t)
|
|
((equal? type 'uint16) 'uint16_t)
|
|
((equal? type 'int32) 'int32)
|
|
((equal? type 'uint32) 'unsigned-int32)
|
|
((equal? type 'int64) 'integer-64)
|
|
((equal? type 'uint64) 'unsigned-integer64)
|
|
((equal? type 'char) 'char)
|
|
((equal? type 'unsigned-char) 'unsigned-char)
|
|
((equal? type 'short) 'short)
|
|
((equal? type 'unsigned-short) 'unsigned-short)
|
|
((equal? type 'int) 'int)
|
|
((equal? type 'unsigned-int) 'unsigned-int)
|
|
((equal? type 'long) 'long)
|
|
((equal? type 'unsigned-long) 'unsigned-long)
|
|
((equal? type 'float) 'float)
|
|
((equal? type 'double) 'double)
|
|
((equal? type 'pointer) 'c-pointer)
|
|
((equal? type 'string) 'c-string)
|
|
((equal? type 'void) 'void)
|
|
((equal? type 'callback) 'c-pointer)
|
|
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
|
(scheme-name (car (cdr expr)))
|
|
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr)))))))
|
|
(argument-types
|
|
(let ((types (cdr (car (cdr (cdr (cdr expr)))))))
|
|
(if (null? types)
|
|
'()
|
|
(map pffi-type->native-type (map car (map cdr types))))))
|
|
(argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))
|
|
(arguments (map
|
|
(lambda (name type)
|
|
`(,name ,type))
|
|
argument-types argument-names))
|
|
(procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
|
|
`(begin (define-external ,(cons 'external_123456789 arguments)
|
|
,return-type
|
|
(begin ,@ procedure-body))
|
|
(define ,scheme-name (location external_123456789)))
|
|
))))
|
|
|
|
(define-syntax pffi-size-of-old
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let ((type (car (cdr (car (cdr expr))))))
|
|
(cond ((equal? type 'int8) `(foreign-value "sizeof(int8_t)" int))
|
|
((equal? type 'uint8) `(foreign-value "sizeof(uint8_t)" int))
|
|
((equal? type 'int16) `(foreign-value "sizeof(int16_t)" int))
|
|
((equal? type 'uint16) `(foreign-value "sizeof(uint16_t)" int))
|
|
((equal? type 'int32) `(foreign-value "sizeof(int32_t)" int))
|
|
((equal? type 'uint32) `(foreign-value "sizeof(uint32_t)" int))
|
|
((equal? type 'int64) `(foreign-value "sizeof(int64_t)" int))
|
|
((equal? type 'uint64) `(foreign-value "sizeof(uint64_t)" int))
|
|
((equal? type 'char) `(foreign-value "sizeof(char)" int))
|
|
((equal? type 'unsigned-char) `(foreign-value "sizeof(unsigned char)" int))
|
|
((equal? type 'short) `(foreign-value "sizeof(short)" int))
|
|
((equal? type 'unsigned-short) `(foreign-value "sizeof(unsigned short)" int))
|
|
((equal? type 'int) `(foreign-value "sizeof(int)" int))
|
|
((equal? type 'unsigned-int) `(foreign-value "sizeof(unsigned int)" int))
|
|
((equal? type 'long) `(foreign-value "sizeof(long)" int))
|
|
((equal? type 'unsigned-long) `(foreign-value "sizeof(unsigned long)" int))
|
|
((equal? type 'float) `(foreign-value "sizeof(float)" int))
|
|
((equal? type 'double) `(foreign-value "sizeof(double)" int))
|
|
((equal? type 'pointer) `(foreign-value "sizeof(void*)" int))
|
|
((equal? type 'string) `(foreign-value "sizeof(void*)" int))
|
|
(else `(error "pffi-size-of -- No such pffi type" type)))))))
|
|
|
|
(define pffi-size-of
|
|
(lambda (type)
|
|
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
|
|
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
|
|
((equal? type 'int16) (foreign-value "sizeof(int16_t)" int))
|
|
((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int))
|
|
((equal? type 'int32) (foreign-value "sizeof(int32_t)" int))
|
|
((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int))
|
|
((equal? type 'int64) (foreign-value "sizeof(int64_t)" int))
|
|
((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int))
|
|
((equal? type 'char) (foreign-value "sizeof(char)" int))
|
|
((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int))
|
|
((equal? type 'short) (foreign-value "sizeof(short)" int))
|
|
((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int))
|
|
((equal? type 'int) (foreign-value "sizeof(int)" int))
|
|
((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int))
|
|
((equal? type 'long) (foreign-value "sizeof(long)" int))
|
|
((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int))
|
|
((equal? type 'float) (foreign-value "sizeof(float)" int))
|
|
((equal? type 'double) (foreign-value "sizeof(double)" int))
|
|
((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
|
|
((equal? type 'string) (foreign-value "sizeof(void*)" int))
|
|
(else (error "pffi-size-of -- No such pffi type" type)))))
|
|
|
|
(define pffi-pointer-allocate
|
|
(lambda (size)
|
|
(allocate size)))
|
|
|
|
(define pffi-pointer-null
|
|
(lambda ()
|
|
(address->pointer 0)))
|
|
|
|
(define pffi-string->pointer-old
|
|
(lambda (string-content)
|
|
(let* ((size (+ (string-length string-content) 1))
|
|
(pointer (pffi-pointer-allocate size)))
|
|
(move-memory! string-content pointer (- size 1) 0)
|
|
pointer)))
|
|
|
|
(define pffi-string->pointer
|
|
(lambda (string-content)
|
|
(location string-content)))
|
|
|
|
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
|
|
|
(define pffi-pointer->string
|
|
(lambda (pointer)
|
|
(write pointer)
|
|
(newline)
|
|
(cond ((string? pointer) pointer)
|
|
((locative? pointer) (locative->object pointer))
|
|
((pffi-pointer? pointer)
|
|
(let* ((size (strlen pointer))
|
|
(string-content (make-string size)))
|
|
(move-memory! pointer string-content size 0)
|
|
string-content))
|
|
(error "Argument not pointer or string" pointer))))
|
|
|
|
(define-syntax pffi-shared-object-load
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let* ((headers (cdr (car (cdr expr)))))
|
|
`(begin
|
|
,@ (map
|
|
(lambda (header)
|
|
`(foreign-declare ,(string-append "#include <" header ">")))
|
|
headers))))))
|
|
|
|
(define pffi-pointer-free
|
|
(lambda (pointer)
|
|
(if (not (pointer? pointer))
|
|
(error "pffi-pointer-free -- Argument is not pointer" pointer))
|
|
(free pointer)))
|
|
|
|
(define pffi-pointer-null?
|
|
(lambda (pointer)
|
|
(if (not (pointer? pointer))
|
|
(error "pffi-pointer-null? -- Argument is not pointer" pointer))
|
|
(= (pointer->address pointer) 0)))
|
|
|
|
(define pffi-pointer-set!
|
|
(lambda (pointer type offset value)
|
|
(cond
|
|
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
|
|
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
|
|
((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
|
|
((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
|
|
((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
|
|
((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
|
|
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) value))
|
|
((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value))
|
|
((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
|
|
((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value))
|
|
((equal? type 'pointer) (pointer-s8-set! (pointer+ pointer offset) value))
|
|
((equal? type 'string) (pffi-pointer-set! pointer type offset (pffi-string->pointer value))))))
|
|
|
|
(define pffi-pointer-get
|
|
(lambda (pointer type offset)
|
|
(cond
|
|
((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
|
|
((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))
|
|
((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset)))
|
|
((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset)))
|
|
((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset)))
|
|
((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
|
|
((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
|
|
((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
|
|
((equal? type 'char) (pointer-s8-ref (pointer+ pointer offset)))
|
|
((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset)))
|
|
((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
|
|
((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
|
|
((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset)))
|
|
((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset)))
|
|
((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
|
|
((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset)))
|
|
((equal? type 'double) (pointer-s8-ref (pointer+ pointer offset)))
|
|
((equal? type 'pointer) (pointer->address (pointer+ pointer offset)))
|
|
((equal? type 'string) (pffi-pointer->string (pffi-pointer-get pointer 'pointer offset))))))
|
|
|
|
(define pffi-pointer-deref
|
|
(lambda (pointer)
|
|
pointer))))
|