diff --git a/Makefile b/Makefile index bafb3f5..5cfdbd4 100644 --- a/Makefile +++ b/Makefile @@ -24,8 +24,10 @@ retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi. test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so libtest.so ${CHIBI} test.scm -CHICKEN5=csc -X r7rs -R r7rs -I. -CHICKEN5_LIB=csc -X r7rs -R r7rs -I. -include-path ./retropikzel -s -J +CHICKEN5=SCMC=csc CSCFLAGS="-I. " compile-r7rs main.scm +#CHICKEN5=csc -X r7rs -R r7rs -uses scheme.base -I. +#CHICKEN5_LIB=csc -X r7rs -R r7rs -uses r7rs -I. -include-path ./retropikzel -s -J +#CHICKEN5_LIB=csc -X r7rs -R r7rs -uses r7rs -unit retropikzel.r7rs-pffi -include-path ./retropikzel -s -J test-chicken5-podman-amd65: clean libtest.so cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld" @@ -37,9 +39,10 @@ test-chicken5-docker: clean libtest.so docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test" test-chicken5: clean libtest.so - cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld - ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld - ${CHICKEN5} test.scm && ./test + #cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld + #${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld + ${CHICKEN5} test.scm + ./test CHICKEN6=csc -I. CHICKEN6_LIB=csc -I. -include-path ./retropikzel -s -J diff --git a/libtest.c b/libtest.c index 8fa31fb..9d0f2f6 100644 --- a/libtest.c +++ b/libtest.c @@ -182,7 +182,7 @@ EXPORT int test_check(struct test* test) { assert(test->n == 14); } -EXPORT struct test* test_new(struct test* test) { +EXPORT struct test* test_new() { print_offsets(); struct test* t = malloc(sizeof(struct test)); t->a = 1; diff --git a/libtest.h b/libtest.h index 6f22df3..bb1042b 100644 --- a/libtest.h +++ b/libtest.h @@ -1,2 +1,6 @@ -struct test* function(struct test* test); - +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 test_check(struct test* test); +struct test* test_new(); diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index e4fa951..295a5c8 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -33,7 +33,7 @@ pffi-define pffi-define-callback) (include-shared "r7rs-pffi/r7rs-pffi-chibi")) - (chicken5 + (chicken-5 (import (scheme base) (scheme write) (scheme char) @@ -458,7 +458,7 @@ pffi-pointer? pffi-pointer-free pffi-pointer-set! - ;pffi-pointer-get + pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make @@ -531,8 +531,8 @@ (else (error "Unsupported implementation"))) (cond-expand (chibi (include "r7rs-pffi/chibi.scm")) - (chicken5 (include "r7rs-pffi/chicken.scm")) - (chicken6 (include "chicken6.scm")) + (chicken-5 (include "r7rs-pffi/chicken5.scm")) + (chicken-6 (include "chicken6.scm")) (cyclone (include "r7rs-pffi/cyclone.scm")) (gambit (include "r7rs-pffi/gambit.scm")) (gauche (include "r7rs-pffi/gauche.scm")) @@ -548,5 +548,9 @@ (tr7 (include "r7rs-pffi/tr7.scm")) (ypsilon (include "r7rs-pffi/ypsilon.scm")) (else #t)) - (include "r7rs-pffi/struct.scm") - (include "r7rs-pffi/main.scm")) + (cond-expand + (stklos (include "retropikzel/r7rs-pffi/struct.scm")) ; FIXME temporarily for stklos 2.10 + (else (include "r7rs-pffi/struct.scm"))) + (cond-expand + (stklos (include "retropikzel/r7rs-pffi/main.scm")) ; FIXME temporarily for stklos 2.10 + (else (include "r7rs-pffi/main.scm")))) diff --git a/retropikzel/r7rs-pffi/chicken5.scm b/retropikzel/r7rs-pffi/chicken5.scm index aff207e..586c522 100644 --- a/retropikzel/r7rs-pffi/chicken5.scm +++ b/retropikzel/r7rs-pffi/chicken5.scm @@ -1,5 +1,5 @@ -(define pffi-type->native-type +(define pffi-type->native-type ; Chicken has this procedure in three places (lambda (type) (cond ((equal? type 'int8) 'byte) ((equal? type 'uint8) 'unsigned-byte) @@ -22,6 +22,7 @@ ((equal? type 'pointer) 'c-pointer) ((equal? type 'void) 'void) ((equal? type 'callback) 'c-pointer) + ((equal? type 'struct) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type)))) ) (define pffi-pointer? @@ -31,7 +32,7 @@ (define-syntax pffi-define (er-macro-transformer (lambda (expr rename compare) - (let* ((pffi-type->native-type + (let* ((pffi-type->native-type ; Chicken has this procedure in three places (lambda (type) (cond ((equal? type 'int8) 'byte) ((equal? type 'uint8) 'unsigned-byte) @@ -54,6 +55,7 @@ ((equal? type 'pointer) 'c-pointer) ((equal? type 'void) 'void) ((equal? type 'callback) 'c-pointer) + ((equal? type 'struct) 'c-pointer) (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)))))))) @@ -72,7 +74,7 @@ (define-syntax pffi-define-callback (er-macro-transformer (lambda (expr rename compare) - (let* ((pffi-type->native-type + (let* ((pffi-type->native-type ; Chicken has this procedure in three places (lambda (type) (cond ((equal? type 'int8) 'byte) ((equal? type 'uint8) 'unsigned-byte) @@ -95,6 +97,7 @@ ((equal? type 'pointer) 'c-pointer) ((equal? type 'void) 'void) ((equal? type 'callback) 'c-pointer) + ((equal? type 'struct) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) (scheme-name (car (cdr expr))) (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr))))))) @@ -246,5 +249,5 @@ (define pffi-struct-dereference (lambda (struct) - (pffi-struct-pointer struct))) + (pffi-pointer-address (pffi-struct-pointer struct)))) diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index 740b4cb..1ae315b 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -1,5 +1,5 @@ (cond-expand - ((or chicken5 chicken6) + ((or chicken-5 chicken-6) (define-syntax pffi-init (er-macro-transformer (lambda (expr rename compare) diff --git a/retropikzel/r7rs-pffi/stklos.scm b/retropikzel/r7rs-pffi/stklos.scm index 063e232..1126fb6 100644 --- a/retropikzel/r7rs-pffi/stklos.scm +++ b/retropikzel/r7rs-pffi/stklos.scm @@ -21,6 +21,7 @@ ((equal? type 'pointer) :pointer) ((equal? type 'string) :string) ((equal? type 'void) :void) + ((equal? type 'struct) :void) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define pffi-pointer? @@ -39,8 +40,7 @@ (define pffi-define-callback (lambda () - (error "Not implemented") - )) + (error "Not implemented"))) ; If youre reading this, this is just a temp hack. Dont judge me :D (define pffi-size-of @@ -76,7 +76,7 @@ (lambda () (let ((p (allocate-bytes 0))) (free-bytes p) - p))) + p))) (define pffi-string->pointer (lambda (string-content) @@ -103,9 +103,7 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (let ((null-pointer (pffi-pointer-null)) - (offset-address (cpointer-data pointer))) - (cpointer-data-set! null-pointer offset-address)))) + (error "Not implemented"))) (define pffi-pointer-get (lambda (pointer type offset) diff --git a/retropikzel/r7rs-pffi/struct.scm b/retropikzel/r7rs-pffi/struct.scm index 0ee60a8..ae9cb73 100644 --- a/retropikzel/r7rs-pffi/struct.scm +++ b/retropikzel/r7rs-pffi/struct.scm @@ -47,7 +47,8 @@ (round-to-next-modulo-of size largest-member-size))))) (cons 'offsets offsets)))) -(define (pffi-struct-make name members . pointer) +(define pffi-struct-make + (lambda (name members . pointer) (for-each (lambda (member) (when (not (pair? member)) @@ -62,7 +63,7 @@ (offsets (cdr (assoc 'offsets size-and-offsets))) (pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer))) (name (if (string? name) name (symbol->string name)))) - (struct-make name size pointer offsets))) + (struct-make name size pointer offsets)))) (define (pffi-struct-offset-get struct member-name) (when (not (assoc member-name (pffi-struct-members struct))) diff --git a/test.scm b/test.scm old mode 100644 new mode 100755