Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

This commit is contained in:
retropikzel 2024-09-15 15:08:55 +03:00
parent c89417113d
commit 7eecc0c0ec
8 changed files with 23 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

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

1
docs/reference.md
View File

@ -22,7 +22,6 @@ Types are given as symbols, for example 'int8 or 'pointer.
- unsigned-long
- float
- double
- string
- pointer
# Procedures or macros

10
retropikzel/r7rs-pffi/version/chicken.scm
View File

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

1
retropikzel/r7rs-pffi/version/guile.scm
View File

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

20
retropikzel/r7rs-pffi/version/kawa.scm
View File

@ -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)))))
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)))))
offset)))
(define pffi-pointer-deref
(lambda (pointer)

20
retropikzel/r7rs-pffi/version/racket.scm
View File

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

4
retropikzel/r7rs-pffi/version/sagittarius.scm
View File

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

20
test.scm
View File

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