From 7eecc0c0ecb7d86b31c3e38df8ee807efca63286 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 15 Sep 2024 15:08:55 +0300 Subject: [PATCH] Remove string type, tier 1 now passes all other than callback tests --- Makefile | 2 +- docs/reference.md | 1 - retropikzel/r7rs-pffi/version/chicken.scm | 10 +---- retropikzel/r7rs-pffi/version/guile.scm | 1 - retropikzel/r7rs-pffi/version/kawa.scm | 42 ++++++------------- retropikzel/r7rs-pffi/version/racket.scm | 20 +-------- retropikzel/r7rs-pffi/version/sagittarius.scm | 4 -- test.scm | 20 +++------ 8 files changed, 23 insertions(+), 77 deletions(-) diff --git a/Makefile b/Makefile index 223afaf..3084a97 100644 --- a/Makefile +++ b/Makefile @@ -61,7 +61,7 @@ test-guile: build KAWA=java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar kawa.jar --r7rs --full-tailcalls -Dkawa.import.path=.:./schubert test-kawa: build - echo "${SCHEME_RUNNER} kawa \"${KAWA} test.scm\"" + ${SCHEME_RUNNER} kawa "${KAWA} test.scm" SASH=sash -L . -L ./schubert test-sagittarius: build diff --git a/docs/reference.md b/docs/reference.md index d41bc94..8954114 100644 --- a/docs/reference.md +++ b/docs/reference.md @@ -22,7 +22,6 @@ Types are given as symbols, for example 'int8 or 'pointer. - unsigned-long - float - double -- string - pointer # Procedures or macros diff --git a/retropikzel/r7rs-pffi/version/chicken.scm b/retropikzel/r7rs-pffi/version/chicken.scm index 8aca339..adbbc1f 100644 --- a/retropikzel/r7rs-pffi/version/chicken.scm +++ b/retropikzel/r7rs-pffi/version/chicken.scm @@ -46,7 +46,6 @@ ((equal? type 'float) 'float) ((equal? type 'double) 'double) ((equal? type 'pointer) 'c-pointer) - ((equal? type 'string) 'c-string) ((equal? type 'void) 'void) ((equal? type 'callback) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type)))) ) @@ -80,7 +79,6 @@ ((equal? type 'float) 'float) ((equal? type 'double) 'double) ((equal? type 'pointer) 'c-pointer) - ((equal? type 'string) 'c-string) ((equal? type 'void) 'void) ((equal? type 'callback) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) @@ -122,7 +120,6 @@ ((equal? type 'float) 'float) ((equal? type 'double) 'double) ((equal? type 'pointer) 'c-pointer) - ((equal? type 'string) 'c-string) ((equal? type 'void) 'void) ((equal? type 'callback) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) @@ -165,7 +162,6 @@ ((equal? type 'float) (foreign-value "sizeof(float)" int)) ((equal? type 'double) (foreign-value "sizeof(double)" int)) ((equal? type 'pointer) (foreign-value "sizeof(void*)" int)) - ((equal? type 'string) (foreign-value "sizeof(void*)" int)) (else (error "pffi-size-of -- No such pffi type" type))))) (define pffi-pointer-allocate @@ -266,8 +262,7 @@ ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value)) ((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value)) ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value)) - ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))) - ((equal? type 'string) (pffi-pointer-set! pointer 'pointer offset (pffi-string->pointer value)))))) + ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value)))))) (define pffi-pointer-get (lambda (pointer type offset) @@ -289,8 +284,7 @@ ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset))) ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset))) ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) - ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))) - ((equal? type 'string) (pffi-pointer->string (pffi-pointer-get pointer 'pointer offset)))))) + ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset))))))) (define pffi-pointer-deref (lambda (pointer) diff --git a/retropikzel/r7rs-pffi/version/guile.scm b/retropikzel/r7rs-pffi/version/guile.scm index 02f3916..51f6e45 100644 --- a/retropikzel/r7rs-pffi/version/guile.scm +++ b/retropikzel/r7rs-pffi/version/guile.scm @@ -44,7 +44,6 @@ ((equal? type 'float) float) ((equal? type 'double) double) ((equal? type 'pointer) '*) - ((equal? type 'string) '*) ((equal? type 'void) void) ((equal? type 'callback) '*) (else (error "pffi-type->native-type -- No such pffi type" type))))) diff --git a/retropikzel/r7rs-pffi/version/kawa.scm b/retropikzel/r7rs-pffi/version/kawa.scm index 9936d59..c29c6c8 100644 --- a/retropikzel/r7rs-pffi/version/kawa.scm +++ b/retropikzel/r7rs-pffi/version/kawa.scm @@ -42,7 +42,6 @@ ((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4)) ((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8)) ((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) - ((equal? type 'string) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) ((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)) (else (error "pffi-type->native-type -- No such pffi type" type))))) @@ -68,7 +67,6 @@ ((equal? type 'float) (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT)) ((equal? type 'double) (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE)) ((equal? type 'pointer) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) - ((equal? type 'string) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) ((equal? type 'void) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) (else (error "pffi-type->function-argument-type -- No such pffi type" type))))) @@ -145,36 +143,22 @@ (define pffi-pointer-set! (lambda (pointer type offset value) - (cond ((equal? type 'string) - (invoke (invoke pointer - 'reinterpret - (static-field java.lang.Integer 'MAX_VALUE)) - 'setString - offset - value)) - (else - (invoke (invoke pointer - 'reinterpret - (static-field java.lang.Integer 'MAX_VALUE)) - 'set - (invoke (pffi-type->native-type type) 'withByteAlignment 1) - offset - value))))) + (invoke (invoke pointer + 'reinterpret + (static-field java.lang.Integer 'MAX_VALUE)) + 'set + (invoke (pffi-type->native-type type) 'withByteAlignment 1) + offset + value))) (define pffi-pointer-get (lambda (pointer type offset) - (cond ((equal? type 'string) - (invoke (invoke pointer - 'reinterpret - (static-field java.lang.Integer 'MAX_VALUE)) - 'getString - offset)) - (else (invoke (invoke pointer - 'reinterpret - (static-field java.lang.Integer 'MAX_VALUE)) - 'get - (invoke (pffi-type->native-type type) 'withByteAlignment 1) - offset))))) + (invoke (invoke pointer + 'reinterpret + (static-field java.lang.Integer 'MAX_VALUE)) + 'get + (invoke (pffi-type->native-type type) 'withByteAlignment 1) + offset))) (define pffi-pointer-deref (lambda (pointer) diff --git a/retropikzel/r7rs-pffi/version/racket.scm b/retropikzel/r7rs-pffi/version/racket.scm index ad6744b..2d4da0e 100644 --- a/retropikzel/r7rs-pffi/version/racket.scm +++ b/retropikzel/r7rs-pffi/version/racket.scm @@ -45,7 +45,6 @@ ((equal? type 'float) _float) ((equal? type 'double) _double) ((equal? type 'pointer) _pointer) - ((equal? type 'string) _string) ((equal? type 'void) _void) ((equal? type 'callback) _pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) @@ -85,29 +84,14 @@ (define pffi-string->pointer (lambda (string-content) - (write string-content) - (newline) (let* ((size (string-length string-content)) (pointer (pffi-pointer-allocate (+ size 1)))) - (memmove pointer (cast string-content _string _pointer) size) - (display "STRING SIZE: ") - (display size) - (display " : ") - (write (cast pointer _pointer _string)) - (newline) + (memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1)) pointer))) (define pffi-pointer->string (lambda (pointer) - (let* ((size (string-length (cast pointer _pointer _string))) - (string-content (string-copy (cast pointer _pointer _string)))) - (memmove (cast string-content _string _pointer) pointer size) - (display "SIZE: ") - (display size) - (display " : ") - (write string-content) - (newline) - string-content))) + (string-copy (cast pointer _pointer _string)))) (define pffi-shared-object-load (lambda (header path) diff --git a/retropikzel/r7rs-pffi/version/sagittarius.scm b/retropikzel/r7rs-pffi/version/sagittarius.scm index c389ba4..0161cc9 100644 --- a/retropikzel/r7rs-pffi/version/sagittarius.scm +++ b/retropikzel/r7rs-pffi/version/sagittarius.scm @@ -43,7 +43,6 @@ ((equal? type 'float) 'float) ((equal? type 'double) 'double) ((equal? type 'pointer) 'void*) - ((equal? type 'string) 'char*) ((equal? type 'void) 'void) ((equal? type 'callback) 'callback) (else (error "pffi-type->native-type -- No such pffi type" type))))) @@ -89,7 +88,6 @@ ((eq? type 'unsigned-long) size-of-unsigned-long) ((eq? type 'float) size-of-float) ((eq? type 'double) size-of-double) - ((eq? type 'string) size-of-void*) ((eq? type 'pointer) size-of-void*) (else (error "Can not get size of unknown type" type))))) @@ -144,7 +142,6 @@ ((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 'string) (pointer-set-c-pointer! pointer offset value)) ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) (define pffi-pointer-get @@ -167,7 +164,6 @@ ((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 'string) (pffi-pointer->string (pointer-ref-c-pointer pointer offset))) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) (define pffi-pointer-deref diff --git a/test.scm b/test.scm index 106a889..262edae 100644 --- a/test.scm +++ b/test.scm @@ -197,13 +197,6 @@ (assert equal? (number? size-double) #t) (assert = size-double 8) -(assert equal? (number? (pffi-size-of 'double)) #t) -(define size-string (pffi-size-of 'string)) -(debug size-string) -(assert equal? (number? size-string) #t) -(assert = size-string 8) - -(assert equal? (number? (pffi-size-of 'string)) #t) (define size-pointer (pffi-size-of 'pointer)) (debug size-pointer) (assert equal? (number? size-pointer) #t) @@ -315,8 +308,8 @@ (define string-to-be-set "FOOBAR") (debug string-to-be-set) -(pffi-pointer-set! set-pointer 'string offset string-to-be-set) -(assert string=? (pffi-pointer-get set-pointer 'string offset) "FOOBAR") +(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set)) +(assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") ;; pffi-pointer-deref @@ -343,8 +336,6 @@ (pffi-define atoi-pointer libc-stdlib 'atoi 'int (list 'pointer)) (assert = (atoi-pointer (pffi-string->pointer "100")) 100) -(pffi-define atoi-string libc-stdlib 'atoi 'int (list 'string)) -(assert = (atoi-string (pffi-string->pointer "100")) 100) (exit) ;; pffi-define-callback @@ -357,11 +348,9 @@ (list ".4"))) (pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list)) (pffi-define curl-easy-setopt libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'pointer)) -(pffi-define curl-easy-setopt-url libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'string)) (pffi-define curl-easy-setopt-callback libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'callback)) (pffi-define curl-easy-getinfo libcurl 'curl_easy_getinfo 'int (list 'pointer 'int 'pointer)) (pffi-define curl-easy-perform libcurl 'curl_easy_perform 'int (list 'pointer)) -(pffi-define curl-easy-strerror libcurl 'curl_easy_strerror 'string (list 'int)) (define CURLOPT-WRITEFUNCTION 20011) (define CURLOPT-FOLLOWLOCATION 52) (define CURLOPT-URL 10002) @@ -376,12 +365,13 @@ (define handle (curl-easy-init)) (define url "https://scheme.org") +(define url-pointer (pffi-string->pointer url)) (debug url) -(define curl-code1 (curl-easy-setopt-url handle CURLOPT-FOLLOWLOCATION url)) +(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url-pointer)) (debug curl-code1) (assert = curl-code1 0) -(define curl-code2 (curl-easy-setopt-url handle CURLOPT-URL url)) +(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url-pointer)) (debug curl-code2) (assert = curl-code2 0)