Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Progress on Chibi

This commit is contained in:
retropikzel 2025-04-27 15:54:46 +03:00
parent 7789dfdd48
commit 1f9732020a
20 changed files with 453 additions and 375 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
README.md
View File

@ -15,18 +15,18 @@ The new readme is a work in progress.
## Primitives
| | c-size-of | define-c-library | c-bytevector? | define-c-procedure | define-c-callbck | c-bytevector-u8-ref |
|------------------|:------------:|:-------------------:|:-------------:|:-------------------:|:----------------:|:-------------------:|
| Chibi | X | X | X | X | | X |
| **Chicken** | X | X | X | X | X | X |
| Gauche | X | X | X | X | | |
| **Guile** | X | X | X | X | X | X |
| Kawa | X | X | X | X | | X |
| **Mosh** | X | X | X | X | X | X |
| **Racket** | X | X | X | X | X | X |
| **Saggittarius** | X | X | X | X | X | X |
| Stklos | X | X | X | X | | X |
| **Ypsilon** | X | X | X | X | X | X |
| | c-size-of | c-bytevector-u8-set! |c-bytevector-u8-ref | define-c-library | c-bytevector? | define-c-procedure | define-c-callback |
|------------------|:------------:|:------------------- :|-------------------:|:-------------------:|:-------------:|:-------------------:|:-----------------:|
| Chibi | X | X |X | X | X | X | |
| **Chicken** | X | X |X | X | X | X | X |
| Gauche | X | X |X | X | X | X | |
| **Guile** | X | X |X | X | X | X | X |
| Kawa | X | X |X | X | X | X | |
| **Mosh** | X | X |X | X | X | X | X |
| **Racket** | X | X |X | X | X | X | X |
| **Saggittarius** | X | X |X | X | X | X | X |
| Stklos | X | X |X | X | X | X | |
| **Ypsilon** | X | X |X | X | X | X | X |
## Test files pass
@ -36,7 +36,7 @@ The new readme is a work in progress.
| **Chicken** | X | X |
| Gauche | | |
| **Guile** | X | X |
| Kawa | | X |
| Kawa | | |
| Mosh | X | |
| Racket | X | |
| **Saggittarius** | X | X |

9
foreign/c.sld
View File

@ -132,7 +132,7 @@
(scheme inexact)
(scheme process-context)
(only (stklos)
make-external-function
%make-callback
allocate-bytes
free-bytes
cpointer?
@ -176,10 +176,9 @@
pointer-set-c-pointer!
pointer-ref-c-pointer
void?))
(export make-external-function
; calculate-struct-size-and-offsets
(export ; calculate-struct-size-and-offsets
;struct-make
pffi:string-split
foreign-c:string-split
c-bytevector-pointer-set!
c-bytevector-pointer-ref))
#;(tr7
@ -208,8 +207,6 @@
c-bytevector-u8-ref
;; c-bytevector
;pffi-pointer-set!;c-bytevector-u8-set! and so on
;pffi-pointer-get;c-bytevector-u8-ref and so on
native-endianness
;; TODO Docs for all of these
c-bytevector->address

73
foreign/c/main.scm
View File

