From 1b08e57be2590dcadffcd5412eaa18dc64337296 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Thu, 13 Mar 2025 18:57:05 +0200 Subject: [PATCH 01/19] Backup --- retropikzel/pffi.sld | 21 +++++++++++---------- retropikzel/pffi/gambit.scm | 14 ++++++-------- retropikzel/pffi/shared/main.scm | 2 +- 3 files changed, 18 insertions(+), 19 deletions(-) diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index d64a8f6..25a30e0 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -141,25 +141,26 @@ (scheme process-context) (only (gambit) c-declare c-lambda c-define)) (export pffi-init - pffi-size-of - pffi-type? - pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + ;pffi-size-of + ;pffi-type? + ;pffi-align-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate + ;pffi-pointer-address ;pffi-pointer? ;pffi-pointer-free ;pffi-pointer-set! ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string - pffi-struct-make - pffi-struct-pointer - pffi-struct-offset-get - pffi-struct-get - pffi-struct-set! + ;pffi-struct-make + ;pffi-struct-pointer + ;pffi-struct-offset-get + ;pffi-struct-get + ;pffi-struct-set! ;pffi-define ;pffi-define-callback )) diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index bd16fbd..bc5b647 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -1,10 +1,5 @@ (c-declare "#include ") -;(c-declare "int size_of_int8() { return sizeof(int8_t);}") -;(define size-of-int8 (c-lambda () int "__return(sizeof(int8_t));")) -;(define int8-size ((c-lambda () int "__return(sizeof(int8_t));"))) -;(define int8-size (c-lambda () int "__return(1);")) - (define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));")) (define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));")) (define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));")) @@ -26,7 +21,7 @@ (define size-of-void* (c-lambda () int "___return(sizeof(void*));")) -(define size-of-type +#;(define size-of-type (lambda (type) (cond ((eq? type 'int8) (size-of-int8_t)) ((eq? type 'uint8) (size-of-uint8_t)) @@ -49,8 +44,11 @@ ((eq? type 'pointer) (size-of-void*)) (else (error "Can not get size of unknown type" type))))) -(define-macro (pffi-shared-object-load header) - `(c-declare ,(string-append "#include <" header ">"))) +#;(define-macro (pffi-shared-object-load headers) + `@,(map (lambda (header) + '(c-declare ,(string-append "#include <" header ">"))) + headers)) + #;(define-syntax pffi-shared-object-load (syntax-rules () diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 3f9263f..d71e945 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -66,7 +66,7 @@ (gambit (define-macro (pffi-shared-object-auto-load headers object-name options) - `(pffi-shared-object-load ,(car headers)))) + `(pffi-shared-object-load headers))) ((or chicken cyclone) (define-syntax pffi-shared-object-auto-load From 59dd50619d7df3bd1134dbc67b0ec157de5e9cc3 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 14 Mar 2025 07:41:35 +0200 Subject: [PATCH 02/19] Commented out some tests to see how far they pass --- retropikzel/pffi.sld | 1 + retropikzel/pffi/mosh.scm | 4 +++ src/libtest.c | 36 ++++++++++++++--------- test.scm | 62 ++++++++++++++++++++++++++------------- 4 files changed, 68 insertions(+), 35 deletions(-) diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index d64a8f6..5e23e4c 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -337,6 +337,7 @@ pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate + pffi-pointer-address pffi-pointer? pffi-pointer-free pffi-pointer-set! diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm index 637d1c9..a44bd6d 100644 --- a/retropikzel/pffi/mosh.scm +++ b/retropikzel/pffi/mosh.scm @@ -40,6 +40,10 @@ (lambda (size) (malloc size))) +(define pffi-pointer-address + (lambda (pointer) + (pointer->integer pointer))) + (define pffi-pointer? (lambda (object) (pointer? object))) diff --git a/src/libtest.c b/src/libtest.c index 43b3bf6..99f0213 100644 --- a/src/libtest.c +++ b/src/libtest.c @@ -187,29 +187,37 @@ EXPORT int test_check(struct test* test) { printf("C: Value of b is %c\n", test->b); assert(test->b == 'b'); printf("C: Value of c is %lf\n", test->c); - assert(test->c == 3.0); + //FIXME + //assert(test->c == 3.0); printf("C: Value of d is %c\n", test->d); assert(test->d == 'd'); printf("C: Value of e is %s\n", test->e); assert(test->e == NULL); printf("C: Value of f is %f\n", test->f); - assert(test->f == 6.0); - printf("C: Value of g is %f\n", test->g); - assert(strcmp(test->g, "foo") == 0); + //FIXME + //assert(test->f == 6.0); + //FIXME + //printf("C: Value of g is %f\n", test->g); + //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); - printf("C: Value of j is %i\n", test->j); - assert(test->j == 10); - printf("C: Value of k is %i\n", test->k); - assert(test->k == 11); - printf("C: Value of l is %i\n", test->l); - assert(test->l == 12); - printf("C: Value of m is %i\n", test->m); - assert(test->m == 13); - printf("C: Value of n is %i\n", test->n); - assert(test->n == 14); + //FIXME + //printf("C: Value of j is %i\n", test->j); + //assert(test->j == 10); + //FIXME + //printf("C: Value of k is %i\n", test->k); + //assert(test->k == 11); + //FIXME + //printf("C: Value of l is %i\n", test->l); + //assert(test->l == 12); + //FIXME + //printf("C: Value of m is %i\n", test->m); + //assert(test->m == 13); + //FIXME + //printf("C: Value of n is %i\n", test->n); + //assert(test->n == 14); } EXPORT int test_check_by_value(struct test test) { diff --git a/test.scm b/test.scm index c28bbed..9123d7e 100755 --- a/test.scm +++ b/test.scm @@ -728,32 +728,43 @@ (debug (pffi-struct-get struct-test 'b)) (assert char=? (pffi-struct-get struct-test 'b) #\b) (debug (pffi-struct-get struct-test 'c)) -(assert = (pffi-struct-get struct-test 'c) 3.0) +;; FIXME +;(assert = (pffi-struct-get struct-test 'c) 3.0) (debug (pffi-struct-get struct-test 'd)) (assert char=? (pffi-struct-get struct-test 'd) #\d) (debug (pffi-struct-get struct-test 'e)) (debug (pffi-pointer-null? (pffi-struct-get struct-test 'e))) (assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'e)) #t) (debug (pffi-struct-get struct-test 'f)) -(assert = (pffi-struct-get struct-test 'f) 6.0) +;; FIXME +;(assert = (pffi-struct-get struct-test 'f) 6.0) (debug (pffi-struct-get struct-test 'g)) -(debug (pffi-pointer->string (pffi-struct-get struct-test 'g))) -(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) +;; FIXME +;(debug (pffi-pointer->string (pffi-struct-get struct-test 'g))) +;; FIXME +;(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) (debug (pffi-struct-get struct-test 'h)) (assert = (pffi-struct-get struct-test 'h) 8) (debug (pffi-struct-get struct-test 'i)) (debug (pffi-pointer-null? (pffi-struct-get struct-test 'i))) -(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t) -(debug (pffi-struct-get struct-test 'j)) -(assert = (pffi-struct-get struct-test 'j) 10) +;; FIXME +;(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t) +;; FIXME +;(debug (pffi-struct-get struct-test 'j)) +;; FIXME +;(assert = (pffi-struct-get struct-test 'j) 10) (debug (pffi-struct-get struct-test 'k)) -(assert = (pffi-struct-get struct-test 'k) 11) +;; FIXME +;(assert = (pffi-struct-get struct-test 'k) 11) (debug (pffi-struct-get struct-test 'l)) -(assert = (pffi-struct-get struct-test 'l) 12) +;; FIXME +;(assert = (pffi-struct-get struct-test 'l) 12) (debug (pffi-struct-get struct-test 'm)) -(assert = (pffi-struct-get struct-test 'm) 13.0) +;; FIXME +;(assert = (pffi-struct-get struct-test 'm) 13.0) (debug (pffi-struct-get struct-test 'n)) -(assert = (pffi-struct-get struct-test 'n) 14.0) +;; FIXME +;(assert = (pffi-struct-get struct-test 'n) 14.0) ;; pffi-struct-set! 1 @@ -822,31 +833,40 @@ (debug (pffi-struct-get struct-test2 'b)) (assert char=? (pffi-struct-get struct-test2 'b) #\b) (debug (pffi-struct-get struct-test2 'c)) -(assert = (pffi-struct-get struct-test2 'c) 3) +;; FIXME +;(assert = (pffi-struct-get struct-test2 'c) 3) (debug (pffi-struct-get struct-test2 'd)) (assert char=? (pffi-struct-get struct-test2 'd) #\d) (debug (pffi-struct-get struct-test2 'e)) (debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e))) (assert equal? (pffi-pointer-null? (pffi-struct-get struct-test2 'e)) #t) (debug (pffi-struct-get struct-test2 'f)) -(assert = (pffi-struct-get struct-test2 'f) 6.0) -(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) -(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) +;; FIXME +;(assert = (pffi-struct-get struct-test2 'f) 6.0) +;; FIXME +;(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) +;(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) (debug (pffi-struct-get struct-test2 'h)) (assert = (pffi-struct-get struct-test2 'h) 8) (debug (pffi-struct-get struct-test2 'i)) (debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i))) -(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) +;; FIXME +;(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) (debug (pffi-struct-get struct-test2 'j)) -(assert = (pffi-struct-get struct-test2 'j) 10) +;; FIXME +;(assert = (pffi-struct-get struct-test2 'j) 10) (debug (pffi-struct-get struct-test2 'k)) -(assert = (pffi-struct-get struct-test2 'k) 11) +;; FIXME +;(assert = (pffi-struct-get struct-test2 'k) 11) (debug (pffi-struct-get struct-test2 'l)) -(assert = (pffi-struct-get struct-test2 'l) 12) +;; FIXME +;(assert = (pffi-struct-get struct-test2 'l) 12) (debug (pffi-struct-get struct-test2 'm)) -(assert = (pffi-struct-get struct-test2 'm) 13.0) +;; FIXME +;(assert = (pffi-struct-get struct-test2 'm) 13.0) (debug (pffi-struct-get struct-test2 'n)) -(assert = (pffi-struct-get struct-test2 'n) 14.0) +;; FIXME +;(assert = (pffi-struct-get struct-test2 'n) 14.0) ;; pffi-struct-dereference From f529fcab52812f05e4b176ce4e8b13ee7424c393 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 06:47:10 +0200 Subject: [PATCH 03/19] Bring in the shared pointer->string and string->pointer implementation --- retropikzel/pffi/mosh.scm | 5 ----- 1 file changed, 5 deletions(-) diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm index d6e5657..c0c2b47 100644 --- a/retropikzel/pffi/mosh.scm +++ b/retropikzel/pffi/mosh.scm @@ -112,11 +112,6 @@ (lambda (pointer) (pointer->string pointer))) -;; FIXME -(define pffi-pointer-address - (lambda (pointer) - 0)) - (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) From a91d07398cf5bc00a4a44bd5d26731733d8e7b99 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 06:49:38 +0200 Subject: [PATCH 04/19] Uncomment all tests as accidentally merged in commented out version from mosh branch --- test.scm | 62 +++++++++++++++++++------------------------------------- 1 file changed, 21 insertions(+), 41 deletions(-) diff --git a/test.scm b/test.scm index 9123d7e..c28bbed 100755 --- a/test.scm +++ b/test.scm @@ -728,43 +728,32 @@ (debug (pffi-struct-get struct-test 'b)) (assert char=? (pffi-struct-get struct-test 'b) #\b) (debug (pffi-struct-get struct-test 'c)) -;; FIXME -;(assert = (pffi-struct-get struct-test 'c) 3.0) +(assert = (pffi-struct-get struct-test 'c) 3.0) (debug (pffi-struct-get struct-test 'd)) (assert char=? (pffi-struct-get struct-test 'd) #\d) (debug (pffi-struct-get struct-test 'e)) (debug (pffi-pointer-null? (pffi-struct-get struct-test 'e))) (assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'e)) #t) (debug (pffi-struct-get struct-test 'f)) -;; FIXME -;(assert = (pffi-struct-get struct-test 'f) 6.0) +(assert = (pffi-struct-get struct-test 'f) 6.0) (debug (pffi-struct-get struct-test 'g)) -;; FIXME -;(debug (pffi-pointer->string (pffi-struct-get struct-test 'g))) -;; FIXME -;(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) +(debug (pffi-pointer->string (pffi-struct-get struct-test 'g))) +(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) (debug (pffi-struct-get struct-test 'h)) (assert = (pffi-struct-get struct-test 'h) 8) (debug (pffi-struct-get struct-test 'i)) (debug (pffi-pointer-null? (pffi-struct-get struct-test 'i))) -;; FIXME -;(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t) -;; FIXME -;(debug (pffi-struct-get struct-test 'j)) -;; FIXME -;(assert = (pffi-struct-get struct-test 'j) 10) +(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t) +(debug (pffi-struct-get struct-test 'j)) +(assert = (pffi-struct-get struct-test 'j) 10) (debug (pffi-struct-get struct-test 'k)) -;; FIXME -;(assert = (pffi-struct-get struct-test 'k) 11) +(assert = (pffi-struct-get struct-test 'k) 11) (debug (pffi-struct-get struct-test 'l)) -;; FIXME -;(assert = (pffi-struct-get struct-test 'l) 12) +(assert = (pffi-struct-get struct-test 'l) 12) (debug (pffi-struct-get struct-test 'm)) -;; FIXME -;(assert = (pffi-struct-get struct-test 'm) 13.0) +(assert = (pffi-struct-get struct-test 'm) 13.0) (debug (pffi-struct-get struct-test 'n)) -;; FIXME -;(assert = (pffi-struct-get struct-test 'n) 14.0) +(assert = (pffi-struct-get struct-test 'n) 14.0) ;; pffi-struct-set! 1 @@ -833,40 +822,31 @@ (debug (pffi-struct-get struct-test2 'b)) (assert char=? (pffi-struct-get struct-test2 'b) #\b) (debug (pffi-struct-get struct-test2 'c)) -;; FIXME -;(assert = (pffi-struct-get struct-test2 'c) 3) +(assert = (pffi-struct-get struct-test2 'c) 3) (debug (pffi-struct-get struct-test2 'd)) (assert char=? (pffi-struct-get struct-test2 'd) #\d) (debug (pffi-struct-get struct-test2 'e)) (debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e))) (assert equal? (pffi-pointer-null? (pffi-struct-get struct-test2 'e)) #t) (debug (pffi-struct-get struct-test2 'f)) -;; FIXME -;(assert = (pffi-struct-get struct-test2 'f) 6.0) -;; FIXME -;(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) -;(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) +(assert = (pffi-struct-get struct-test2 'f) 6.0) +(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) +(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) (debug (pffi-struct-get struct-test2 'h)) (assert = (pffi-struct-get struct-test2 'h) 8) (debug (pffi-struct-get struct-test2 'i)) (debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i))) -;; FIXME -;(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) +(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) (debug (pffi-struct-get struct-test2 'j)) -;; FIXME -;(assert = (pffi-struct-get struct-test2 'j) 10) +(assert = (pffi-struct-get struct-test2 'j) 10) (debug (pffi-struct-get struct-test2 'k)) -;; FIXME -;(assert = (pffi-struct-get struct-test2 'k) 11) +(assert = (pffi-struct-get struct-test2 'k) 11) (debug (pffi-struct-get struct-test2 'l)) -;; FIXME -;(assert = (pffi-struct-get struct-test2 'l) 12) +(assert = (pffi-struct-get struct-test2 'l) 12) (debug (pffi-struct-get struct-test2 'm)) -;; FIXME -;(assert = (pffi-struct-get struct-test2 'm) 13.0) +(assert = (pffi-struct-get struct-test2 'm) 13.0) (debug (pffi-struct-get struct-test2 'n)) -;; FIXME -;(assert = (pffi-struct-get struct-test2 'n) 14.0) +(assert = (pffi-struct-get struct-test2 'n) 14.0) ;; pffi-struct-dereference From ad9a6778af8983febf10e3ff5f608a4ad6210d7c Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 06:55:49 +0200 Subject: [PATCH 05/19] Simplify Chibi code --- retropikzel/pffi/chibi.scm | 3 +-- src/chibi/pffi.stub | 11 +---------- 2 files changed, 2 insertions(+), 12 deletions(-) diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm index 9a015ed..e6bef02 100644 --- a/retropikzel/pffi/chibi.scm +++ b/retropikzel/pffi/chibi.scm @@ -165,8 +165,7 @@ (define argument->pointer (lambda (value type) - (cond ((pffi-pointer? value) value) - ((procedure? value) (scheme-procedure-to-pointer value)) + (cond ((procedure? value) (scheme-procedure-to-pointer value)) (else (let ((pointer (pffi-pointer-allocate (size-of-type type)))) (pffi-pointer-set! pointer type 0 value) pointer))))) diff --git a/src/chibi/pffi.stub b/src/chibi/pffi.stub index 69eb1ce..3196990 100644 --- a/src/chibi/pffi.stub +++ b/src/chibi/pffi.stub @@ -256,16 +256,7 @@ ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); void* c_avalues[nargs]; for(int i = 0; i < nargs; i++) { - if(atypes[i] == &ffi_type_pointer) { - if(sexp_booleanp(avalues[i])) { - void* p = NULL; - c_avalues[i] = &p; - } else { - c_avalues[i] = &sexp_cpointer_value(avalues[i]); - } - } else { - c_avalues[i] = sexp_cpointer_value(avalues[i]); - } + c_avalues[i] = sexp_cpointer_value(avalues[i]); } ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues); }") From 4d24c23a5cb92510506d9d72e7802d0f4e85ace6 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 06:57:22 +0200 Subject: [PATCH 06/19] Move gauche to using shared pointer->string and string->pointer --- retropikzel/pffi/gauche.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index 9e840eb..08a8745 100644 --- a/retropikzel/pffi/gauche.scm +++ b/retropikzel/pffi/gauche.scm @@ -113,11 +113,11 @@ ((equal? type 'void) (pointer-get-pointer pointer offset)) ((equal? type 'pointer) (pointer-get-pointer pointer offset))))) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (string->pointer string-content))) -(define pffi-pointer->string +#;(define pffi-pointer->string (lambda (pointer) (pointer->string pointer))) From 38d25678003358b046fc81d888a4ad219f21acb9 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 07:01:56 +0200 Subject: [PATCH 07/19] Move chicken 6 code to shared pointer->string and string->pointer implementation --- retropikzel/pffi/chicken6.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/retropikzel/pffi/chicken6.scm b/retropikzel/pffi/chicken6.scm index b5ec6fc..2a813f9 100644 --- a/retropikzel/pffi/chicken6.scm +++ b/retropikzel/pffi/chicken6.scm @@ -152,11 +152,11 @@ (lambda () (address->pointer 0))) -(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) -(pffi-define puts #f 'puts 'int (list 'pointer)) -(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int)) +;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) +;(pffi-define puts #f 'puts 'int (list 'pointer)) +;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int)) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (let* ((size (string-length string-content)) (pointer (pffi-pointer-allocate (+ size 1)))) @@ -174,7 +174,7 @@ ;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int)) ;(pffi-define strlen #f 'strlen 'int (list 'pointer)) -(define pffi-pointer->string +#;(define pffi-pointer->string (foreign-lambda* c-string ((c-pointer p)) "C_return((char*)p);")) From 701eb7420319448c835d2e4d1db11e82b354fcf2 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 07:06:54 +0200 Subject: [PATCH 08/19] Making room for more tests --- .gitignore | 1 + Makefile | 18 +++++++++--------- test.scm => tests/compliance.scm | 0 3 files changed, 10 insertions(+), 9 deletions(-) rename test.scm => tests/compliance.scm (100%) diff --git a/.gitignore b/.gitignore index da9d247..33b5b42 100644 --- a/.gitignore +++ b/.gitignore @@ -39,3 +39,4 @@ dockerfiles/build .scheme_testrunner core testfile.test +tests/compliance diff --git a/Makefile b/Makefile index e1287ec..d113f41 100644 --- a/Makefile +++ b/Makefile @@ -48,24 +48,24 @@ libtest.so: src/libtest.c libtest.a: libtest.o src/libtest.c ar rcs libtest.a libtest.o -test-script: libtest.so - SCHEME=${SCHEME} script-r7rs -I . test.scm +test-interpreter-compliance: libtest.so + SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm -test-script-docker: +test-interpreter-compliance-docker: docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} - docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . test.scm" + docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm" test-compile-library: libtest.so libtest.a libtest.o SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld -test-compile: test-compile-library - SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . test.scm - ./test +test-compiler-compliance: test-compile-library + SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . tests/compliance.scm + ./tests/compliance -test-compile-docker: libtest.so libtest.a +test-compiler-compliance-docker: libtest.so libtest.a docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld" - docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . test.scm && ./test" + docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . compliance.scm && ./test" clean: @rm -rf retropikzel/pffi/*.o* diff --git a/test.scm b/tests/compliance.scm similarity index 100% rename from test.scm rename to tests/compliance.scm From 66e4812f1105aa8fbf57317f40ea8cb6e6a2ace1 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Thu, 20 Mar 2025 19:25:35 +0200 Subject: [PATCH 09/19] Rename pffi-shared-object-auto-load to pffi-load and dont export pffi-shared-object-load --- README.md | 87 ++++++++++++-------------------- retropikzel/pffi.sld | 50 +++++++----------- retropikzel/pffi/shared/main.scm | 6 +-- tests/compliance.scm | 30 +++++------ 4 files changed, 67 insertions(+), 106 deletions(-) diff --git a/README.md b/README.md index bf8512a..a02a8d4 100644 --- a/README.md +++ b/README.md @@ -43,8 +43,7 @@ conforming to some specification. - [pffi-init](#pffi-init) - [pffi-size-of](#pffi-size-of) - [pffi-align-of](#pffi-align-of) - - [pffi-shared-object-auto-load](#pffi-shared-object-auto-load) - - [pffi-shared-object-load](#pffi-shared-object-load) + - [pffi-load](#pffi-load) - [pffi-pointer-null](#pffi-pointer-null) - [pffi-pointer-null?](#pffi-pointer-null?) - [pffi-pointer-allocate](#pffi-pointer-allocate) @@ -114,31 +113,31 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear ### Beta -| | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | -|--------------|:---------:|:------------:|:----------------------------:|:-----------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| -| Chibi | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | -| Chicken-5 | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| Gauche | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | -| Guile | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| Kawa | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| Racket | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | -| Saggittarius | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | +| | pffi-init | pffi-size-of | pffi-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | +|--------------|:---------:|:------------:|:---------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| +| Chibi | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | +| Chicken-5 | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | +| Gauche | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | +| Guile | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | +| Kawa | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | +| Racket | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | +| Saggittarius | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | ### Alpha -| | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | -|--------------|:---------:|:------------:|:----------------------------:|:-----------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| -| Cyclone | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | | -| Gambit | X | X | | | | | | X | | | | | | | X | X | X | X | X | | | -| Gerbil | X | | | | | | | | | | | | | | X | X | X | X | X | | | -| Larceny | X | | | | | | | | | | | | | | X | X | X | X | X | | | -| Mosh | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | -| Skint | X | | | | | | | | | | | | | | X | X | X | X | X | | | -| Stklos | X | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | | -| tr7 | | | | | | | | | | | | | | | X | X | X | X | X | | | -| Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | | | +| | pffi-init | pffi-size-of | pffi-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | +|--------------|:---------:|:------------:|:---------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| +| Cyclone | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | | +| Gambit | X | X | | | | | X | | | | | | | X | X | X | X | X | | | +| Gerbil | X | | | | | | | | | | | | | X | X | X | X | X | | | +| Larceny | X | | | | | | | | | | | | | X | X | X | X | X | | | +| Mosh | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | +| Skint | X | | | | | | | | | | | | | X | X | X | X | X | | | +| Stklos | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | | +| tr7 | | | | | | | | | | | | | | X | X | X | X | X | | | +| Ypsilon | | | | | | | | | | | | | | X | X | X | X | X | | | ### Not started @@ -267,9 +266,9 @@ Returns the size of the pffi-struct, pffi-enum or pffi-type. Returns the align of the type. -#### pffi-shared-object-auto-load +#### pffi-load -**pffi-shared-object-auto-load** headers shared-object-name [options] -> object +**pffi-load** headers shared-object-name [options] -> object Load given shared object automatically searching many predefined paths. @@ -291,33 +290,11 @@ Example: (define libc-stdlib (cond-expand - (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) - (else (pffi-shared-object-auto-load (list "stdlib.h") - "c" - '(additional-versions . ("6")) - '(additional-search-paths . (".")))))) - - -#### pffi-shared-object-load - -**pffi-shared-object-load** headers path [options] - -It is recommended to use the pffi-shared-object-auto-load instead of this -directly. - -Headers is a list of strings needed to be included, for example - - (list "curl/curl.h") - -Path is the full path of the shared object without any "lib" prefix or ".so/.dll" suffix. For example: - - "curl" - - -Options: - -- additional-versions - - List of different versions of library to try, for example (list ".0" ".1") + (windows (pffi-load (list "stdlib.h") "ucrtbase")) + (else (pffi-load (list "stdlib.h") + "c" + '(additional-versions . ("6")) + '(additional-search-paths . (".")))))) #### pffi-pointer-null @@ -438,8 +415,8 @@ Defines a new foreign function to be used from Scheme code. For example: (define libc-stdlib (cond-expand - (windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))) - (else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" "6"))))) + (windows (pffi-load (list "stdlib.h") (list) "ucrtbase" (list ""))) + (else (pffi-load (list "stdlib.h") (list) "c" (list "" "6"))))) (pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer)) (c-puts "Message brought to you by FFI!") @@ -452,8 +429,8 @@ Defines a new Sceme function to be used as callback to C code. For example: ; Load the shared library (define libc-stdlib (cond-expand - (windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))) - (else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" "6"))))) + (windows (pffi-load (list "stdlib.h") (list) "ucrtbase" (list ""))) + (else (pffi-load (list "stdlib.h") (list) "c" (list "" "6"))))) ; Define C function that takes a callback (pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback)) diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 2f8edf4..1694e08 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -13,8 +13,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -50,8 +49,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -84,8 +82,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -114,8 +111,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -144,8 +140,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -175,8 +170,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -205,8 +199,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-shared-object-auto-load - ;pffi-shared-object-load + ;pffi-load ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -237,8 +230,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -266,8 +258,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -302,8 +293,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-shared-object-auto-load - ;pffi-shared-object-load + ;pffi-load ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -332,8 +322,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -366,8 +355,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -397,8 +385,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -426,8 +413,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-shared-object-auto-load - ;pffi-shared-object-load + ;pffi-load ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -456,8 +442,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-shared-object-auto-load - pffi-shared-object-load + pffi-load pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -486,7 +471,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-shared-object-auto-load + ;pffi-load ;pffi-shared-object-load ;pffi-pointer-null ;pffi-pointer-null? @@ -515,8 +500,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-shared-object-auto-load - ;pffi-shared-object-load + ;pffi-load ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 2ecb7dd..dcdae6d 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -90,16 +90,16 @@ (cond-expand (gambit (define-macro - (pffi-shared-object-auto-load headers object-name options) + (pffi-load headers object-name options) `(pffi-shared-object-load ,(car headers)))) ((or chicken cyclone) - (define-syntax pffi-shared-object-auto-load + (define-syntax pffi-load (syntax-rules () ((_ headers object-name . options) (pffi-shared-object-load headers))))) (else - (define pffi-shared-object-auto-load + (define pffi-load (lambda (headers object-name . options) (let* ((additional-paths (if (assoc 'additional-paths options) (cdr (assoc 'additional-paths options)) diff --git a/tests/compliance.scm b/tests/compliance.scm index c28bbed..f27328c 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -386,27 +386,27 @@ (assert equal? (number? align-pointer) #t) (assert = align-pointer 8))) -;; pffi-shared-object-auto-load +;; pffi-load (print-header 'pffi-shared-object-auto-load) (define libc-stdlib (cond-expand - (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase")) - (else (pffi-shared-object-auto-load (list "stdlib.h") - "c" - '(additional-versions . ("0" "6")))))) + (windows (pffi-load (list "stdlib.h") "ucrtbase")) + (else (pffi-load (list "stdlib.h") + "c" + '(additional-versions . ("0" "6")))))) (debug libc-stdlib) (define c-testlib (cond-expand - (windows (pffi-shared-object-auto-load (list "libtest.h") - "test" - '(additional-paths . (".")))) - (else (pffi-shared-object-auto-load (list "libtest.h") - "test" - '(additional-paths . (".")))))) + (windows (pffi-load (list "libtest.h") + "test" + '(additional-paths . (".")))) + (else (pffi-load (list "libtest.h") + "test" + '(additional-paths . (".")))))) (debug c-testlib) @@ -661,10 +661,10 @@ (define libc-stdio (cond-expand ; FIXME Check that windows so file is correct - (windows (pffi-shared-object-auto-load (list "stdio.h") "ucrtbase")) - (else (pffi-shared-object-auto-load (list "stdio.h") - "c" - '(additional-versions . ("0" "6")))))) + (windows (pffi-load (list "stdio.h") "ucrtbase")) + (else (pffi-load (list "stdio.h") + "c" + '(additional-versions . ("0" "6")))))) (pffi-define c-fopen libc-stdio 'fopen 'pointer (list 'pointer 'pointer)) (define output-file (c-fopen (pffi-string->pointer "testfile.test") From fe5de3e73105381658fcc2d7fbc6ce7a49516a39 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 21 Mar 2025 07:16:39 +0200 Subject: [PATCH 10/19] Working on Gambit implementation --- Makefile | 1 + retropikzel/pffi/gambit.scm | 28 +++++++++++++++++----------- 2 files changed, 18 insertions(+), 11 deletions(-) diff --git a/Makefile b/Makefile index e1287ec..204f2b6 100644 --- a/Makefile +++ b/Makefile @@ -87,3 +87,4 @@ clean: @rm -rf test find . -name "core.1" -delete find . -name "*@gambit*" -delete + rm -rf retropikzel/pffi.c diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index bc5b647..54dfb88 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -20,8 +20,7 @@ (define size-of-double (c-lambda () int "___return(sizeof(double));")) (define size-of-void* (c-lambda () int "___return(sizeof(void*));")) - -#;(define size-of-type +(define size-of-type (lambda (type) (cond ((eq? type 'int8) (size-of-int8_t)) ((eq? type 'uint8) (size-of-uint8_t)) @@ -42,16 +41,23 @@ ((eq? type 'float) (size-of-float)) ((eq? type 'double) (size-of-double)) ((eq? type 'pointer) (size-of-void*)) + ((eq? type 'callback) (size-of-void*)) + ((eq? type 'void) (size-of-void*)) (else (error "Can not get size of unknown type" type))))) -#;(define-macro (pffi-shared-object-load headers) - `@,(map (lambda (header) - '(c-declare ,(string-append "#include <" header ">"))) - headers)) +#;(define-macro + (include-c-headers headers) + `(c-declare ,(apply string-append + (map + (lambda (header) + (string-append "#include <" header ">" (string #\newline))) + (list "stdio.h"))))) - -#;(define-syntax pffi-shared-object-load - (syntax-rules () - ((_ headers) - (c-declare "#include ")))) +(define-macro + (pffi-shared-object-auto-load headers object-name . options) + `(c-declare ,(apply string-append + (map + (lambda (header) + (string-append "#include <" header ">" (string #\newline))) + (cdr headers))))) From 7d39b4ee783b11ac506ca31a6ed727a0e39816fe Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 21 Mar 2025 07:30:16 +0200 Subject: [PATCH 11/19] Working on Gambit implementation --- Makefile | 4 ++++ retropikzel/pffi.sld | 2 +- retropikzel/pffi/shared/main.scm | 6 +----- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 4616ce1..cbeff94 100644 --- a/Makefile +++ b/Makefile @@ -88,3 +88,7 @@ clean: find . -name "core.1" -delete find . -name "*@gambit*" -delete rm -rf retropikzel/pffi.c + rm -rf tests/compliance.c + rm -rf tests/compliance.o + rm -rf tests/compliance.so + rm -rf tests/compliance diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index ea20e8c..6b5d4f1 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -135,7 +135,7 @@ (scheme char) (scheme file) (scheme process-context) - (only (gambit) c-declare c-lambda c-define)) + (only (gambit) c-declare c-lambda c-define define-macro)) (export pffi-init pffi-size-of pffi-type? diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index dcdae6d..0231293 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -88,11 +88,7 @@ res))) (cond-expand - (gambit - (define-macro - (pffi-load headers object-name options) - `(pffi-shared-object-load ,(car headers)))) - + (gambit #t) ((or chicken cyclone) (define-syntax pffi-load (syntax-rules () From 9fa2bf0b80b3466e7399162860cb09accf929093 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 21 Mar 2025 07:36:42 +0200 Subject: [PATCH 12/19] Fixing more stuff from auto-load to load --- tests/compliance.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/compliance.scm b/tests/compliance.scm index f27328c..6c31b09 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -388,7 +388,7 @@ ;; pffi-load -(print-header 'pffi-shared-object-auto-load) +(print-header 'pffi-load) (define libc-stdlib (cond-expand From d0206d3ce9ece7c6037ee46ba9daeaeac6247746 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 21 Mar 2025 07:45:13 +0200 Subject: [PATCH 13/19] Remove string type --- retropikzel/pffi/shared/main.scm | 1 - tests/compliance.scm | 2 -- 2 files changed, 3 deletions(-) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index dcdae6d..ce73330 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -66,7 +66,6 @@ unsigned-long float double - string pointer void)) diff --git a/tests/compliance.scm b/tests/compliance.scm index 6c31b09..0ccf3d5 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -99,8 +99,6 @@ (assert equal? (pffi-type? 'float) #t) (debug (pffi-type? 'double)) (assert equal? (pffi-type? 'double) #t) -(debug (pffi-type? 'string)) -(assert equal? (pffi-type? 'string) #t) (debug (pffi-type? 'pointer)) (assert equal? (pffi-type? 'pointer) #t) (debug (pffi-type? 'void)) From a0b316b47b0b3a7d69d60590eb243a5e3dfb9adc Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 22 Mar 2025 14:41:28 +0200 Subject: [PATCH 14/19] Progress --- Makefile | 21 ++-- include/libtest.h | 2 + retropikzel/pffi.sld | 27 ++--- retropikzel/pffi/gambit.scm | 172 ++++++++++++++++++++++++++++--- retropikzel/pffi/shared/main.scm | 8 +- src/libtest.c | 8 ++ tests/compliance.scm | 116 ++++++++++++--------- 7 files changed, 268 insertions(+), 86 deletions(-) diff --git a/Makefile b/Makefile index cbeff94..0ccd4d3 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,10 @@ -.PHONY=libtest.o libtest.so libtest.a documentation +.PHONY=libtest.o tests/libtest.so libtest.a documentation CC=gcc DOCKER=docker run -it -v ${PWD}:/workdir DOCKER_INIT=cd /workdir && make clean && VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}') -all: chibi gauche libtest.so libtest.o libtest.a +all: chibi gauche tests/libtest.so libtest.o libtest.a # apt-get install pandoc weasyprint docs: @@ -42,27 +42,30 @@ jenkinsfile: libtest.o: src/libtest.c ${CC} -o libtest.o -fPIC -c src/libtest.c -I./include -libtest.so: src/libtest.c - ${CC} -o libtest.so -shared -fPIC src/libtest.c -I./include +tests/libtest.so: src/libtest.c + ${CC} -o tests/libtest.so -shared -fPIC src/libtest.c -I./include libtest.a: libtest.o src/libtest.c ar rcs libtest.a libtest.o -test-interpreter-compliance: libtest.so +test-interpreter-compliance: tests/libtest.so SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm test-interpreter-compliance-docker: docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm" -test-compile-library: libtest.so libtest.a libtest.o +test-compile-library: tests/libtest.so libtest.a libtest.o SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld -test-compiler-compliance: test-compile-library - SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest libtest.o" compile-r7rs -I . tests/compliance.scm +test-compiler-compliance-compile: test-compile-library + SCHEME=${SCHEME} CFLAGS="-I../include -L.." LDFLAGS="-ltest" compile-r7rs -I . tests/compliance.scm ./tests/compliance -test-compiler-compliance-docker: libtest.so libtest.a +test-compiler-compliance: test-compiler-compliance-compile + ./tests/compliance + +test-compiler-compliance-docker: tests/libtest.so libtest.a docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld" docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . compliance.scm && ./test" diff --git a/include/libtest.h b/include/libtest.h index 86e229d..3a42d3b 100644 --- a/include/libtest.h +++ b/include/libtest.h @@ -13,3 +13,5 @@ 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(); +void takes_no_args(); +int takes_no_args_returns_int(); diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 6b5d4f1..bf677f1 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -140,23 +140,23 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load - ;pffi-pointer-null - ;pffi-pointer-null? - ;pffi-pointer-allocate - ;pffi-pointer-address - ;pffi-pointer? - ;pffi-pointer-free - ;pffi-pointer-set! - ;pffi-pointer-get - ;pffi-string->pointer - ;pffi-pointer->string + pffi-define-library + pffi-pointer-null + pffi-pointer-null? + pffi-pointer-allocate + pffi-pointer-address + pffi-pointer? + pffi-pointer-free + pffi-pointer-set! + pffi-pointer-get + pffi-string->pointer + pffi-pointer->string pffi-struct-make pffi-struct-pointer pffi-struct-offset-get pffi-struct-get pffi-struct-set! - ;pffi-define + pffi-define ;pffi-define-callback )) (gauche @@ -540,4 +540,5 @@ (ypsilon (include "pffi/ypsilon.scm"))) (include "pffi/shared/struct.scm") (include "pffi/shared/union.scm") - (include "pffi/shared/main.scm")) + (include "pffi/shared/main.scm") + ) diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index 54dfb88..f6b9f84 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -1,5 +1,11 @@ +(c-declare "#include ") (c-declare "#include ") +(define-macro + (pffi-init) + `(begin (c-define-type pointer (pointer void)) + (c-define-type callback (pointer void)))) + (define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));")) (define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));")) (define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));")) @@ -45,19 +51,157 @@ ((eq? type 'void) (size-of-void*)) (else (error "Can not get size of unknown type" type))))) -#;(define-macro - (include-c-headers headers) - `(c-declare ,(apply string-append - (map - (lambda (header) - (string-append "#include <" header ">" (string #\newline))) - (list "stdio.h"))))) +(define-macro + (pffi-define-library name headers object-name . options) + `(begin (define ,name #t) + (c-declare ,(apply string-append + (map + (lambda (header) + (string-append "#include <" header ">" (string #\newline))) + (cdr headers)))))) + +(define pointer? (c-lambda ((pointer void)) bool "___return(1);")) +(define pffi-pointer? + (lambda (object) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) #f) + (lambda () (pointer? object))))))) + +(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);")) + +(define pointer-null? (c-lambda ((pointer void)) bool "if(___arg1 == NULL) { ___return(1); } else { ___return(0); }")) +(define pffi-pointer-null? + (lambda (pointer) + (and (pffi-pointer? pointer) + (pointer-null? pointer)))) + +(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);")) + +(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);")) + +(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);")) + +(define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint16_t! (c-lambda ((pointer void) int unsigned-int16) void "*(uint16_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int32_t! (c-lambda ((pointer void) int int32) void "*(int32_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint32_t! (c-lambda ((pointer void) int unsigned-int32) void "*(uint32_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int64_t! (c-lambda ((pointer void) int int64) void "*(int64_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-uint64_t! (c-lambda ((pointer void) int unsigned-int64) void "*(uint64_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-char! (c-lambda ((pointer void) int char) void "*((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-short! (c-lambda ((pointer void) int short) void "*(short*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-unsigned-short! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned short*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-int! (c-lambda ((pointer void) int int) void "*(int*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-unsigned-int! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned int*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-long! (c-lambda ((pointer void) int long) void "*(long*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-unsigned-long! (c-lambda ((pointer void) int unsigned-int64) void "*(unsigned long*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-float! (c-lambda ((pointer void) int float) void "*(float*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-double! (c-lambda ((pointer void) int double) void "*(double*)((char*)___arg1 + ___arg2) = ___arg3;")) +(define pointer-set-c-pointer! (c-lambda ((pointer void) int (pointer void)) void "{ char* p = (char*)___arg1 + ___arg2; *(char**)p = ___arg3; }")) + +(define pffi-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)) + ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value)) + ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) + ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) + ((equal? type 'char) (pointer-set-c-char! pointer offset value)) + ((equal? type 'short) (pointer-set-c-short! pointer offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) + ((equal? type 'int) (pointer-set-c-int! pointer offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value)) + ((equal? type 'long) (pointer-set-c-long! pointer offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value)) + ((equal? type 'float) (pointer-set-c-float! pointer offset value)) + ((equal? type 'double) (pointer-set-c-double! pointer offset value)) + ((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) + ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) + +(define pointer-ref-c-int8_t (c-lambda ((pointer void) int) int8 "___return(*(int8_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint8_t (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int16_t (c-lambda ((pointer void) int) int16 "___return(*(int16_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint16_t (c-lambda ((pointer void) int) unsigned-int16 "___return(*(uint16_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int32_t (c-lambda ((pointer void) int) int32 "___return(*(int32_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint32_t (c-lambda ((pointer void) int) unsigned-int32 "___return(*(uint32_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int64_t (c-lambda ((pointer void) int) int64 "___return(*(int64_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-uint64_t (c-lambda ((pointer void) int) unsigned-int64 "___return(*(uint64_t*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-char (c-lambda ((pointer void) int) char "___return(*((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-short (c-lambda ((pointer void) int) short "___return(*(short*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-unsigned-short (c-lambda ((pointer void) int) unsigned-short "___return(*(unsigned short*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-int (c-lambda ((pointer void) int) int "___return(*(int*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-unsigned-int (c-lambda ((pointer void) int) unsigned-int "___return(*(unsigned int*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-long (c-lambda ((pointer void) int) long "___return(*(long*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-unsigned-long (c-lambda ((pointer void) int) unsigned-long "___return(*(unsigned long*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-float (c-lambda ((pointer void) int) float "___return(*(float*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-double (c-lambda ((pointer void) int) double "___return(*(double*)((char*)___arg1 + ___arg2));")) +(define pointer-ref-c-pointer (c-lambda ((pointer void) int) (pointer void) " char* p = (char*)___arg1 + ___arg2; ___return(*(char**)p);")) + + +(define pffi-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)) + ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset)) + ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset)) + ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset)) + ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) + ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) + ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) + ((equal? type 'char) (pointer-ref-c-char pointer offset)) + ((equal? type 'short) (pointer-ref-c-short pointer offset)) + ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) + ((equal? type 'int) (pointer-ref-c-int pointer offset)) + ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) + ((equal? type 'long) (pointer-ref-c-long pointer offset)) + ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) + ((equal? type 'float) (pointer-ref-c-float pointer offset)) + ((equal? type 'double) (pointer-ref-c-double pointer offset)) + ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) + ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) (define-macro - (pffi-shared-object-auto-load headers object-name . options) - `(c-declare ,(apply string-append - (map - (lambda (header) - (string-append "#include <" header ">" (string #\newline))) - (cdr headers))))) - + (pffi-define scheme-name shared-object c-name return-type argument-types) + (display "HERE: ") + (write argument-types) + (newline) + (write (equal? '(list) argument-types)) + (newline) + (letrec* ((native-argument-types + (if (equal? '(list) argument-types) + (list) + (let ((types (map cdr (cdr argument-types)))) + (if (null? types) types (map car types))))) + (native-return-type (car (cdr return-type))) + (c-arguments (lambda (index argument-count result) + (if (> index argument-count) + result + (c-arguments (+ index 1) + argument-count + (string-append result + "___arg" + (number->string index) + (if (< index argument-count) + ", " + "")))))) + (c-code (string-append + (if (equal? 'void (cadr return-type)) "" "___return(") + (symbol->string (cadr c-name)) + "(" (c-arguments 1 (- (length argument-types) 1) "") ")" + (if (equal? 'void (cadr return-type)) "" ")") + ";"))) + (write `(define ,scheme-name + (c-lambda ,native-argument-types + ,native-return-type + ,c-code))) + (newline) + `(define ,scheme-name + (c-lambda ,native-argument-types + ,native-return-type + ,c-code)))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index af4a15f..00f772d 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -6,8 +6,8 @@ '(import (chicken foreign) (chicken memory)) #t)))) - (else - (define pffi-init(lambda () #t)))) + (gambit #t) + (else (define pffi-init (lambda () #t)))) (define pffi-type? (lambda (object) @@ -89,12 +89,12 @@ (cond-expand (gambit #t) ((or chicken cyclone) - (define-syntax pffi-load + (define-syntax pffi-define-library (syntax-rules () ((_ headers object-name . options) (pffi-shared-object-load headers))))) (else - (define pffi-load + (define pffi-define-library (lambda (headers object-name . options) (let* ((additional-paths (if (assoc 'additional-paths options) (cdr (assoc 'additional-paths options)) diff --git a/src/libtest.c b/src/libtest.c index 99f0213..75c3703 100644 --- a/src/libtest.c +++ b/src/libtest.c @@ -273,3 +273,11 @@ EXPORT struct test* test_new() { t->n = 14; return t; } + +EXPORT void takes_no_args() { + puts("I take no arguments :)"); +} + +EXPORT int takes_no_args_returns_int() { + return 0; +} diff --git a/tests/compliance.scm b/tests/compliance.scm index 0ccf3d5..6e3cdac 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -28,21 +28,38 @@ (set! assert-tag tag) (set! count 0))) -(define-syntax assert - (syntax-rules () - ((_ check value-a value-b) - (let ((result (apply check (list value-a value-b)))) - (set! count (+ count 1)) - (if (not result) (display "FAIL ") (display "PASS ")) - (display "[") - (display assert-tag) - (display " - ") - (display count) - (display "]") - (display ": ") - (write (list 'check 'value-a 'value-b)) - (newline) - (when (not result) (exit 1)))))) +(cond-expand + (gambit + (define assert + (lambda (check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (set! count (+ count 1)) + (if (not result) (display "FAIL ") (display "PASS ")) + (display "[") + (display assert-tag) + (display " - ") + (display count) + (display "]") + (display ": ") + (write (list 'check 'value-a 'value-b)) + (newline) + (when (not result) (exit 1)))))) + (else + (define-syntax assert + (syntax-rules () + ((_ check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (set! count (+ count 1)) + (if (not result) (display "FAIL ") (display "PASS ")) + (display "[") + (display assert-tag) + (display " - ") + (display count) + (display "]") + (display ": ") + (write (list 'check 'value-a 'value-b)) + (newline) + (when (not result) (exit 1)))))))) (define-syntax debug (syntax-rules () @@ -106,8 +123,6 @@ (debug (pffi-type? 'callback)) (assert equal? (pffi-type? 'callback) #t) -(pffi-init) - ;; pffi-size-of (print-header 'pffi-size-of) @@ -384,27 +399,27 @@ (assert equal? (number? align-pointer) #t) (assert = align-pointer 8))) -;; pffi-load +;; pffi-define-library -(print-header 'pffi-load) +(print-header 'pffi-define-library) -(define libc-stdlib - (cond-expand - (windows (pffi-load (list "stdlib.h") "ucrtbase")) - (else (pffi-load (list "stdlib.h") - "c" - '(additional-versions . ("0" "6")))))) +(pffi-define-library libc-stdlib + (list "stdlib.h") + (cond-expand (windows "ucrtbase") (else "c")) + '(additional-versions . ("0" "6"))) (debug libc-stdlib) -(define c-testlib - (cond-expand - (windows (pffi-load (list "libtest.h") - "test" - '(additional-paths . (".")))) - (else (pffi-load (list "libtest.h") +(pffi-define-library libc-stdio + (list "stdio.h") + (cond-expand (windows "ucrtbase") (else "c")) + '(additional-versions . ("0" "6"))) +(debug libc-stdio) + +(pffi-define-library c-testlib + (list "libtest.h") "test" - '(additional-paths . (".")))))) + '(additional-paths . ("."))) (debug c-testlib) @@ -477,12 +492,20 @@ (debug offset) (debug value) -(define-syntax test-type - (syntax-rules () - ((_ type) - (begin - (pffi-pointer-set! set-pointer type offset value) - (assert = (pffi-pointer-get set-pointer type offset) value))))) +(cond-expand + (gambit + (define test-type + (lambda (type) + (begin + (pffi-pointer-set! set-pointer type offset value) + (assert = (pffi-pointer-get set-pointer type offset) value))))) + (else + (define-syntax test-type + (syntax-rules () + ((_ type) + (begin + (pffi-pointer-set! set-pointer type offset value) + (assert = (pffi-pointer-get set-pointer type offset) value))))))) (test-type 'int8) (test-type 'uint8) @@ -656,14 +679,6 @@ (pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer)) (assert = (c-atoi (pffi-string->pointer "100")) 100) -(define libc-stdio - (cond-expand - ; FIXME Check that windows so file is correct - (windows (pffi-load (list "stdio.h") "ucrtbase")) - (else (pffi-load (list "stdio.h") - "c" - '(additional-versions . ("0" "6")))))) - (pffi-define c-fopen libc-stdio 'fopen 'pointer (list 'pointer 'pointer)) (define output-file (c-fopen (pffi-string->pointer "testfile.test") (pffi-string->pointer "w"))) @@ -682,6 +697,15 @@ (lambda () (read-line))) "Hello world") #t) +(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void (list)) +(debug c-takes-no-args) +(c-takes-no-args) + +(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int (list)) +(debug c-takes-no-args) +(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) +(assert equal? (= takes-no-args-returns-int-result 0) #t) + ;; pffi-struct-get (print-header 'pffi-struct-get) From 27cc998f356156f2490a8efe529acf942887ea7e Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 22 Mar 2025 16:14:06 +0200 Subject: [PATCH 15/19] Remove debug logging --- retropikzel/pffi/gambit.scm | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index f6b9f84..1c331d8 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -168,11 +168,6 @@ (define-macro (pffi-define scheme-name shared-object c-name return-type argument-types) - (display "HERE: ") - (write argument-types) - (newline) - (write (equal? '(list) argument-types)) - (newline) (letrec* ((native-argument-types (if (equal? '(list) argument-types) (list) @@ -196,11 +191,6 @@ "(" (c-arguments 1 (- (length argument-types) 1) "") ")" (if (equal? 'void (cadr return-type)) "" ")") ";"))) - (write `(define ,scheme-name - (c-lambda ,native-argument-types - ,native-return-type - ,c-code))) - (newline) `(define ,scheme-name (c-lambda ,native-argument-types ,native-return-type From 993588e2860fa86654fd206e7b1193fb81e8a063 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 22 Mar 2025 17:39:54 +0200 Subject: [PATCH 16/19] Move chicken to pffi-define-library --- Makefile | 2 +- retropikzel/pffi.sld | 32 ++-- retropikzel/pffi/racket.scm | 6 +- retropikzel/pffi/sagittarius.scm | 4 +- retropikzel/pffi/shared/main.scm | 277 ++++++++++++++++--------------- tests/compliance.scm | 6 +- 6 files changed, 170 insertions(+), 157 deletions(-) diff --git a/Makefile b/Makefile index 0ccd4d3..ed4516d 100644 --- a/Makefile +++ b/Makefile @@ -59,7 +59,7 @@ test-compile-library: tests/libtest.so libtest.a libtest.o SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld test-compiler-compliance-compile: test-compile-library - SCHEME=${SCHEME} CFLAGS="-I../include -L.." LDFLAGS="-ltest" compile-r7rs -I . tests/compliance.scm + SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest -L." compile-r7rs -I . tests/compliance.scm ./tests/compliance test-compiler-compliance: test-compiler-compliance-compile diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index bf677f1..c334a81 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -13,7 +13,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -49,7 +49,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -82,7 +82,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -111,7 +111,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -171,7 +171,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -200,7 +200,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -231,7 +231,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -259,7 +259,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -294,7 +294,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -323,7 +323,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -356,7 +356,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -386,7 +386,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -414,7 +414,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate @@ -443,7 +443,7 @@ pffi-size-of pffi-type? pffi-align-of - pffi-load + pffi-define-library pffi-pointer-null pffi-pointer-null? pffi-pointer-allocate @@ -472,7 +472,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-shared-object-load ;pffi-pointer-null ;pffi-pointer-null? @@ -501,7 +501,7 @@ ;pffi-size-of pffi-type? ;pffi-align-of - ;pffi-load + ;pffi-define-library ;pffi-pointer-null ;pffi-pointer-null? ;pffi-pointer-allocate diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index e4c837d..8f6b6ed 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -79,9 +79,11 @@ (string-copy (cast pointer _pointer _string)))) (define pffi-shared-object-load - (lambda (header path . options) + (lambda (header path options) + (write options) + (newline) (if (and (not (null? options)) - (assoc 'additional-versions (car options))) + (assoc 'additional-versions options)) (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions (car options))) (list #f)))) diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index cd35e9c..de726ac 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -32,7 +32,7 @@ (define-syntax pffi-define (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) + ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name (make-c-function shared-object (pffi-type->native-type return-type) @@ -102,7 +102,7 @@ (pointer->string pointer))) (define pffi-shared-object-load - (lambda (headers path . options) + (lambda (headers path options) (open-shared-library path))) (define pffi-pointer-free diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 00f772d..2729f35 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -91,138 +91,149 @@ ((or chicken cyclone) (define-syntax pffi-define-library (syntax-rules () - ((_ headers object-name . options) - (pffi-shared-object-load headers))))) + ((_ scheme-name headers object-name . options) + (begin + (define scheme-name #t) + (pffi-shared-object-load headers)))))) (else - (define pffi-define-library - (lambda (headers object-name . options) - (let* ((additional-paths (if (assoc 'additional-paths options) - (cdr (assoc 'additional-paths options)) - (list))) - (additional-versions (if (assoc 'additional-versions options) - (map (lambda (version) - (if (number? version) - (number->string version) - version)) - (cdr (assoc 'additional-versions options))) + (define-syntax pffi-define-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (define scheme-name #t)))) + #;(define-syntax pffi-define-library-old + (syntax-rules () + ((_ scheme-name headers object-name options) + (define scheme-name + (let* ((additional-paths (if (assoc 'additional-paths options) + (cdr (assoc 'additional-paths options)) (list))) - (slash (cond-expand (windows (string #\\)) (else "/"))) - (auto-load-paths - (cond-expand - (windows - (append - (if (get-environment-variable "SYSTEM") - (list (get-environment-variable "SYSTEM")) - (list)) - (if (get-environment-variable "WINDIR") - (list (get-environment-variable "WINDIR")) - (list)) - (if (get-environment-variable "WINEDLLDIR0") - (list (get-environment-variable "WINEDLLDIR0")) - (list)) - (if (get-environment-variable "SystemRoot") - (list (string-append - (get-environment-variable "SystemRoot") - slash - "system32")) - (list)) - (list ".") - (if (get-environment-variable "PATH") - (string-split (get-environment-variable "PATH") #\;) - (list)) - (if (get-environment-variable "PWD") - (list (get-environment-variable "PWD")) - (list)))) - (else - (append - ; Guix - (list (if (get-environment-variable "GUIX_ENVIRONMENT") - (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") - "") - "/run/current-system/profile/lib") - ; Debian - (if (get-environment-variable "LD_LIBRARY_PATH") - (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) - (list)) - (list - ;;; x86-64 - ; Debian - "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ;;; aarch64 - ; Debian - "/lib/aarch64-linux-gnu" - "/usr/lib/aarch64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ; NetBSD - "/usr/pkg/lib"))))) - (auto-load-versions (list "")) - (paths (append auto-load-paths additional-paths)) - (versions (append additional-versions auto-load-versions)) - (platform-lib-prefix - (cond-expand - ;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) - (windows "") - (else "lib"))) - (platform-file-extension - (cond-expand - ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) - (windows ".dll") - (else ".so"))) - (shared-object #f) - (searched-paths (list))) - (for-each - (lambda (path) - (for-each - (lambda (version) - (let ((library-path - (string-append path - slash - platform-lib-prefix - object-name - (cond-expand - (windows "") - (else platform-file-extension)) - (if (string=? version "") - "" - (string-append - (cond-expand (windows "-") - (else ".")) - version)) - (cond-expand - (windows platform-file-extension) - (else "")))) - (library-path-without-suffixes (string-append path - slash - platform-lib-prefix - object-name))) - (set! searched-paths (append searched-paths (list library-path))) - (when (and (not shared-object) - (file-exists? library-path)) - (set! shared-object - (cond-expand (racket library-path-without-suffixes) - (else library-path)))))) - versions)) - paths) - (if (not shared-object) - (begin - (display "Could not load shared object: ") - (write (list (cons 'object object-name) - (cons 'paths paths) - (cons 'platform-file-extension platform-file-extension) - (cons 'versions versions))) - (newline) - (display "Searched paths: ") - (write searched-paths) - (newline) - (exit 1)) - (pffi-shared-object-load headers - shared-object - `((additional-versions ,versions))))))))) + (additional-versions (if (assoc 'additional-versions options) + (map (lambda (version) + (if (number? version) + (number->string version) + version)) + (cdr (assoc 'additional-versions options))) + (list))) + (slash (cond-expand (windows (string #\\)) (else "/"))) + (auto-load-paths + (cond-expand + (windows + (append + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (if (get-environment-variable "WINEDLLDIR0") + (list (get-environment-variable "WINEDLLDIR0")) + (list)) + (if (get-environment-variable "SystemRoot") + (list (string-append + (get-environment-variable "SystemRoot") + slash + "system32")) + (list)) + (list ".") + (if (get-environment-variable "PATH") + (string-split (get-environment-variable "PATH") #\;) + (list)) + (if (get-environment-variable "PWD") + (list (get-environment-variable "PWD")) + (list)))) + (else + (append + ; Guix + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") + "") + "/run/current-system/profile/lib") + ; Debian + (if (get-environment-variable "LD_LIBRARY_PATH") + (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) + (list)) + (list + ;;; x86-64 + ; Debian + "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ;;; aarch64 + ; Debian + "/lib/aarch64-linux-gnu" + "/usr/lib/aarch64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ; NetBSD + "/usr/pkg/lib"))))) + (auto-load-versions (list "")) + (paths (append auto-load-paths additional-paths)) + (versions (append additional-versions auto-load-versions)) + (platform-lib-prefix + (cond-expand + ;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) + (windows "") + (else "lib"))) + (platform-file-extension + (cond-expand + ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) + (windows ".dll") + (else ".so"))) + (shared-object #f) + (searched-paths (list))) + (display "HERE: ") + (write additional-versions) + (newline) + (for-each + (lambda (path) + (for-each + (lambda (version) + (let ((library-path + (string-append path + slash + platform-lib-prefix + object-name + (cond-expand + (windows "") + (else platform-file-extension)) + (if (string=? version "") + "" + (string-append + (cond-expand (windows "-") + (else ".")) + version)) + (cond-expand + (windows platform-file-extension) + (else "")))) + (library-path-without-suffixes (string-append path + slash + platform-lib-prefix + object-name))) + (set! searched-paths (append searched-paths (list library-path))) + (when (and (not shared-object) + (file-exists? library-path)) + (set! shared-object + (cond-expand (racket library-path-without-suffixes) + (else library-path)))))) + versions)) + paths) + (if (not shared-object) + (begin + (display "Could not load shared object: ") + (write (list (cons 'object object-name) + (cons 'paths paths) + (cons 'platform-file-extension platform-file-extension) + (cons 'versions versions))) + (newline) + (display "Searched paths: ") + (write searched-paths) + (newline) + (exit 1)) + (pffi-shared-object-load headers + shared-object + `((additional-versions ,versions))))))))))) diff --git a/tests/compliance.scm b/tests/compliance.scm index 6e3cdac..a7575ec 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -406,20 +406,20 @@ (pffi-define-library libc-stdlib (list "stdlib.h") (cond-expand (windows "ucrtbase") (else "c")) - '(additional-versions . ("0" "6"))) + '((additional-versions . ("0" "6")))) (debug libc-stdlib) (pffi-define-library libc-stdio (list "stdio.h") (cond-expand (windows "ucrtbase") (else "c")) - '(additional-versions . ("0" "6"))) + '((additional-versions . ("0" "6")))) (debug libc-stdio) (pffi-define-library c-testlib (list "libtest.h") "test" - '(additional-paths . ("."))) + '((additional-paths . (".")))) (debug c-testlib) From 2ff726127ca20afc0b0fe6d590d7af3c52834a4e Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 22 Mar 2025 18:50:20 +0200 Subject: [PATCH 17/19] Sagittarius and Racket to pffi-define-library --- retropikzel/pffi/racket.scm | 4 ++-- retropikzel/pffi/shared/main.scm | 34 +++++++++++--------------------- tests/compliance.scm | 30 +++++++++++++++++++--------- 3 files changed, 34 insertions(+), 34 deletions(-) diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index 8f6b6ed..6abd4ff 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -80,12 +80,12 @@ (define pffi-shared-object-load (lambda (header path options) - (write options) + (write (cadr (assoc 'additional-versions options))) (newline) (if (and (not (null? options)) (assoc 'additional-versions options)) (ffi-lib path (mlist->list (append (cadr (assoc 'additional-versions - (car options))) + options)) (list #f)))) (ffi-lib path)))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 2729f35..192cb09 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -91,28 +91,27 @@ ((or chicken cyclone) (define-syntax pffi-define-library (syntax-rules () - ((_ scheme-name headers object-name . options) + ((_ scheme-name headers object-name options) (begin (define scheme-name #t) (pffi-shared-object-load headers)))))) (else (define-syntax pffi-define-library - (syntax-rules () - ((_ scheme-name headers object-name options) - (define scheme-name #t)))) - #;(define-syntax pffi-define-library-old (syntax-rules () ((_ scheme-name headers object-name options) (define scheme-name - (let* ((additional-paths (if (assoc 'additional-paths options) - (cdr (assoc 'additional-paths options)) + (let* ((internal-options (if (null? 'options) + (list) + (cadr 'options))) + (additional-paths (if (assoc 'additional-paths internal-options) + (cadr (assoc 'additional-paths internal-options)) (list))) - (additional-versions (if (assoc 'additional-versions options) + (additional-versions (if (assoc 'additional-versions internal-options) (map (lambda (version) (if (number? version) (number->string version) version)) - (cdr (assoc 'additional-versions options))) + (cadr (assoc 'additional-versions internal-options))) (list))) (slash (cond-expand (windows (string #\\)) (else "/"))) (auto-load-paths @@ -174,21 +173,10 @@ (auto-load-versions (list "")) (paths (append auto-load-paths additional-paths)) (versions (append additional-versions auto-load-versions)) - (platform-lib-prefix - (cond-expand - ;(racket (if (equal? (system-type 'os) 'windows) "" "lib")) - (windows "") - (else "lib"))) - (platform-file-extension - (cond-expand - ;(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) - (windows ".dll") - (else ".so"))) + (platform-lib-prefix (cond-expand (windows "") (else "lib"))) + (platform-file-extension (cond-expand (windows ".dll") (else ".so"))) (shared-object #f) (searched-paths (list))) - (display "HERE: ") - (write additional-versions) - (newline) (for-each (lambda (path) (for-each @@ -236,4 +224,4 @@ (exit 1)) (pffi-shared-object-load headers shared-object - `((additional-versions ,versions))))))))))) + `((additional-versions ,additional-versions))))))))))) diff --git a/tests/compliance.scm b/tests/compliance.scm index a7575ec..f68b623 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -403,23 +403,35 @@ (print-header 'pffi-define-library) -(pffi-define-library libc-stdlib - (list "stdlib.h") - (cond-expand (windows "ucrtbase") (else "c")) - '((additional-versions . ("0" "6")))) +(cond-expand + (windows (pffi-define-library libc-stdlib + (list "stdlib.h") + "ucrtbase" + '((additional-versions ("0" "6"))) + )) + (else (pffi-define-library libc-stdlib + (list "stdlib.h") + "c" + '((additional-versions ("0" "6")))))) (debug libc-stdlib) -(pffi-define-library libc-stdio - (list "stdio.h") - (cond-expand (windows "ucrtbase") (else "c")) - '((additional-versions . ("0" "6")))) +(cond-expand + (windows (pffi-define-library libc-stdio + (list "stdio.h") + "ucrtbase" + '((additional-versions ("0" "6"))))) + (else (pffi-define-library libc-stdio + (list "stdio.h") + "c" + '((additional-versions ("0" "6")))))) + (debug libc-stdio) (pffi-define-library c-testlib (list "libtest.h") "test" - '((additional-paths . (".")))) + '((additional-paths ("." "./tests")))) (debug c-testlib) From 75405a313551c88202a1f89a3e127ffe4c3dcdcf Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 22 Mar 2025 18:52:48 +0200 Subject: [PATCH 18/19] pffi-define-library works on Guile and Kawa now --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index ed4516d..6d0bd47 100644 --- a/Makefile +++ b/Makefile @@ -49,11 +49,11 @@ libtest.a: libtest.o src/libtest.c ar rcs libtest.a libtest.o test-interpreter-compliance: tests/libtest.so - SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm + SCHEME=${SCHEME} script-r7rs -I . -I .. tests/compliance.scm test-interpreter-compliance-docker: docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} - docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . tests/compliance.scm" + docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . -I .. tests/compliance.scm" test-compile-library: tests/libtest.so libtest.a libtest.o SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld From d5fd1eb95355cba3a8cb25c6179b3164fa90ad5b Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 22 Mar 2025 19:05:08 +0200 Subject: [PATCH 19/19] Added uniformity to pffi-define-library argument passing and made it work on Chicken too --- README.md | 30 +++++++++++++++++++++--------- retropikzel/pffi/chicken5.scm | 2 +- tests/compliance.scm | 13 ++++++------- 3 files changed, 28 insertions(+), 17 deletions(-) diff --git a/README.md b/README.md index a02a8d4..63927cf 100644 --- a/README.md +++ b/README.md @@ -266,9 +266,9 @@ Returns the size of the pffi-struct, pffi-enum or pffi-type. Returns the align of the type. -#### pffi-load +#### pffi-define-library -**pffi-load** headers shared-object-name [options] -> object +**pffi-define-library** headers shared-object-name [options] -> object Load given shared object automatically searching many predefined paths. @@ -288,13 +288,25 @@ keyword. The options are: Example: - (define libc-stdlib - (cond-expand - (windows (pffi-load (list "stdlib.h") "ucrtbase")) - (else (pffi-load (list "stdlib.h") - "c" - '(additional-versions . ("6")) - '(additional-search-paths . (".")))))) + (cond-expand + (windows (pffi-define-library libc-stdlib + (list "stdlib.h") + "ucrtbase" + '((additional-versions ("0" "6")) + (additiona-paths ("."))))) + (else (pffi-define-library libc-stdlib + (list "stdlib.h") + "c" + '((additional-versions ("0" "6")) + (additiona-paths (".")))))) + +#### Notes +- Do not cond-expand inside the arguments, that might lead to problems on some +implementations. +- Do pass the headers using quote + - As '(... and not (list... +- Do pass the options using quote + - As '(... and not (list... #### pffi-pointer-null diff --git a/retropikzel/pffi/chicken5.scm b/retropikzel/pffi/chicken5.scm index 6d18f1d..1e9afbf 100644 --- a/retropikzel/pffi/chicken5.scm +++ b/retropikzel/pffi/chicken5.scm @@ -183,7 +183,7 @@ (define-syntax pffi-shared-object-load (er-macro-transformer (lambda (expr rename compare) - (let* ((headers (cdr (car (cdr expr))))) + (let* ((headers (cadr (car (cdr expr))))) `(begin ,@ (map (lambda (header) diff --git a/tests/compliance.scm b/tests/compliance.scm index f68b623..d7de154 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -405,12 +405,11 @@ (cond-expand (windows (pffi-define-library libc-stdlib - (list "stdlib.h") + '("stdlib.h") "ucrtbase" - '((additional-versions ("0" "6"))) - )) + '((additional-versions ("0" "6"))))) (else (pffi-define-library libc-stdlib - (list "stdlib.h") + '("stdlib.h") "c" '((additional-versions ("0" "6")))))) @@ -418,18 +417,18 @@ (cond-expand (windows (pffi-define-library libc-stdio - (list "stdio.h") + '("stdio.h") "ucrtbase" '((additional-versions ("0" "6"))))) (else (pffi-define-library libc-stdio - (list "stdio.h") + '("stdio.h") "c" '((additional-versions ("0" "6")))))) (debug libc-stdio) (pffi-define-library c-testlib - (list "libtest.h") + '("libtest.h") "test" '((additional-paths ("." "./tests"))))