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

Update readme

This commit is contained in:
retropikzel 2025-01-25 06:50:51 +02:00
parent 26b492a8eb
commit a8d09439ab
6 changed files with 16 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@ -1,4 +1,4 @@
# Portable Foreign Function Interface for R8RS schemes
# Portable Foreign Function Interface for R7RS schemes
Foreign function interface that is supported on multiple R7RS Sceheme implementations.

2
retropikzel/r7rs-pffi.sld
View File

@ -31,7 +31,7 @@
pffi-struct-get
pffi-struct-set!
pffi-define
;pffi-define-callback
pffi-define-callback
;pffi-pointer-address
;pffi-pointer-dereference
)

6
retropikzel/r7rs-pffi/chibi.scm
View File

@ -194,9 +194,7 @@
(map argument->pointer
arguments
argument-types))
(cond ((equal? return-type 'pointer)
return-value)
((not (equal? return-type 'void))
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0)))))))
(define-syntax pffi-define
@ -211,7 +209,7 @@
(define make-c-callback
(lambda (return-type argument-types procedure)
procedure))
(scheme-procedure-to-pointer procedure)))
(define-syntax pffi-define-callback
(syntax-rules ()

7
retropikzel/r7rs-pffi/kawa.scm
View File

@ -28,7 +28,6 @@
(java.lang.Char value))
(else value))))
(define pffi-type->native-type
(lambda (type)
(cond
@ -90,8 +89,6 @@
(looper (+ count 1) (append result (list count)))))))
(looper from (list)))))
(define-syntax pffi-define-callback
(syntax-rules ()
((_ scheme-name return-type argument-types procedure)
@ -185,7 +182,7 @@
'reinterpret
(static-field java.lang.Integer 'MAX_VALUE))
'set
(invoke (pffi-type->native-type type) 'withByteAlignment (pffi-align-of type))
(invoke (pffi-type->native-type type) 'withByteAlignment 1)
offset
value)))
@ -194,6 +191,6 @@
(let ((r (invoke (invoke pointer 'reinterpret
(static-field java.lang.Integer 'MAX_VALUE))
'get
(invoke (pffi-type->native-type type) 'withByteAlignment (pffi-align-of type))
(invoke (pffi-type->native-type type) 'withByteAlignment 1)
offset)))
r)))

10
retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub
View File

@ -240,8 +240,6 @@
(c-declare
"void internal_ffi_call(unsigned int nargs, void* rtype, void** atypes, void* fn, void* rvalue, void* avalues) {
ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes);
char* s = \"MORO\";
void* values[] = {&s};
ffi_call(&cif, FFI_FN(fn), rvalue, &avalues);
}")
(define-c void
@ -254,11 +252,11 @@
(array void*)))
(c-declare
"void* scheme_procedure_to_pointer(void* proc) {
/*if(sexp_procedurep(proc) == 1) {
"void* scheme_procedure_to_pointer(sexp proc) {
if(sexp_procedurep(proc) == 1) {
puts(\"ITS A PROCEDURE\");
}*/
return proc;
}
return proc->var;
}")
(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))

9
test.scm
View File

@ -403,7 +403,7 @@
(print-header "pffi-pointer-set! and pffi-pointer-get 1/2")
(define set-pointer (pffi-pointer-allocate 256))
(define offset 0)
(define offset 64)
(define value 1)
(debug set-pointer)
(debug offset)
@ -691,6 +691,7 @@
(print-header "pffi-struct-make with pointer")
(pffi-define c-test-new c-testlib 'test_new 'pointer (list))
(define struct-test2-pointer (c-test-new))
(define struct-test2 (pffi-struct-make 'test
'((int8 . a)
(char . b)
@ -706,11 +707,13 @@
(int . l)
(double . m)
(float . n))
(c-test-new)))
struct-test2-pointer))
(debug struct-test2)
(debug (pffi-pointer-get struct-test2-pointer 'int8 0))
(debug (pffi-struct-get struct-test2 'a))
(assert = (pffi-struct-get struct-test2 'a) 1)
(debug (pffi-pointer-get struct-test2-pointer 'char 1))
(debug (pffi-struct-get struct-test2 'b))
(assert char=? (pffi-struct-get struct-test2 'b) #\b)
(debug (pffi-struct-get struct-test2 'c))
@ -768,7 +771,7 @@
(pffi-pointer-get array 'int (* (pffi-size-of 'int) 1))
(pffi-pointer-get array 'int (* (pffi-size-of 'int) 2))))
(newline)
(qsort array 3 (pffi-size-of 'int) compare)
;(qsort array 3 (pffi-size-of 'int) compare)
(display "Sorted: ")
(write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))