From 59dd50619d7df3bd1134dbc67b0ec157de5e9cc3 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 14 Mar 2025 07:41:35 +0200 Subject: [PATCH 01/11] 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 85d524f40a7b68390e9a5e658e522ae2d3fcd702 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 14 Mar 2025 07:55:08 +0200 Subject: [PATCH 02/11] Added roadmap link --- README.md | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/README.md b/README.md index ea056a6..f96c49b 100644 --- a/README.md +++ b/README.md @@ -25,6 +25,7 @@ conforming to some specification. - [Non Goals](#non-goals) - [Status](#status) - [Current caveats](#current-caveats) +- [Roadmap](#roadmap) - [Implementation table](#implementation-table) - [Beta](#beta) - [Alpha](#alpha) @@ -99,12 +100,23 @@ changing anymore and some implementations are in **beta**. - No way to pass structs by value - Most implementations are missing callback support +## Roadmap + +For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?search=status%3Aopen%20label%3A%221.0.0%22) + ## Implementation table +### Released + + +Everything is implemented. + ### Beta +Most things are implemented. + | | 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 | |--------------|:---------:|:------------:|:----------------------------:|:-----------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| From 9938608df2b847ac89c18e3fe6cc20c13b2285f3 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 14 Mar 2025 09:20:10 +0200 Subject: [PATCH 03/11] Remove unnecessary beta and released explanations from README --- README.md | 4 ---- 1 file changed, 4 deletions(-) diff --git a/README.md b/README.md index f96c49b..bf8512a 100644 --- a/README.md +++ b/README.md @@ -110,14 +110,10 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear ### Released -Everything is implemented. ### Beta -Most things are implemented. - - | | 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 | | From 3dc98c239121fa03ef3cfa691dc49b6fdc728b03 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 06:44:41 +0200 Subject: [PATCH 04/11] Made shared pointer->string and string->pointer implementation --- retropikzel/pffi.sld | 2 ++ retropikzel/pffi/chibi.scm | 4 ++-- retropikzel/pffi/chicken5.scm | 10 +++++----- retropikzel/pffi/cyclone.scm | 4 ++-- retropikzel/pffi/gerbil.scm | 4 ++-- retropikzel/pffi/guile.scm | 4 ++-- retropikzel/pffi/kawa.scm | 4 ++-- retropikzel/pffi/mosh.scm | 9 +++++++-- retropikzel/pffi/racket.scm | 4 ++-- retropikzel/pffi/sagittarius.scm | 6 +++--- retropikzel/pffi/shared/main.scm | 25 +++++++++++++++++++++++++ retropikzel/pffi/stklos.scm | 14 +++++++------- src/chibi/pffi.stub | 8 ++++---- 13 files changed, 65 insertions(+), 33 deletions(-) diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index d64a8f6..2f8edf4 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! @@ -460,6 +461,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/chibi.scm b/retropikzel/pffi/chibi.scm index 2c88779..9a015ed 100644 --- a/retropikzel/pffi/chibi.scm +++ b/retropikzel/pffi/chibi.scm @@ -102,11 +102,11 @@ ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (string-to-pointer string-content))) -(define pffi-pointer->string +#;(define pffi-pointer->string (lambda (pointer) (pointer-to-string pointer))) diff --git a/retropikzel/pffi/chicken5.scm b/retropikzel/pffi/chicken5.scm index fc4b7d2..6d18f1d 100644 --- a/retropikzel/pffi/chicken5.scm +++ b/retropikzel/pffi/chicken5.scm @@ -153,11 +153,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)))) @@ -175,7 +175,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);")) diff --git a/retropikzel/pffi/cyclone.scm b/retropikzel/pffi/cyclone.scm index f2063f8..83824ee 100644 --- a/retropikzel/pffi/cyclone.scm +++ b/retropikzel/pffi/cyclone.scm @@ -102,12 +102,12 @@ (lambda () (make-opaque))) -(define-c pffi-string->pointer +#;(define-c pffi-string->pointer "(void *data, int argc, closure _, object k, object s)" "make_c_opaque(opq, string_str(s)); return_closcall1(data, k, &opq);") -(define-c pffi-pointer->string +#;(define-c pffi-pointer->string "(void *data, int argc, closure _, object k, object p)" "make_string(s, opaque_ptr(p)); return_closcall1(data, k, &s);") diff --git a/retropikzel/pffi/gerbil.scm b/retropikzel/pffi/gerbil.scm index 4c32e13..4b046f7 100644 --- a/retropikzel/pffi/gerbil.scm +++ b/retropikzel/pffi/gerbil.scm @@ -23,11 +23,11 @@ (lambda () (error "Not defined"))) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (error "Not defined"))) -(define pffi-pointer->string +#;(define pffi-pointer->string (lambda (pointer) pointer)) diff --git a/retropikzel/pffi/guile.scm b/retropikzel/pffi/guile.scm index a4df807..68eb76c 100644 --- a/retropikzel/pffi/guile.scm +++ b/retropikzel/pffi/guile.scm @@ -65,11 +65,11 @@ (lambda () (make-pointer 0))) -(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))) diff --git a/retropikzel/pffi/kawa.scm b/retropikzel/pffi/kawa.scm index af4cb72..ba4561b 100644 --- a/retropikzel/pffi/kawa.scm +++ b/retropikzel/pffi/kawa.scm @@ -143,13 +143,13 @@ (lambda () (static-field java.lang.foreign.MemorySegment 'NULL))) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (let ((size (+ (invoke string-content 'length) 1))) (invoke (invoke arena 'allocateFrom (invoke string-content 'toString)) 'reinterpret size)))) -(define pffi-pointer->string +#;(define pffi-pointer->string (lambda (pointer) (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0))) diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm index 637d1c9..24abf27 100644 --- a/retropikzel/pffi/mosh.scm +++ b/retropikzel/pffi/mosh.scm @@ -92,7 +92,7 @@ ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1))) (index 0)) @@ -104,10 +104,15 @@ (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null) pointer))) -(define pffi-pointer->string +#;(define pffi-pointer->string (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) diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index a3c538f..e4c837d 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -65,14 +65,14 @@ (lambda () #f )) ; #f is the null pointer on racket -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (let* ((size (string-length string-content)) (pointer (pffi-pointer-allocate (+ size 1)))) (memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1)) pointer))) -(define pffi-pointer->string +#;(define pffi-pointer->string (lambda (pointer) (when (pffi-pointer-null? pointer) (error "Can not make string from null pointer" pointer)) diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index 0bcb8ac..cd35e9c 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -85,7 +85,7 @@ (lambda () (empty-pointer))) -(define (string->c-string s) +#;(define (string->c-string s) (let* ((bv (string->utf8 s)) (p (allocate-pointer (+ (bytevector-length bv) 1)))) (do ((i 0 (+ i 1))) @@ -93,11 +93,11 @@ (pointer-set-c-uint8! p i (bytevector-u8-ref bv i))) p)) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) (string->c-string string-content))) -(define pffi-pointer->string +#;(define pffi-pointer->string (lambda (pointer) (pointer->string pointer))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 3f9263f..2ecb7dd 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -22,6 +22,31 @@ ((pffi-type? object) (size-of-type object)) (else (error "Not pffi-struct, pffi-enum of pffi-type" object))))) +(define pffi-string->pointer + (lambda (str) + (letrec* ((str-length (string-length str)) + (pointer (pffi-pointer-allocate (+ str-length 1))) + (looper (lambda (index) + (when (< index str-length) + (pffi-pointer-set! pointer + 'char + index + (string-ref str index)) + (looper (+ index 1)))))) + (looper 0) + (pffi-pointer-set! pointer 'char str-length #\null) + pointer))) + +(define pffi-pointer->string + (lambda (pointer) + (letrec* ((looper (lambda (index str) + (let ((c (pffi-pointer-get pointer 'char index))) + (if (char=? c #\null) + str + (looper (+ index 1) (cons c str))))))) + (list->string (reverse (looper 0 (list))))))) + + (define pffi-types '(int8 uint8 diff --git a/retropikzel/pffi/stklos.scm b/retropikzel/pffi/stklos.scm index a77af1c..54e23db 100644 --- a/retropikzel/pffi/stklos.scm +++ b/retropikzel/pffi/stklos.scm @@ -72,17 +72,22 @@ (lambda (size) (allocate-bytes size))) +;; FIXME +(define pffi-pointer-address + (lambda (pointer) + 0)) + (define pffi-pointer-null (lambda () (let ((p (allocate-bytes 0))) (free-bytes p) p))) -(define pffi-string->pointer +#;(define pffi-string->pointer (lambda (string-content) string-content)) -(define pffi-pointer->string +#;(define pffi-pointer->string (lambda (pointer) (if (string? pointer) pointer @@ -108,8 +113,3 @@ (define pffi-pointer-get (lambda (pointer type offset) (error "Not implemented"))) - -(define pffi-pointer-address - (lambda (pointer) - (error "Not implemented"))) - diff --git a/src/chibi/pffi.stub b/src/chibi/pffi.stub index f784611..69eb1ce 100644 --- a/src/chibi/pffi.stub +++ b/src/chibi/pffi.stub @@ -179,12 +179,12 @@ (define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int)) ;; pffi-string->pointer -(c-declare "void* string_to_pointer(char* string) { return (void*)string; }") -(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string)) +;(c-declare "void* string_to_pointer(char* string) { return (void*)string; }") +;(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string)) ;; pffi-pointer->string -(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }") -(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*))) +;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }") +;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*))) ;; pffi-define From f529fcab52812f05e4b176ce4e8b13ee7424c393 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 15 Mar 2025 06:47:10 +0200 Subject: [PATCH 05/11] 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 06/11] 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 07/11] 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 08/11] 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 09/11] 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 10/11] 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 11/11] 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")