@ -1,57 +1,8 @@
#;(cond-expand
(mosh (define pffi-init (lambda () #t)))
(chicken
(define-syntax pffi-init
(er-macro-transformer
(lambda (expr rename compare)
'(import (chicken foreign)
(chicken memory))
#t))))
(gambit #t)
#;(ypsilon
(define-syntax pffi-init
(syntax-rules ()
((_)
(import (ypsilon ffi)
(ypsilon c-types))))))
(else (define pffi-init (lambda () #t))))
(define pffi-type?
(lambda (object)
(if (equal? (size-of-type object) #f)
#f
#t)))
(define c-size-of
(lambda (object)
(size-of-type object)
#;(cond ((pffi-struct? object) (pffi-struct-size object))
((pffi-type? object) (size-of-type object))
(else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))
(size-of-type object)))
(define pffi-types
'(int8
uint8
int16
uint16
int32
uint32
int64
uint64
char
unsigned-char
short
unsigned-short
int
unsigned-int
long
unsigned-long
float
double
pointer
void))
(define pffi:string-split
(define foreign-c:string-split
(lambda (str mark)
(let* ((str-l (string->list str))
(res (list))
@ -69,9 +20,9 @@
res)))
(cond-expand
(gambit #t) ; Defined in pffi/gambit.scm
(chicken #t) ; Defined in pffi/chicken.scm
(cyclone #t) ; Defined in pffi/cyclone.scm
(gambit #t) ; Defined in gambit.scm
(chicken #t) ; Defined in chicken.scm
(cyclone #t) ; Defined in cyclone.scm
(else
(define-syntax define-c-library
(syntax-rules ()
@ -95,8 +46,8 @@
(cond-expand
(windows
(append
(if (get-environment-variable "PFFI_LOAD_PATH")
(pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\;)
(if (get-environment-variable "FOREIGN_C_LOAD_PATH")
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\;)
(list))
(if (get-environment-variable "SYSTEM")
(list (get-environment-variable "SYSTEM"))
@ -115,15 +66,15 @@
(list))
(list ".")
(if (get-environment-variable "PATH")
(pffi:string-split (get-environment-variable "PATH") #\;)
(foreign-c:string-split (get-environment-variable "PATH") #\;)
(list))
(if (get-environment-variable "PWD")
(list (get-environment-variable "PWD"))
(list))))
(else
(append
(if (get-environment-variable "PFFI_LOAD_PATH")
(pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\:)
(if (get-environment-variable "FOREIGN_C_LOAD_PATH")
(foreign-c:string-split (get-environment-variable "FOREIGN_C_LOAD_PATH") #\:)
(list))
; Guix
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
@ -132,7 +83,7 @@
"/run/current-system/profile/lib")
; Debian
(if (get-environment-variable "LD_LIBRARY_PATH")
(pffi:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
(foreign-c:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
(list))
(list
;;; x86-64
@ -207,5 +158,5 @@
(exit 1))
(cond-expand
(stklos shared-object)
(else (pffi-shared-object-load shared-object
(else (shared-object-load shared-object
`((additional-versions ,additional-versions)))))))))))))

15
foreign/c/pointer.scm
View File

@ -8,7 +8,7 @@
"c"
'((additional-versions ("0" "6"))))))
(define-c-procedure pffi-pointer-allocate-calloc libc 'calloc 'pointer '(int int))
(define-c-procedure c-calloc libc 'calloc 'pointer '(int int))
(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int))
(define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int))
(define-c-procedure c-memset-address libc 'memset 'pointer '(uint64 uint8 int))
@ -17,7 +17,7 @@
(define-c-procedure c-strlen libc 'strlen 'int '(pointer))
(cond-expand
(chibi #t) ; FIXME
;(chibi #t) ; FIXME
(else (define make-c-bytevector
(lambda (k . byte)
(if (null? byte)
@ -29,7 +29,6 @@
(bytevector->c-bytevector (apply bytevector bytes))))
(cond-expand
(chibi #t) ; FIXME
(else (define-c-procedure c-free libc 'free 'void '(pointer))))
(define bytevector->c-bytevector
@ -112,16 +111,18 @@
(native-endianness)
(c-size-of 'pointer)))))
(cond-expand
#;(cond-expand
(kawa #t) ; Defined in kawa.scm
(chibi #t)
(else
(define c-bytevector-u8-set!
(lambda (c-bytevector k byte)
(let ((address (c-memset-pointer->address c-bytevector 0 0)))
(c-memset-address (+ address k) byte 1))))))
(c-memset-address (+ (c-memset-pointer->address c-bytevector 0 0) k)
byte
1)))))
(cond-expand
(kawa #t) ; Defined in kawa.scm
;(kawa #t) ; Defined in kawa.scm
(else (define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)

91
foreign/c/primitives/chibi.scm
View File

@ -19,39 +19,30 @@
((eq? type 'float) (size-of-float))
((eq? type 'double) (size-of-double))
((eq? type 'pointer) (size-of-pointer))
((eq? type 'string) (size-of-pointer))
((eq? type 'struct) (size-of-pointer))
((eq? type 'pointer-address) (size-of-pointer))
((eq? type 'callback) (size-of-pointer))
((eq? type 'void) 0)
(else #f))))
(define pffi-shared-object-load
(define shared-object-load
(lambda (path options)
(let ((shared-object (dlopen path RTLD-NOW))
(maybe-error (dlerror)))
#;(when (not (pffi-pointer-null? maybe-error))
(error (c-bytevector->string maybe-error)))
shared-object)))
(define c-bytevector?
(lambda (object)
(or (equal? object #f) ; False can be null pointer
(pointer? object))))
(pointer? object))))
(define make-c-bytevector
(lambda (k . byte)
(if (null? byte)
(pointer-allocate k)
(bytevector->c-bytevector (make-bytevector k byte)))))
(define c-free
(lambda (pointer)
(pointer-free pointer)))
#;(define c-free
(lambda (pointer)
(pointer-free pointer)))
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define pffi-pointer-set!
(define 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))
@ -73,7 +64,7 @@
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get
(define 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))
@ -116,14 +107,14 @@
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) '(maybe-null void*))
((equal? type 'string) 'string)
((equal? type 'pointer-address) '(maybe-null void*))
((equal? type 'void) 'void)
((equal? type 'callback) '(maybe-null void*))
(else (error "pffi-type->native-type -- No such pffi type" type)))))
;; define-c-procedure
(define pffi-type->libffi-type
#;(define type->libffi-type
(lambda (type)
(cond ((equal? type 'int8) (get-ffi-type-int8))
((equal? type 'uint8) (get-ffi-type-uint8))
@ -146,13 +137,40 @@
((equal? type 'double) (get-ffi-type-double))
((equal? type 'void) (get-ffi-type-void))
((equal? type 'pointer) (get-ffi-type-pointer))
((equal? type 'pointer-address) 1)
((equal? type 'callback) (get-ffi-type-pointer)))))
(define argument->pointer
(define type->libffi-type
(lambda (type)
(cond ((equal? type 'int8) 1)
((equal? type 'uint8) 2)
((equal? type 'int16) 3)
((equal? type 'uint16) 4)
((equal? type 'int32) 5)
((equal? type 'uint32) 6)
((equal? type 'int64) 7)
((equal? type 'uint64) 8)
((equal? type 'char) 9)
((equal? type 'unsigned-char) 10)
((equal? type 'short) 11)
((equal? type 'unsigned-short) 12)
((equal? type 'int) 13)
((equal? type 'unsigned-int) 14)
((equal? type 'long) 15)
((equal? type 'unsigned-long) 16)
((equal? type 'float) 17)
((equal? type 'double) 18)
((equal? type 'void) 19)
((equal? type 'pointer) 20)
((equal? type 'pointer-address) 21)
((equal? type 'callback) 22)
(else (error "Undefined type" type)))))
#;(define argument->pointer
(lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (make-c-bytevector (size-of-type type))))
(pffi-pointer-set! pointer type 0 value)
(else (let ((pointer (pointer-allocate (size-of-type type))))
(pointer-set! pointer type 0 value)
pointer)))))
(define make-c-function
@ -160,23 +178,16 @@
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
#;(when (not (pffi-pointer-null? maybe-dlerror))
(error (c-bytevector->string maybe-dlerror)))
(lambda arguments
(let ((return-value (make-c-bytevector
(if (equal? return-type 'void)
0
(size-of-type return-type)))))
(internal-ffi-call (length argument-types)
(pffi-type->libffi-type return-type)
(map pffi-type->libffi-type argument-types)
c-function
return-value
(map argument->pointer
arguments
argument-types))
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
(let* ((return-pointer
(internal-ffi-call (length argument-types)
(type->libffi-type return-type)
(map type->libffi-type argument-types)
c-function
(c-size-of return-type)
arguments)))
(when (not (equal? return-type 'void))
(pointer-get return-pointer return-type 0)))))))
(define-syntax define-c-procedure
(syntax-rules ()
@ -191,7 +202,7 @@
(lambda (return-type argument-types procedure)
(scheme-procedure-to-pointer procedure)))
(define-syntax pffi-define-callback
(define-syntax define-c-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name

113
foreign/c/primitives/chibi/foreign-c.stub
View File

@ -2,6 +2,7 @@
(c-system-include "stdint.h")
(c-system-include "dlfcn.h")
(c-system-include "stdio.h")
(c-system-include "ffi.h")
;; c-size-of
@ -47,7 +48,7 @@
(define-c int (size-of-double size_of_double) ())
(define-c int (size-of-pointer size_of_pointer) ())
;; pffi-shared-object-load
;; shared-object-load
(define-c-const int (RTLD-NOW "RTLD_NOW"))
(define-c (maybe-null pointer void*) dlopen (string int))
(define-c (maybe-null pointer void*) dlerror ())
@ -71,14 +72,14 @@
(define-c sexp (pointer? is_pointer) (sexp))
(c-declare "void* pointer_address(struct sexp_struct* pointer) {
return (void*)&sexp_cpointer_value(pointer);
return &sexp_cpointer_value(pointer);
}")
(define-c (maybe-null pointer void*) (pointer-address pointer_address) (sexp))
(c-declare "void pointer_free(void* pointer) { free(pointer); }")
(define-c void (pointer-free pointer_free) ((maybe-null pointer void*)))
;; pffi-pointer-set!
;; pointer-set!
(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }")
(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t))
(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
@ -128,7 +129,7 @@
(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*)))
;; pffi-pointer-get
;; pointer-get
(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int))
(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }")
@ -237,28 +238,114 @@
(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ())
(define-c-const int (FFI-OK "FFI_OK"))
(c-declare
#;(c-declare
"int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) {
printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs);
return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
}")
(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*)))
;(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*)))
(c-declare
"void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, struct sexp_struct* avalues[]) {
ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
"void* internal_ffi_call(
unsigned int nargs,
unsigned int rtype,
unsigned int atypes[],
void* fn,
unsigned int rvalue_size,
struct sexp_struct* avalues[])
{
ffi_type* c_atypes[nargs];
void* temps[nargs];
void* c_avalues[nargs];
for(int i = 0; i < nargs; i++) {
c_avalues[i] = sexp_cpointer_value(avalues[i]);
void* arg = NULL;
switch(atypes[i]) {
//case 1: c_atypes[i] = &ffi_type_sint8; arg = sexp_sint_value(avalues[i]); break;
case 2:
c_atypes[i] = &ffi_type_uint8;
temps[i] = sexp_uint_value(avalues[i]);
c_avalues[i] = &temps[i];
break;
//case 3: c_atypes[i] = &ffi_type_sint16; arg = sexp_sint_value(avalues[i]); break;
//case 4: c_atypes[i] = &ffi_type_uint16; arg = sexp_uint_value(avalues[i]); break;
//case 5: c_atypes[i] = &ffi_type_sint32; arg = sexp_sint_value(avalues[i]); break;
//case 6: c_atypes[i] = &ffi_type_uint32; arg = sexp_uint_value(avalues[i]); break;
//case 7: c_atypes[i] = &ffi_type_sint64; arg = sexp_sint_value(avalues[i]); break;
case 8:
c_atypes[i] = &ffi_type_uint64;
temps[i] = sexp_uint_value(avalues[i]);
c_avalues[i] = &temps[i];
break;
//case 9: c_atypes[i] = &ffi_type_schar; arg = sexp_sint_value(avalues[i]); break;
//case 10: c_atypes[i] = &ffi_type_uchar; arg = sexp_uint_value(avalues[i]); break;
//case 11: c_atypes[i] = &ffi_type_sshort; arg = sexp_sint_value(avalues[i]); break;
//case 12: c_atypes[i] = &ffi_type_ushort; arg = sexp_uint_value(avalues[i]); break;
case 13:
c_atypes[i] = &ffi_type_sint;
temps[i] = sexp_sint_value(avalues[i]);
c_avalues[i] = &temps[i];
break;
//case 14: c_atypes[i] = &ffi_type_uint; arg = sexp_uint_value(avalues[i]); break;
//case 15: c_atypes[i] = &ffi_type_slong; arg = sexp_sint_value(avalues[i]); break;
//case 16: c_atypes[i] = &ffi_type_ulong; arg = sexp_uint_value(avalues[i]); break;
// FIXME
//case 17: c_atypes[i] = &ffi_type_float; arg = sexp_flonum_value(avalues[i]); break;
// FIXME
//case 18: c_atypes[i] = &ffi_type_double; arg = sexp_flonum_value(avalues[i]); break;
//case 19: c_atypes[i] = &ffi_type_void; arg = NULL; break;
case 20:
c_atypes[i] = &ffi_type_pointer;
c_avalues[i] = &sexp_cpointer_value(avalues[i]);
//printf(\"Pointer value: %s\\n\", sexp_cpointer_maybe_null_value(avalues[i]));
break;
default:
printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i);
//c_avalues[i] = sexp_cpointer_value(avalues[i]);
break;
}
}
ffi_type* c_rtype = &ffi_type_void;
switch(rtype) {
case 1: c_rtype = &ffi_type_sint8; break;
case 2: c_rtype = &ffi_type_uint8; break;
case 3: c_rtype = &ffi_type_sint16; break;
case 4: c_rtype = &ffi_type_uint16; break;
case 5: c_rtype = &ffi_type_sint32; break;
case 6: c_rtype = &ffi_type_uint32; break;
case 7: c_rtype = &ffi_type_sint64; break;
case 8: c_rtype = &ffi_type_uint64; break;
case 9: c_rtype = &ffi_type_schar; break;
case 10: c_rtype = &ffi_type_uchar; break;
case 11: c_rtype = &ffi_type_sshort; break;
case 12: c_rtype = &ffi_type_ushort; break;
case 13: c_rtype = &ffi_type_sint; break;
case 14: c_rtype = &ffi_type_uint; break;
case 15: c_rtype = &ffi_type_slong; break;
case 16: c_rtype = &ffi_type_ulong; break;
case 17: c_rtype = &ffi_type_float; break;
case 18: c_rtype = &ffi_type_double; break;
case 19: c_rtype = &ffi_type_void; break;
case 20: c_rtype = &ffi_type_pointer; break;
default:
printf(\"Undefined return type: %i\\n\", rtype);
c_rtype = &ffi_type_pointer;
break;
}
int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes);
void* rvalue = malloc(rvalue_size);
ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
return rvalue;
}")
(define-c void
(define-c (maybe-null pointer void*)
(internal-ffi-call internal_ffi_call)
(unsigned-int
unsigned-int
(array unsigned-int)
(pointer void*)
(array void*)
(pointer void*)
(pointer void*)
unsigned-int
(array sexp)))
(c-declare

2
foreign/c/primitives/chicken.scm
View File

@ -169,7 +169,7 @@
(lambda (c-bytevector k)
(pointer-u8-ref (pointer+ c-bytevector k))))
#;(define c-bytevector-u8-set!
(define c-bytevector-u8-set!
(lambda (c-bytevector k byte)
(pointer-u8-set! (pointer+ c-bytevector k) byte)))

176
foreign/c/primitives/cyclone.scm
View File

@ -1,4 +1,4 @@
(define pffi-type->native-type
(define type->native-type
(lambda (type)
(cond ((equal? type 'int8) int)
((equal? type 'uint8) int)
@ -21,7 +21,7 @@
((equal? type 'pointer) opaque)
((equal? type 'void) c-void)
((equal? type 'callback) opaque)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(else (error "type->native-type -- No such type" type)))))
(define c-bytevector?
(lambda (object)
@ -30,7 +30,7 @@
(define-syntax define-c-procedure
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type
(let* ((type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'int)
((equal? type 'uint8) 'int)
@ -53,15 +53,15 @@
((equal? type 'pointer) 'opaque)
((equal? type 'void) 'c-void)
((equal? type 'callback) 'opaque)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(else (error "type->native-type -- No such type" type)))))
(scheme-name (cadr 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)))))))))
(return-type (type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
(argument-types
(let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr)))))))))
(if (null? types)
'()
(map pffi-type->native-type types)))))
(map type->native-type types)))))
(if (null? argument-types)
`(c-define ,scheme-name ,return-type ,c-name)
`(c-define ,scheme-name
@ -69,7 +69,7 @@
(define define-c-callback
(lambda (scheme-name return-type argument-types procedure)
(error "pffi-define-callback not yet implemented on Cyclone")))
(error "define-callback not yet implemented on Cyclone")))
(define size-of-type
(lambda (type)
@ -93,12 +93,12 @@
((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
(define-c pffi-pointer-address
(define-c pointer-address
"(void *data, int argc, closure _, object k, object pointer)"
"make_c_opaque(opq, &(void*)opaque_ptr(pointer));
return_closcall1(data, k, &opq);")
(define pffi-pointer-null
(define pointer-null
(lambda ()
(make-opaque)))
@ -107,9 +107,9 @@
((_ scheme-name headers object-name options)
(begin
(define scheme-name #t)
(pffi-shared-object-load headers)))))
(shared-object-load headers)))))
(define-syntax pffi-shared-object-load
(define-syntax shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
(let* ((headers (cadr (cadr expr)))
@ -119,254 +119,254 @@
headers)))
`(,@includes)))))
(define pffi-pointer-null?
(define pointer-null?
(lambda (pointer)
(and (opaque? pointer)
(opaque-null? pointer))))
(define-c pffi-pointer-int8-set!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c 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!
(define-c pointer-pointer-set!
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
"uintptr_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
*p = (uintptr_t)&opaque_ptr(value);
return_closcall1(data, k, make_boolean(boolean_t));")
(define pffi-pointer-set!
(define 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)))))
((equal? type 'int8) (pointer-int8-set! pointer offset value))
((equal? type 'uint8) (pointer-uint8-set! pointer offset value))
((equal? type 'int16) (pointer-int16-set! pointer offset value))
((equal? type 'uint16) (pointer-uint16-set! pointer offset value))
((equal? type 'int32) (pointer-int32-set! pointer offset value))
((equal? type 'uint32) (pointer-uint32-set! pointer offset value))
((equal? type 'int64) (pointer-int64-set! pointer offset value))
((equal? type 'uint64) (pointer-uint64-set! pointer offset value))
((equal? type 'char) (pointer-char-set! pointer offset value))
((equal? type 'short) (pointer-short-set! pointer offset value))
((equal? type 'unsigned-short) (pointer-unsigned-short-set! pointer offset value))
((equal? type 'int) (pointer-int-set! pointer offset value))
((equal? type 'unsigned-int) (pointer-unsigned-int-set! pointer offset value))
((equal? type 'long) (pointer-long-set! pointer offset value))
((equal? type 'unsigned-long) (pointer-unsigned-long-set! pointer offset value))
((equal? type 'float) (pointer-float-set! pointer offset value))
((equal? type 'double) (pointer-double-set! pointer offset value))
((equal? type 'pointer) (pointer-pointer-set! pointer offset value)))))
(define-c pffi-pointer-int8-get
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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
(define-c 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 c-bytevector-u8-set! pffi-pointer-uint8-set!)
(define c-bytevector-u8-ref pffi-pointer-uint8-get)
#;(define c-bytevector-u8-set! pointer-uint8-set!)
(define c-bytevector-u8-ref pointer-uint8-get)
(define pffi-pointer-get
(define 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)))))
((equal? type 'int8) (pointer-int8-get pointer offset))
((equal? type 'uint8) (pointer-uint8-get pointer offset))
((equal? type 'int16) (pointer-int16-get pointer offset))
((equal? type 'uint16) (pointer-uint16-get pointer offset))
((equal? type 'int32) (pointer-int32-get pointer offset))
((equal? type 'uint32) (pointer-uint32-get pointer offset))
((equal? type 'int64) (pointer-int64-get pointer offset))
((equal? type 'uint64) (pointer-uint64-get pointer offset))
((equal? type 'char) (pointer-char-get pointer offset))
((equal? type 'short) (pointer-short-get pointer offset))
((equal? type 'unsigned-short) (pointer-unsigned-short-get pointer offset))
((equal? type 'int) (pointer-int-get pointer offset))
((equal? type 'unsigned-int) (pointer-unsigned-int-get pointer offset))
((equal? type 'long) (pointer-long-get pointer offset))
((equal? type 'unsigned-long) (pointer-unsigned-long-get pointer offset))
((equal? type 'float) (pointer-float-get pointer offset))
((equal? type 'double) (pointer-double-get pointer offset))
((equal? type 'pointer) (pointer-pointer-get pointer offset)))))

26
foreign/c/primitives/gauche.scm
View File

@ -1,16 +1,16 @@
(define-module foreign.c.primitives.gauche
(export size-of-type
pffi-shared-object-load
shared-object-load
c-bytevector-u8-set!
c-bytevector-u8-ref
;pffi-pointer-null
;pffi-pointer-null?
;pointer-null
;pointer-null?
make-c-bytevector
;pffi-pointer-address
;pointer-address
c-bytevector?
c-free
pffi-pointer-set!
pffi-pointer-get
pointer-set!
pointer-get
define-c-procedure
define-c-callback))
@ -42,7 +42,7 @@
((equal? type 'pointer) (size-of-pointer))
((equal? type 'void) (size-of-void)))))
(define pffi-shared-object-load
#;(define shared-object-load
(lambda (path options)
(shared-object-load path)))
@ -58,10 +58,10 @@
(lambda (pointer)
(pointer-free pointer)))
;(define c-bytevector-u8-set! pointer-set-uint8!)
(define c-bytevector-u8-set! pointer-set-uint8!)
(define c-bytevector-u8-ref pointer-get-uint8)
(define pffi-pointer-set!
(define pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-int8! pointer offset value))
((equal? type 'uint8) (pointer-set-uint8! pointer offset value))
@ -83,7 +83,7 @@
((equal? type 'void) (pointer-set-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-pointer! pointer offset value)))))
(define pffi-pointer-get
(define pointer-get
(lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-get-int8 pointer offset))
((equal? type 'uint8) (pointer-get-uint8 pointer offset))
@ -134,7 +134,7 @@
(lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (make-c-bytevector (size-of-type type))))
(pffi-pointer-set! pointer type 0 value)
(pointer-set! pointer type 0 value)
pointer)))))
(define make-c-function
@ -142,7 +142,7 @@
(dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
#;(when (not (pffi-pointer-null? maybe-dlerror))
#;(when (not (pointer-null? maybe-dlerror))
(error (c-bytevector->string maybe-dlerror)))
(lambda arguments
(let ((return-value (make-c-bytevector
@ -158,7 +158,7 @@
arguments
argument-types))
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
(pointer-get return-value return-type 0))))))))
(define-syntax define-c-procedure
(syntax-rules ()

2
foreign/c/primitives/gauche/gauchelib.scm
View File

@ -23,7 +23,7 @@
(define-cproc size-of-string () size_of_string)
(define-cproc size-of-pointer () size_of_pointer)
(define-cproc size-of-void () size_of_void)
(define-cproc shared-object-load (path::<string>) shared_object_load)
(define-cproc shared-object-load (path::<string> options) shared_object_load)
(define-cproc pointer-null () pointer_null)
(define-cproc pointer-null? (pointer) is_pointer_null)
(define-cproc pointer-allocate (size::<int>) pointer_allocate)

20
foreign/c/primitives/guile.scm
View File

@ -1,4 +1,4 @@
(define pffi-type->native-type
(define type->native-type
(lambda (type)
(cond ((equal? type 'int8) int8)
((equal? type 'uint8) uint8)
@ -34,29 +34,29 @@
(define scheme-name
(foreign-library-function shared-object
(symbol->string c-name)
#:return-type (pffi-type->native-type return-type)
#:arg-types (map pffi-type->native-type argument-types))))))
#:return-type (type->native-type return-type)
#:arg-types (map type->native-type argument-types))))))
(define-syntax define-c-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(procedure->pointer (pffi-type->native-type return-type)
(procedure->pointer (type->native-type return-type)
procedure
(map pffi-type->native-type argument-types))))))
(map type->native-type argument-types))))))
(define size-of-type
(lambda (type)
(let ((native-type (pffi-type->native-type type)))
(let ((native-type (type->native-type type)))
(cond ((equal? native-type void) 0)
(native-type (sizeof native-type))
(else #f)))))
(define pffi-shared-object-load
(define shared-object-load
(lambda (path options)
(load-foreign-library path)))
#;(define c-bytevector-u8-set!
(define c-bytevector-u8-set!
(lambda (c-bytevector k byte)
(let ((p (pointer->bytevector c-bytevector (+ k 100))))
(bytevector-u8-set! p k byte))))
@ -66,7 +66,7 @@
(let ((p (pointer->bytevector c-bytevector (+ k 100))))
(bytevector-u8-ref p k))))
(define pffi-pointer-set!
(define pointer-set!
(lambda (pointer type offset value)
(let ((p (pointer->bytevector pointer (+ offset 100))))
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
@ -88,7 +88,7 @@
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))))))
(define pffi-pointer-get
(define pointer-get
(lambda (pointer type offset)
(let ((p (pointer->bytevector pointer (+ offset 100))))
(cond ((equal? type 'int8) (bytevector-s8-ref p offset))

32
foreign/c/primitives/kawa.scm
View File

@ -26,7 +26,7 @@
(java.lang.Char value))
(else value))))
(define pffi-type->native-type
(define type->native-type
(lambda (type)
(cond
((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_BYTE) 'withByteAlignment 1))
@ -71,10 +71,10 @@
'orElseThrow)
(if (equal? return-type 'void)
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
(map pffi-type->native-type argument-types))
(map type->native-type argument-types))
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
(pffi-type->native-type return-type)
(map pffi-type->native-type argument-types))))
(type->native-type return-type)
(map type->native-type argument-types))))
'invokeWithArguments
(map value->object vals argument-types)))))))
@ -103,10 +103,10 @@
(let ((function-descriptor
(if (equal? return-type 'void)
(apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)
(map pffi-type->native-type argument-types))
(map type->native-type argument-types))
(apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
(pffi-type->native-type return-type)
(map pffi-type->native-type argument-types)))))
(type->native-type return-type)
(map type->native-type argument-types)))))
(write function-descriptor)
(newline)
(write (invoke function-descriptor 'getClass))
@ -125,7 +125,7 @@
(define size-of-type
(lambda (type)
(let ((native-type (pffi-type->native-type type)))
(let ((native-type (type->native-type type)))
(if native-type
(invoke native-type 'byteAlignment)
#f))))
@ -134,7 +134,7 @@
(lambda ()
(static-field java.lang.foreign.MemorySegment 'NULL)))
(define pffi-shared-object-load
(define shared-object-load
(lambda (path options)
(let* ((library-file (make java.io.File path))
(file-name (invoke library-file 'getName))
@ -170,31 +170,31 @@
u8-value-layout
k)))
(define pffi-pointer-set!
(define pointer-set!
(lambda (pointer type offset value)
(invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
'set
(pffi-type->native-type type)
(type->native-type type)
offset
(if (equal? type 'char)
(char->integer value)
value))))
(define pffi-pointer-get
(define pointer-get
(lambda (pointer type offset)
(let ((r (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE))
'get
(pffi-type->native-type type)
(type->native-type type)
offset)))
(if (equal? type 'char)
(integer->char r)
r))))
(define-syntax call-with-address-of-c-bytevector
#;(define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
(pffi-pointer-set! address-pointer 'pointer 0 input-pointer)
(pointer-set! address-pointer 'pointer 0 input-pointer)
(apply thunk (list address-pointer))
(set! input-pointer (pffi-pointer-get address-pointer 'pointer 0))
(set! input-pointer (pointer-get address-pointer 'pointer 0))
(c-free address-pointer)))))

4
foreign/c/primitives/larceny.scm
View File

@ -32,7 +32,7 @@
;(void*? object)
(number? object)))
(define pffi-shared-object-load
(define shared-object-load
(lambda (headers path . options)
(foreign-file path)))
@ -51,7 +51,7 @@
return-type
argument-types)))))
(define-syntax pffi-define-callback
(define-syntax define-c-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name

21
foreign/c/primitives/mosh.scm
View File

@ -19,12 +19,11 @@
((eq? type 'float) size-of-float)
((eq? type 'double) size-of-double)
((eq? type 'pointer) size-of-pointer)
((eq? type 'string) size-of-pointer)
((eq? type 'callback) size-of-pointer)
((eq? type 'void) 0)
(else #f))))
(define pffi-shared-object-load
(define shared-object-load
(lambda (path options)
(open-shared-library path)))
@ -32,10 +31,10 @@
(lambda (object)
(pointer? object)))
;(define c-bytevector-u8-set! pointer-set-c-uint8!)
(define c-bytevector-u8-set! pointer-set-c-uint8!)
(define c-bytevector-u8-ref pointer-ref-c-uint8)
(define pffi-pointer-set!
#;(define pointer-set!
(lambda (pointer type offset value)
(cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value))
((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value))
@ -57,7 +56,7 @@
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get
#;(define pointer-get
(lambda (pointer type offset)
(cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset))
((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset))
@ -79,7 +78,7 @@
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define pffi-type->native-type
(define type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'int8_t)
((equal? type 'uint8) 'uint8_t)
@ -102,21 +101,21 @@
((equal? type 'pointer) 'void*)
((equal? type 'void) 'void)
((equal? type 'callback) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(else (error "type->native-type -- No such type" type)))))
(define-syntax define-c-procedure
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(pffi-type->native-type return-type)
(type->native-type return-type)
c-name
(map pffi-type->native-type argument-types))))))
(map type->native-type argument-types))))))
(define-syntax define-c-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback (pffi-type->native-type return-type)
(map pffi-type->native-type argument-types)
(make-c-callback (type->native-type return-type)
(map type->native-type argument-types)
procedure)))))

38
foreign/c/primitives/racket.scm
View File

@ -1,4 +1,4 @@
(define pffi-type->native-type
(define type->native-type
(lambda (type)
(cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8)
@ -33,25 +33,22 @@
(define scheme-name
(get-ffi-obj c-name
shared-object
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))))))
(_cprocedure (mlist->list (map type->native-type argument-types))
(type->native-type return-type)))))))
(define-syntax define-c-callback
(syntax-rules ()
((pffi-define-callback scheme-name return-type argument-types procedure)
((_ scheme-name return-type argument-types procedure)
(define scheme-name (function-ptr procedure
(_cprocedure
(mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))))))
(mlist->list (map type->native-type argument-types))
(type->native-type return-type)))))))
(define size-of-type
(lambda (type)
(let ((native-type (pffi-type->native-type type)))
(if native-type
(ctype-sizeof native-type)
#f))))
(ctype-sizeof (type->native-type type))))
(define pffi-shared-object-load
(define shared-object-load
(lambda (path options)
(if (and (not (null? options))
(assoc 'additional-versions options))
@ -60,7 +57,7 @@
(list #f))))
(ffi-lib path))))
#;(define c-bytevector-u8-set!
(define c-bytevector-u8-set!
(lambda (c-bytevector k byte)
(ptr-set! c-bytevector _uint8 'abs k byte)))
@ -68,22 +65,31 @@
(lambda (c-bytevector k)
(ptr-ref c-bytevector _uint8 'abs k)))
(define pffi-pointer-set!
#;(define pointer-set!
(lambda (pointer type offset value)
(ptr-set! pointer
(pffi-type->native-type type)
(type->native-type type)
'abs
offset
(if (equal? type 'char)
(char->integer value)
value))))
(define pffi-pointer-get
#;(define pointer-get
(lambda (pointer type offset)
(let ((r (ptr-ref pointer
(pffi-type->native-type type)
(type->native-type type)
'abs
offset)))
(if (equal? type 'char)
(integer->char r)
r))))
#;(define-syntax call-with-address-of-c-bytevector
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))
(c-bytevector-pointer-set! address-pointer 0 input-pointer)
(apply thunk (list address-pointer))
(set! input-pointer (c-bytevector-pointer-ref address-pointer 0))
(c-free address-pointer)))))

18
foreign/c/primitives/sagittarius.scm
View File

@ -23,11 +23,11 @@
((eq? type 'callback) size-of-void*)
(else #f))))
(define pffi-shared-object-load
(define shared-object-load
(lambda (path options)
(open-shared-library path)))
(define pffi-type->native-type
(define type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'int8_t)
((equal? type 'uint8) 'uint8_t)
@ -57,26 +57,26 @@
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(pffi-type->native-type return-type)
(type->native-type return-type)
c-name
(map pffi-type->native-type argument-types))))))
(map type->native-type argument-types))))))
(define-syntax define-c-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback (pffi-type->native-type return-type)
(map pffi-type->native-type argument-types)
(make-c-callback (type->native-type return-type)
(map type->native-type argument-types)
procedure)))))
(define c-bytevector?
(lambda (object)
(pointer? object)))
;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
(define pffi-pointer-set!
(define 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))
@ -98,7 +98,7 @@
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get
(define 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))

16
foreign/c/primitives/stklos.scm
View File

@ -42,7 +42,7 @@
((equal? type 'int64) :long)
((equal? type 'uint64) :ulong)
((equal? type 'char) :char)
((equal? type 'unsigned-char) :uchar)
((equal? type 'unsigned-char) :char)
((equal? type 'short) :short)
((equal? type 'unsigned-short) :ushort)
((equal? type 'int) :int)
@ -62,9 +62,15 @@
(type->native-type return-type)
shared-object))))))
(define define-c-callback
(lambda ()
(error "Not implemented")))
(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))
))))
; FIXME
(define size-of-type
@ -89,7 +95,7 @@
((equal? type 'double) 8)
((equal? type 'pointer) 8))))
;(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-set! pointer-set-c-uint8_t!)
(define c-bytevector-u8-ref pointer-ref-c-uint8_t)
(define pffi-pointer-set!

14
foreign/c/primitives/ypsilon.scm
View File

@ -28,7 +28,7 @@
(lambda (object)
(number? object)))
#;(define c-bytevector-u8-set!
(define c-bytevector-u8-set!
(lambda (c-bytevector k byte)
(bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
(c-size-of 'uint8))
@ -41,7 +41,7 @@
(c-size-of 'uint8))
0)))
(define pffi-pointer-set!
(define pointer-set!
(lambda (pointer type offset value)
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type))))
(cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
@ -64,7 +64,7 @@
((equal? type 'void) (bytevector-c-void*-set! bv 0 value))
((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value))))))
(define pffi-pointer-get
(define pointer-get
(lambda (pointer type offset)
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type))))
(cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
@ -87,7 +87,7 @@
((equal? type 'void) (bytevector-c-void*-ref bv 0))
((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
(define pffi-shared-object-load
(define shared-object-load
(lambda (path options)
(load-shared-object path)))
@ -114,7 +114,7 @@
((equal? ,type 'pointer) 'void*)
((equal? ,type 'void) 'void)
;((equal? ,type 'callback) 'void*)
(else (error "type->native-type -- No such pffi type" ,type))))
(else (error "type->native-type -- No such type" ,type))))
(define-macro
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
@ -142,7 +142,7 @@
((equal? type 'pointer) 'void*)
((equal? type 'void) 'void)
((equal? type 'callback) 'void*)
(else (error "type->native-type -- No such pffi type" type))))))
(else (error "type->native-type -- No such type" type))))))
`(define ,scheme-name
(c-function ,(type->native-type (cadr return-type))
,(cadr c-name)
@ -173,7 +173,7 @@
((equal? type 'pointer) 'void*)
((equal? type 'void) 'void)
((equal? type 'callback) 'void*)
(else (error "type->native-type -- No such pffi type" type)))))
(else (error "type->native-type -- No such type" type)))))
(native-return-type (type->native-type (cadr return-type)))
(native-argument-types (map type->native-type (cadr argument-types))))
`(define ,scheme-name

4
tests/addressof.scm
View File

@ -88,8 +88,12 @@
'(pointer pointer))
(define input-pointer (make-c-bytevector (c-size-of 'int)))
(debug (c-bytevector->address input-pointer))
(assert equal? (number? (c-bytevector->address input-pointer)) #t)
(c-bytevector-s32-native-set! input-pointer 0 100)
(assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 100) #t)
(debug (c-bytevector-s32-native-ref input-pointer 0))
(debug input-pointer)
(call-with-address-of-c-bytevector
input-pointer
(lambda (address)

128
tests/primitives.scm
View File

@ -212,31 +212,19 @@
;; define-c-library
(print-header 'pffi-define-library)
(print-header 'define-c-library)
(cond-expand
(windows (define-c-library libc-stdlib
'("stdlib.h")
(windows (define-c-library libc
'("stdio.h" "string.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (define-c-library libc-stdlib
'("stdlib.h")
(else (define-c-library libc
'("stdio.h" "string.h")
"c"
'((additional-versions ("0" "6"))))))
(debug libc-stdlib)
(cond-expand
(windows (define-c-library libc-stdio
'("stdio.h")
"ucrtbase"
'((additional-versions ("0" "6")))))
(else (define-c-library libc-stdio
'("stdio.h")
"c"
'((additional-versions ("0" "6"))))))
(debug libc-stdio)
(debug libc)
(define-c-library c-testlib
'("libtest.h")
@ -245,43 +233,15 @@
(debug c-testlib)
;; define-c-procedure
;; define-c-procedure 1
(print-header "define-c-procedure 1")
(print-header 'define-c-procedure)
(define-c-procedure c-abs libc-stdlib 'abs 'int '(int))
(define-c-procedure c-abs libc 'abs 'int '(int))
(debug c-abs)
(define absoluted (c-abs -2))
(debug absoluted)
(assert = absoluted 2)
(define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer))
(debug c-puts)
(define chars-written (c-puts (string->c-utf8 "puts: Hello from testing, I am C function puts")))
(debug chars-written)
(assert = chars-written 47)
(define-c-procedure c-atoi libc-stdlib 'atoi 'int '(pointer))
(assert = (c-atoi (string->c-utf8 "100")) 100)
(define-c-procedure c-fopen libc-stdio 'fopen 'pointer '(pointer pointer))
(define output-file (c-fopen (string->c-utf8 "testfile.test")
(string->c-utf8 "w")))
(debug output-file)
(define-c-procedure c-fprintf libc-stdio 'fprintf 'int '(pointer pointer))
(define characters-written
(c-fprintf output-file (string->c-utf8 "Hello world")))
(debug characters-written)
(assert equal? (= characters-written 11) #t)
(define-c-procedure c-fclose libc-stdio 'fclose 'int '(pointer))
(define closed-status (c-fclose output-file))
(debug closed-status)
(assert equal? (= closed-status 0) #t)
(assert equal? (file-exists? "testfile.test") #t)
(assert equal? (string=? (with-input-from-file "testfile.test"
(lambda () (read-line)))
"Hello world") #t)
(define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '())
(debug c-takes-no-args)
(c-takes-no-args)
@ -291,26 +251,82 @@
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
(assert equal? (= takes-no-args-returns-int-result 0) #t)
;; c-bytevector?
(print-header 'c-bytevector?)
;; make-c-bytevector and c-bytevector?
(print-header "make-c-bytevector and c-bytevector?")
(define bytes (make-c-bytevector 100))
(debug bytes)
(assert equal? (c-bytevector? bytes) #t)
(define is-pointer (make-c-bytevector 100))
(debug is-pointer)
(assert equal? (c-bytevector? is-pointer) #t)
; FIXME Ypsilon
;(assert equal? (c-bytevector? 100) #f)
; FIXME Chibi
;(assert equal? (c-bytevector? #f) #f)
(assert equal? (c-bytevector? "Hello") #f)
(assert equal? (c-bytevector? 'bar) #f)
;; c-bytevector-u8-ref
(print-header "c-bytevector-u8-ref")
;; c-bytevector-u8-set! and c-bytevector-u8-ref
(print-header "c-bytevector-u8-set! and c-bytevector-u8-ref")
(define u8-pointer (make-c-bytevector (c-size-of 'uint8)))
(debug u8-pointer)
(debug (c-bytevector? u8-pointer))
(assert equal? (c-bytevector? u8-pointer) #t)
(c-bytevector-u8-set! u8-pointer 0 42)
(debug u8-pointer)
(debug (c-bytevector-u8-ref u8-pointer 0))
(assert equal? (= (c-bytevector-u8-ref u8-pointer 0) 42) #t)
;; string->-utf8 c-utf8->string
(print-header "string->c-utf8 c-utf8->string")
(for-each
(lambda (str)
(debug str)
(assert equal? (string=? (c-utf8->string (string->c-utf8 str)) str) #t))
(list "100" "Hello world" "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
;; define-c-procedure 2
(print-header "define-c-procedure 2")
(define-c-procedure c-atoi libc 'atoi 'int '(pointer))
(assert = (c-atoi (string->c-utf8 "100")) 100)
(define-c-procedure c-puts libc 'puts 'int '(pointer))
(debug c-puts)
(define chars-written (c-puts (string->c-utf8 "puts: Hello from testing, I am C function puts")))
(debug chars-written)
(assert = chars-written 47)
(define-c-procedure c-strcat libc 'strcat 'pointer '(pointer pointer))
(define c-string1 (string->c-utf8 "test123"))
(debug (c-utf8->string c-string1))
(debug (c-utf8->string (c-strcat (string->c-utf8 "con1") (string->c-utf8 "cat1"))))
(assert equal? (string=? (c-utf8->string (c-strcat (string->c-utf8 "con2")
(string->c-utf8 "cat2")))
"con2cat2") #t)
(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
(define output-file (c-fopen (string->c-utf8 "testfile.test")
(string->c-utf8 "w")))
(debug output-file)
(define-c-procedure c-fprintf libc 'fprintf 'int '(pointer pointer))
(define characters-written
(c-fprintf output-file (string->c-utf8 "Hello world")))
(debug characters-written)
(assert equal? (= characters-written 11) #t)
(define-c-procedure c-fclose libc 'fclose 'int '(pointer))
(define closed-status (c-fclose output-file))
(debug closed-status)
(assert equal? (= closed-status 0) #t)
(assert equal? (file-exists? "testfile.test") #t)
(assert equal? (string=? (with-input-from-file "testfile.test"
(lambda () (read-line)))
"Hello world") #t)
;; define-c-callback
(print-header 'define-c-callback)
@ -320,7 +336,7 @@
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2)
(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1)
(define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback))
(define-c-procedure qsort libc 'qsort 'void '(pointer int int callback))
(define-c-callback compare
'int