380 lines
18 KiB
Scheme
380 lines
18 KiB
Scheme
(define pffi-init (lambda () #t))
|
|
|
|
(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)
|
|
(opaque? 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 '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-define-callback
|
|
(lambda (scheme-name return-type argument-types procedure)
|
|
(error "pffi-define-callback not yet implemented on Cyclone")))
|
|
|
|
(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-c pffi-pointer-allocate
|
|
"(void *data, int argc, closure _, object k, object size)"
|
|
"make_c_opaque(opq, malloc(obj_obj2int(size)));
|
|
return_closcall1(data, k, &opq);")
|
|
|
|
(define pffi-pointer-null
|
|
(lambda ()
|
|
(make-opaque)))
|
|
|
|
(define-c pffi-string->pointer
|
|
"(void *data, int argc, closure _, object k, object s)"
|
|
"make_c_opaque(opq, string_str(s));
|
|
return_closcall1(data, k, &opq);")
|
|
|
|
(define-c pffi-pointer->string
|
|
"(void *data, int argc, closure _, object k, object p)"
|
|
"make_string(s, opaque_ptr(p));
|
|
return_closcall1(data, k, &s);")
|
|
|
|
(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-c pffi-pointer-free
|
|
"(void *data, int argc, closure _, object k, object pointer)"
|
|
"free(opaque_ptr(pointer));
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define pffi-pointer-null?
|
|
(lambda (pointer)
|
|
(and (opaque? pointer)
|
|
(opaque-null? pointer))))
|
|
|
|
(define-c pffi-pointer-int8-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-uint8-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-int16-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-uint16-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-int32-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-uint32-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-int64-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-uint64-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-char-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2char(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-short-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-unsigned-short-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-int-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-unsigned-int-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-long-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-unsigned-long-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = obj_obj2int(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-float-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"float* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = double_value(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-double-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"double* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = double_value(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define-c pffi-pointer-pointer-set!
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
|
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
*p = &opaque_ptr(value);
|
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
|
|
|
(define pffi-pointer-set!
|
|
(lambda (pointer type offset value)
|
|
(cond
|
|
((equal? type 'int8) (pffi-pointer-int8-set! pointer offset value))
|
|
((equal? type 'uint8) (pffi-pointer-uint8-set! pointer offset value))
|
|
((equal? type 'int16) (pffi-pointer-int16-set! pointer offset value))
|
|
((equal? type 'uint16) (pffi-pointer-uint16-set! pointer offset value))
|
|
((equal? type 'int32) (pffi-pointer-int32-set! pointer offset value))
|
|
((equal? type 'uint32) (pffi-pointer-uint32-set! pointer offset value))
|
|
((equal? type 'int64) (pffi-pointer-int64-set! pointer offset value))
|
|
((equal? type 'uint64) (pffi-pointer-uint64-set! pointer offset value))
|
|
((equal? type 'char) (pffi-pointer-char-set! pointer offset value))
|
|
((equal? type 'short) (pffi-pointer-short-set! pointer offset value))
|
|
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-set! pointer offset value))
|
|
((equal? type 'int) (pffi-pointer-int-set! pointer offset value))
|
|
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-set! pointer offset value))
|
|
((equal? type 'long) (pffi-pointer-long-set! pointer offset value))
|
|
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-set! pointer offset value))
|
|
((equal? type 'float) (pffi-pointer-float-set! pointer offset value))
|
|
((equal? type 'double) (pffi-pointer-double-set! pointer offset value))
|
|
((equal? type 'pointer) (pffi-pointer-pointer-set! pointer offset value))
|
|
)))
|
|
|
|
(define-c pffi-pointer-int8-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-uint8-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-int16-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-uint16-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-int32-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-uint32-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-int64-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-uint64-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-char-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_char2obj(*p));")
|
|
|
|
(define-c pffi-pointer-short-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-unsigned-short-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-int-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-unsigned-int-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-long-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-unsigned-long-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
return_closcall1(data, k, obj_int2obj(*p));")
|
|
|
|
(define-c pffi-pointer-float-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"float* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
alloca_double(d, *p);
|
|
return_closcall1(data, k, d);")
|
|
|
|
(define-c pffi-pointer-double-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"double* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
|
alloca_double(d, *p);
|
|
return_closcall1(data, k, d);")
|
|
|
|
(define-c pffi-pointer-pointer-get
|
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
|
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
|
|
return_closcall1(data, k, &opq);")
|
|
|
|
(define pffi-pointer-get
|
|
(lambda (pointer type offset)
|
|
(cond
|
|
((equal? type 'int8) (pffi-pointer-int8-get pointer offset))
|
|
((equal? type 'uint8) (pffi-pointer-uint8-get pointer offset))
|
|
((equal? type 'int16) (pffi-pointer-int16-get pointer offset))
|
|
((equal? type 'uint16) (pffi-pointer-uint16-get pointer offset))
|
|
((equal? type 'int32) (pffi-pointer-int32-get pointer offset))
|
|
((equal? type 'uint32) (pffi-pointer-uint32-get pointer offset))
|
|
((equal? type 'int64) (pffi-pointer-int64-get pointer offset))
|
|
((equal? type 'uint64) (pffi-pointer-uint64-get pointer offset))
|
|
((equal? type 'char) (pffi-pointer-char-get pointer offset))
|
|
((equal? type 'short) (pffi-pointer-short-get pointer offset))
|
|
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-get pointer offset))
|
|
((equal? type 'int) (pffi-pointer-int-get pointer offset))
|
|
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-get pointer offset))
|
|
((equal? type 'long) (pffi-pointer-long-get pointer offset))
|
|
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-get pointer offset))
|
|
((equal? type 'float) (pffi-pointer-float-get pointer offset))
|
|
((equal? type 'double) (pffi-pointer-double-get pointer offset))
|
|
((equal? type 'pointer) (pffi-pointer-pointer-get pointer offset))
|
|
)))
|