Remove string type, tier 1 now passes all other than callback tests

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

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

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 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value))))))
-          ((equal? type 'string) (pffi-pointer-set! pointer 'pointer offset (pffi-string->pointer 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 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
-          ((equal? type 'string) (pffi-pointer->string (pffi-pointer-get pointer 'pointer offset))))))
 
     (define pffi-pointer-deref
       (lambda (pointer)

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)))))

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
-           (invoke (invoke pointer
+                    'reinterpret
-                           'reinterpret
+                    (static-field java.lang.Integer 'MAX_VALUE))
-                           (static-field java.lang.Integer 'MAX_VALUE))
+            'set
-                   'setString
+            (invoke (pffi-type->native-type type) 'withByteAlignment 1)
-                   offset
+            offset
-                   value))
+            value)))
-          (else
-            (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
-           (invoke (invoke pointer
+                    'reinterpret
-                           'reinterpret
+                    (static-field java.lang.Integer 'MAX_VALUE))
-                           (static-field java.lang.Integer 'MAX_VALUE))
+            'get
-                   'getString
+            (invoke (pffi-type->native-type type) 'withByteAlignment 1)
-                   offset))
+            offset)))
-          (else (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)

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)
+         (memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1))
-         (display "STRING SIZE: ")
-         (display size)
-         (display " : ")
-         (write (cast pointer _pointer _string))
-         (newline)
          pointer)))
 
    (define pffi-pointer->string
      (lambda (pointer)
-     (let* ((size (string-length (cast pointer _pointer _string)))
+       (string-copy (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)))
 
    (define pffi-shared-object-load
      (lambda (header path)

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

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)
+(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set))
-(assert string=? (pffi-pointer-get set-pointer 'string offset) "FOOBAR")
+(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)