(define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) int) ((equal? type 'uint8) int) ((equal? type 'int16) int) ((equal? type 'uint16) int) ((equal? type 'int32) int) ((equal? type 'uint32) int) ((equal? type 'int64) int) ((equal? type 'uint64) int) ((equal? type 'char) char) ((equal? type 'unsigned-char) char) ((equal? type 'short) int) ((equal? type 'unsigned-short) int) ((equal? type 'int) int) ((equal? type 'unsigned-int) int) ((equal? type 'long) int) ((equal? type 'unsigned-long) int) ((equal? type 'float) float) ((equal? type 'double) double) ((equal? type 'pointer) opaque) ((equal? type 'void) c-void) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define pffi-pointer? (lambda (object) (error "Not defined"))) (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 'void) 'void) (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) `(c-define ,scheme-name ,return-type ,c-name) `(c-define ,scheme-name ,return-type ,c-name ,@ argument-types)))))) (define pffi-size-of (lambda (type) (cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int)) ((equal? type 'uint8) (c-value "sizeof(uint8_t)" int)) ((equal? type 'int16) (c-value "sizeof(int16_t)" int)) ((equal? type 'uint16) (c-value "sizeof(uint16_t)" int)) ((equal? type 'int32) (c-value "sizeof(int32_t)" int)) ((equal? type 'uint32) (c-value "sizeof(uint32_t)" int)) ((equal? type 'int64) (c-value "sizeof(int64_t)" int)) ((equal? type 'uint64) (c-value "sizeof(uint64_t)" int)) ((equal? type 'char) (c-value "sizeof(char)" int)) ((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int)) ((equal? type 'short) (c-value "sizeof(short)" int)) ((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int)) ((equal? type 'int) (c-value "sizeof(int)" int)) ((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int)) ((equal? type 'long) (c-value "sizeof(long)" int)) ((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int)) ((equal? type 'float) (c-value "sizeof(float)" int)) ((equal? type 'double) (c-value "sizeof(double)" int)) ((equal? type 'pointer) (c-value "sizeof(void*)" int)) (else (error "pffi-size-of -- No such pffi type" type))))) (define pffi-pointer-allocate (lambda (size) (error "Not defined"))) (define pffi-pointer-null (lambda () (error "Not defined"))) (define pffi-string->pointer (lambda (string-content) (error "Not defined") )) (define pffi-pointer->string (lambda (pointer) pointer)) (define-syntax pffi-shared-object-load (er-macro-transformer (lambda (expr rename compare) `(begin ,@ (map (lambda (header) `(include-c-header ,(string-append "<" header ">"))) (cdr (car (cdr expr)))))))) (define pffi-pointer-free (lambda (pointer) (error "Not defined"))) (define pffi-pointer-null? (lambda (pointer) (error "Not defined"))) (define pffi-pointer-set! (lambda (pointer type offset value) (let ((p pointer)) (error "Not defined")))) (define pffi-pointer-get (lambda (pointer type offset) (error "Not defined"))) (define pffi-pointer-deref (lambda (pointer) (error "Not defined"))) (define pffi-define-callback (lambda (scheme-name return-type argument-types procedure) (error "pffi-define-callback not yet implemented on Cyclone")))