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

Type, size and readme fixes

This commit is contained in:
retropikzel 2025-02-19 21:03:20 +02:00
parent 24cdacfcef
commit 815e49906f
12 changed files with 197 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -118,7 +118,7 @@ test-mosh: libtest.so
SASH=sash --clean-cache -r7 -L .
test-sagittarius-docker:
docker build --build-arg SCHEME=sagittarius -f Dockerfile --tag=r7rs-pffi-sagittarius .
docker build --build-arg SCHEME=sagittarius:head -f Dockerfile --tag=r7rs-pffi-sagittarius .
${DOCKER} r7rs-pffi-sagittarius bash -c "${DOCKER_INIT} ${SASH} test.scm"
test-sagittarius: libtest.so

50
README.md
View File

@ -21,7 +21,11 @@ Any help in form of constructive advice and bug reports are appreciated.
- [Implementation table](#implementation-table)
- [Other Implementations](#other-implementations)
- [Documentation](#documentation)
- [Usage notes](#usage-notes)
- [Usage](#usage)
- [Chibi](#usage_chibi)
- [Chicken](#usage_chicken)
- [Racket](#usage_racket)
- [Kawa](#usage_kawa)
- [Reference](#reference)
- [Types](#types)
- [Procedures and macros](#procedures-and-macros)
@ -128,26 +132,41 @@ changing anymore and some implementations are in **beta**.
## Documentation
### Usage Chibi
### Usage <a name="#usage"></a>
- Chibi
- Install libffi-dev
- Build with:
- chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub
- ${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so -fPIC -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c -lchibi-scheme -lffi
#### Chibi <a name="#usage_chibi"></a>
Needs libffi-dev, on Debina/Ubuntu/Mint install with:
apt install libffi-dev
Build with:
chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub
gcc -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so -fPIC -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c -lchibi-scheme -lffi
#### Chicken <a name="#usage_chicken"></a>
Needs [r7rs egg](https://wiki.call-cc.org/eggref/5/r7rs), install with:
chicken-install r7rs
#### Racket <a name="#usage_racker"></a>
Needs [racket-r7rs](https://github.com/lexi-lambda/racket-r7rs), install with:
raco pkg install --auto r7rs
#### Kawa <a name="#usage_kawa"></a>
Kawa Needs at least Java version 22
Needs jvm flags:
### Usage Chicken
- Chicken 5
- Needs [r7rs egg](https://wiki.call-cc.org/eggref/5/r7rs)
- Kawa
- Needs at least Java version 22
- Needs jvm flags:
- --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED
- --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED
- --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED
- --enable-native-access=ALL-UNNAMED
- Racket
- Needs [racket-r7rs](https://github.com/lexi-lambda/racket-r7rs)
### Reference
@ -208,6 +227,7 @@ keyword. The options are:
- additional-versions
- Search for additional versions of shared object, given shared object "c" and additional
versions "6" "7" on linux the files "libc", "libc.6", "libc.7" are searched for.
- Can be either numbers or strings
- additional-paths
- Give additional paths to search shared objects for

64
libtest.c
View File

@ -16,6 +16,12 @@
#pragma warning Unknown dynamic link import/export semantics.
#endif
struct color {
int8_t r;
int8_t g;
int8_t b;
int8_t a;
};
struct test {
int8_t a;
@ -150,6 +156,30 @@ EXPORT struct test* init_struct(struct test* test) {
test->n = 14;
}
EXPORT int color_check(struct color* color) {
printf("C: Value of r is %c\n", color->r);
assert(color->r == 100);
printf("C: Value of g is %c\n", color->g);
assert(color->g == 100);
printf("C: Value of b is %c\n", color->b);
assert(color->b == 100);
printf("C: Value of a is %c\n", color->a);
assert(color->a == 100);
return 0;
}
EXPORT int color_check_by_value(struct color color) {
printf("C: Value of r is %i\n", color.r);
assert(color.r == 100);
printf("C: Value of g is %i\n", color.g);
assert(color.g == 101);
printf("C: Value of b is %i\n", color.b);
assert(color.b == 102);
printf("C: Value of a is %i\n", color.a);
assert(color.a == 103);
return 0;
}
EXPORT int test_check(struct test* test) {
print_offsets();
printf("C: Value of a is %c\n", test->a);
@ -166,7 +196,7 @@ EXPORT int test_check(struct test* test) {
assert(test->f == 6.0);
printf("C: Value of g is %f\n", test->g);
assert(strcmp(test->g, "foo") == 0);
printf("C: Value of g is %i\n", test->h);
printf("C: Value of h is %i\n", test->h);
assert(test->h == 8);
printf("C: Value of i is %s\n", test->i);
assert(test->i == NULL);
@ -184,34 +214,34 @@ EXPORT int test_check(struct test* test) {
EXPORT int test_check_by_value(struct test test) {
print_offsets();
printf("C: Value of a is %c\n", test.a);
assert(test.a == 1);
printf("C: Value of a is %i\n", test.a);
//assert(test.a == 1);
printf("C: Value of b is %c\n", test.b);
assert(test.b == 'b');
//assert(test.b == 'b');
printf("C: Value of c is %lf\n", test.c);
assert(test.c == 3.0);
//assert(test.c == 3.0);
printf("C: Value of d is %c\n", test.d);
assert(test.d == 'd');
//assert(test.d == 'd');
printf("C: Value of e is %s\n", test.e);
assert(test.e == NULL);
//assert(test.e == NULL);
printf("C: Value of f is %f\n", test.f);
assert(test.f == 6.0);
//assert(test.f == 6.0);
printf("C: Value of g is %f\n", test.g);
assert(strcmp(test.g, "foo") == 0);
printf("C: Value of g is %i\n", test.h);
assert(test.h == 8);
//assert(strcmp(test.g, "foo") == 0);
printf("C: Value of h is %i\n", test.h);
//assert(test.h == 8);
printf("C: Value of i is %s\n", test.i);
assert(test.i == NULL);
//assert(test.i == NULL);
printf("C: Value of j is %i\n", test.j);
assert(test.j == 10);
//assert(test.j == 10);
printf("C: Value of k is %i\n", test.k);
assert(test.k == 11);
//assert(test.k == 11);
printf("C: Value of l is %i\n", test.l);
assert(test.l == 12);
//assert(test.l == 12);
printf("C: Value of m is %i\n", test.m);
assert(test.m == 13);
//assert(test.m == 13);
printf("C: Value of n is %i\n", test.n);
assert(test.n == 14);
//assert(test.n == 14);
}
EXPORT struct test* test_new() {

2
libtest.h
View File

@ -2,6 +2,8 @@ void print_string_pointer(char* p);
void print_offsets();
void check_offset(int member_index, int offset);
struct test* init_struct(struct test* test);
int color_check(struct color* test);
int color_check_by_value(struct color color);
int test_check(struct test* test);
int test_check_by_value(struct test test);
struct test* test_new();

12
manifest.scm
View File

@ -3,7 +3,13 @@
;; that accepts a '--manifest' (or '-m') option.
(specifications->manifest (list "gcc-toolchain"
"guile-next"
"racket"
"libffi"
"chibi-scheme"
"chicken"
"stklos"))
"guile-next"
"gambit-c"
"gerbil"
"racket"
"mosh"
"stklos"
"openjdk"))

2
retropikzel/r7rs-pffi.sld
View File

@ -18,6 +18,7 @@
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer-address
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!
@ -269,6 +270,7 @@
pffi-pointer-null
pffi-pointer-null?
pffi-pointer-allocate
pffi-pointer-address
pffi-pointer?
pffi-pointer-free
pffi-pointer-set!

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

@ -19,7 +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 'string) (size-of-pointer))
((eq? type 'struct) (size-of-pointer))
((eq? type 'callback) (size-of-pointer))
((eq? type 'void) 0)
(else #f))))
(define pffi-shared-object-load
(lambda (headers path . options)
@ -46,6 +50,10 @@
(lambda (size)
(pointer-allocate size)))
(define pffi-pointer-address
(lambda (pointer)
(pointer-address pointer)))
(define pffi-pointer-free
(lambda (pointer)
(pointer-free pointer)))
@ -217,4 +225,4 @@
(define pffi-struct-dereference
(lambda (struct)
(pffi-struct-pointer struct)))
(pffi-pointer-address (pffi-struct-pointer struct))))

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

@ -137,7 +137,7 @@
(define pffi-pointer-address
(lambda (pointer)
(invoke pointer 'get (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1) 0)))
(invoke pointer 'address)))
(define pffi-pointer-null
(lambda ()

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

@ -85,7 +85,11 @@
(cadr (assoc 'additional-paths options))
(list)))
(additional-versions (if (assoc 'additional-versions options)
(cadr (assoc 'additional-versions options))
(map (lambda (version)
(if (number? version)
(number->string version)
version))
(cadr (assoc 'additional-versions options)))
(list)))
(slash (cond-expand (windows (string #\\)) (else "/")))
(auto-load-paths

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

@ -61,6 +61,9 @@
(c-declare "void* pointer_allocate(int size) { return malloc(size); }")
(define-c (maybe-null void*) (pointer-allocate pointer_allocate) (int))
(c-declare "int pointer_address(void* pointer) { return (int)&pointer; }")
(define-c int (pointer-address pointer_address) ((maybe-null void*)))
(c-declare "void pointer_free(void* pointer) { free(pointer); }")
(define-c void (pointer-free pointer_free) ((maybe-null void*)))

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

@ -19,10 +19,10 @@
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'void*)
((equal? type 'string) 'string)
((equal? type 'string) 'void*)
((equal? type 'void) 'void)
((equal? type 'callback) 'callback)
((equal? type 'struct) 'void*)
((equal? type 'struct) 'char*)
(else #f))))
(define pffi-pointer?
@ -79,7 +79,7 @@
(define pffi-pointer-address
(lambda (pointer)
(address pointer)))
(pointer-address pointer)))
(define pffi-struct-dereference
(lambda (struct)

119
test.scm
View File

@ -430,6 +430,17 @@
(assert equal? (pffi-pointer? test-pointer) #t)
(assert equal? (pffi-pointer-null? test-pointer) #f)
;; pffi-pointer-address
(print-header 'pffi-pointer-allocate)
(define test-pointer1 (pffi-pointer-allocate 100))
(debug test-pointer1)
(debug (pffi-pointer? test-pointer1))
(assert equal? (pffi-pointer? test-pointer1) #t)
;(debug (pffi-pointer-address test-pointer1))
;(assert equal? (number? (pffi-pointer-address test-pointer1)) #t)
;; pffi-pointer?
(print-header 'pffi-pointer?)
@ -702,9 +713,9 @@
(debug (pffi-struct-get struct-test 'n))
(assert = (pffi-struct-get struct-test 'n) 14.0)
;; pffi-struct-set!
;; pffi-struct-set! 1
(print-header 'pffi-struct-set!)
(print-header "pffi-struct-set! 1")
(pffi-define c-test-check c-testlib 'test_check 'int (list 'pointer))
(define struct-test1 (pffi-struct-make 'test
@ -795,6 +806,68 @@
(debug (pffi-struct-get struct-test2 'n))
(assert = (pffi-struct-get struct-test2 'n) 14.0)
;; pffi-struct-dereference
(print-header "pffi-struct-dereference 1")
(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int (list 'struct))
(define struct-color (pffi-struct-make 'color '((int8 . r)
(int8 . g)
(int8 . b)
(int8 . a))))
(debug (pffi-struct-set! struct-color 'r 100))
(debug (pffi-struct-set! struct-color 'g 101))
(debug (pffi-struct-set! struct-color 'b 102))
(debug (pffi-struct-set! struct-color 'a 103))
(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0)
(print-header "pffi-struct-dereference 2")
(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int (list 'struct))
(define struct-test3 (pffi-struct-make 'test
'((int8 . a)
(char . b)
(double . c)
(char . d)
(pointer . e)
(float . f)
(pointer . g)
(int8 . h)
(pointer . i)
(int . j)
(int . k)
(int . l)
(double . m)
(float . n))))
(debug (pffi-struct-set! struct-test3 'a 1))
(debug (pffi-struct-set! struct-test3 'b #\b))
(debug (pffi-struct-set! struct-test3 'c 3.0))
(debug (pffi-struct-set! struct-test3 'd #\d))
(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null)))
(debug (pffi-struct-set! struct-test3 'f 6.0))
(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo")))
(debug (pffi-struct-set! struct-test3 'h 8))
(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null)))
(debug (pffi-struct-set! struct-test3 'j 10))
(debug (pffi-struct-set! struct-test3 'k 11))
(debug (pffi-struct-set! struct-test3 'l 12))
(debug (pffi-struct-set! struct-test3 'm 13.0))
(debug (pffi-struct-set! struct-test3 'n 14.0))
(debug (pffi-struct-get struct-test3 'a))
(debug (pffi-struct-get struct-test3 'b))
(debug (pffi-struct-get struct-test3 'c))
(debug (pffi-struct-get struct-test3 'd))
(debug (pffi-struct-get struct-test3 'e))
(debug (pffi-struct-get struct-test3 'f))
(debug (pffi-struct-get struct-test3 'g))
(debug (pffi-struct-get struct-test3 'h))
(debug (pffi-struct-get struct-test3 'i))
(debug (pffi-struct-get struct-test3 'j))
(debug (pffi-struct-get struct-test3 'k))
(debug (pffi-struct-get struct-test3 'l))
(debug (pffi-struct-get struct-test3 'm))
(debug (pffi-struct-get struct-test3 'n))
(c-test-check-by-value (pffi-struct-dereference struct-test3))
;; pffi-define-callback
(print-header 'pffi-define-callback)
@ -831,46 +904,4 @@
(pffi-pointer-get array 'int (* (pffi-size-of 'int) 2))))
(debug sorted)
(assert equal? sorted (list 1 2 3))
;; pffi-struct-dereference
(print-header 'pffi-struct-dereference)
;; pffi-struct-set!
(print-header 'pffi-struct-set!)
(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int (list 'struct))
(define struct-test3 (pffi-struct-make 'test
'((int8 . a)
(char . b)
(double . c)
(char . d)
(pointer . e)
(float . f)
(pointer . g)
(int8 . h)
(pointer . i)
(int . j)
(int . k)
(int . l)
(double . m)
(float . n))))
(pffi-struct-set! struct-test3 'a 1)
(pffi-struct-set! struct-test3 'b #\b)
(pffi-struct-set! struct-test3 'c 3.0)
(pffi-struct-set! struct-test3 'd #\d)
(pffi-struct-set! struct-test3 'e (pffi-pointer-null))
(pffi-struct-set! struct-test3 'f 6.0)
(pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))
(pffi-struct-set! struct-test3 'h 8)
(pffi-struct-set! struct-test3 'i (pffi-pointer-null))
(pffi-struct-set! struct-test3 'j 10)
(pffi-struct-set! struct-test3 'k 11)
(pffi-struct-set! struct-test3 'l 12)
(pffi-struct-set! struct-test3 'm 13.0)
(pffi-struct-set! struct-test3 'n 14.0)
(c-test-check-by-value (pffi-struct-dereference struct-test3))
(exit 0)