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

Added more tests

This commit is contained in:
retropikzel 2024-09-13 08:23:16 +03:00
parent f41a7e098f
commit a94bfc0768
3 changed files with 212 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -56,7 +56,8 @@ test-gambit: clean build
GUILE=guile -L . -L ./schubert
test-guile: build
${SCHEME_RUNNER} guile "${GUILE} test.scm"
#${SCHEME_RUNNER} guile "${GUILE} test.scm"
${GUILE} test.scm
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

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

@ -64,7 +64,7 @@
(define-syntax pffi-define-callback
(syntax-rules ()
((pffi-define-callback scheme-name return-type argument-types procedure)
((_ scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback (pffi-type->native-type return-type)
(map pffi-type->native-type argument-types)

211
test.scm
View File

@ -4,6 +4,15 @@
(scheme process-context)
(retropikzel r7rs-pffi version main))
(define print-header
(lambda (title)
(display "=========================================")
(newline)
(display title)
(newline)
(display "=========================================")
(newline)))
(define-syntax assert
(syntax-rules ()
((_ check value-a value-b)
@ -13,24 +22,88 @@
(newline)
(when (not result) (exit 1))))))
(define-syntax debug
(syntax-rules ()
((_ value)
(begin
(display 'value)
(display ": ")
(write value)
(newline)))))
;; pffi-init
(print-header 'pffi-init)
(pffi-init)
;; pffi-shared-object-auto-load
(print-header 'pffi-shared-object-auto-load)
(define libc-stdlib
(if (string=? pffi-os-name "windows")
(pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))
(pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6"))))
;; pffi-define
(print-header 'pffi-define)
(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
(assert = (atoi (pffi-string->pointer "100")) 100)
;; Size of
;; pffi-define-callback
(print-header 'pffi-define-callback)
(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers
(list ".") ; Additional search paths
"curl" ; The named of shared object without the lib prefix
(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-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))
(define CURLOPT-WRITEFUNCTION 20011)
(define CURLOPT-FOLLOWLOCATION 52)
(define CURLOPT-URL 10002)
(define CURLINFO-RESPONSE-CODE 2097154)
(define result "")
(pffi-define-callback collect-result
'void
(list 'pointer 'int 'int 'pointer)
(lambda (pointer size nmemb client-pointer)
(set! result (string-append result (pffi-pointer->string pointer)))))
(define handle (curl-easy-init))
(define url (pffi-string->pointer "https://scheme.org"))
(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url))
(debug curl-code1)
(assert = curl-code1 0)
(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url))
(debug curl-code2)
(assert = curl-code2 0)
(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
(debug curl-code3)
(assert = curl-code3 0)
(debug (curl-easy-perform handle))
(define http-code (pffi-pointer-allocate (pffi-size-of 'int)))
(curl-easy-getinfo handle CURLINFO-RESPONSE-CODE http-code)
(assert = (pffi-pointer-get http-code 'int 0) 200)
;; pffi-size-of
(print-header 'pffi-size-of)
(define size-int8 (pffi-size-of 'int8))
(debug size-int8)
(assert equal? (number? size-int8) #t)
(assert = size-int8 1)
(assert equal? (number? (pffi-size-of 'int8)) #t)
(assert equal? (number? (pffi-size-of 'uint8)) #t)
(assert equal? (number? (pffi-size-of 'int16)) #t)
(assert equal? (number? (pffi-size-of 'uint16)) #t)
@ -51,4 +124,138 @@
(assert equal? (number? (pffi-size-of 'string)) #t)
(assert equal? (number? (pffi-size-of 'pointer)) #t)
;; pffi-pointer-allocate
(print-header 'pffi-pointer-allocate)
(define test-pointer (pffi-pointer-allocate 100))
(debug test-pointer)
(assert equal? (pffi-pointer? test-pointer) #t)
;; pffi-pointer-null
(print-header 'pffi-pointer-null)
(define null-pointer (pffi-pointer-null))
(debug null-pointer)
(assert equal? (pffi-pointer-null? null-pointer) #t)
;; pffi-string->pointer
(print-header 'pffi-string->pointer)
(define string-pointer (pffi-string->pointer "Hello world"))
(debug string-pointer)
(assert equal? (pffi-pointer? string-pointer) #t)
;; pffi-pointer->string
(print-header 'pffi-pointer->string)
(define pointer-string (pffi-pointer->string string-pointer))
(debug pointer-string)
(assert string=? pointer-string "Hello world")
;; pffi-pointer-free
(print-header 'pffi-pointer-free)
(define pointer-to-be-freed (pffi-pointer-allocate 100))
(debug pointer-to-be-freed)
(pffi-pointer-free pointer-to-be-freed)
(debug pointer-to-be-freed)
;; pffi-pointer?
(print-header 'pffi-pointer?)
(define is-pointer (pffi-pointer-allocate 100))
(debug is-pointer)
(assert equal? (pffi-pointer? is-pointer) #t)
(assert equal? (pffi-pointer? 100) #f)
(assert equal? (pffi-pointer? 'bar) #f)
;; pffi-pointer-null?
(print-header 'pffi-pointer-null?)
(define is-null-pointer (pffi-pointer-null))
(debug is-null-pointer)
(define is-not-null-pointer (pffi-pointer-allocate 100))
(debug is-not-null-pointer)
(assert equal? (pffi-pointer-null? is-null-pointer) #t)
(assert equal? (pffi-pointer-null? is-not-null-pointer) #f)
(assert equal? (pffi-pointer-null? 100) #f)
(assert equal? (pffi-pointer-null? 'bar) #f)
;; pffi-pointer-set! and pffi-pointer-get
(print-header "pffi-pointer-set! and pffi-pointer-get")
(define set-pointer (pffi-pointer-allocate 100))
(define offset 50)
(define value 10)
(debug set-pointer)
(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)))))
(test-type 'int8)
(test-type 'uint8)
(test-type 'int16)
(test-type 'uint16)
(test-type 'int32)
(test-type 'uint32)
(test-type 'int64)
(test-type 'uint64)
(test-type 'short)
(test-type 'unsigned-short)
(test-type 'int)
(test-type 'unsigned-int)
(test-type 'long)
(test-type 'unsigned-long)
(test-type 'float)
(test-type 'double)
(define pointer-to-be-set (pffi-string->pointer "FOOBAR"))
(debug pointer-to-be-set)
(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set)
(assert equal?
(pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset))
#t)
(assert string=?
(pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))
"FOOBAR")
(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-deref
(print-header 'pffi-pointer-deref)
(define pointer-to-deref (pffi-pointer-allocate (pffi-size-of 'int)))
(debug pointer-to-deref)
(pffi-pointer-set! pointer-to-deref 'int 0 42)
(assert equal? (pffi-pointer? (pffi-pointer-deref pointer-to-deref)) #t)
;; pffi-os-name
(print-header 'pffi-os-name)
(assert equal?
(or (string=? pffi-os-name "windows")
(string=? pffi-os-name "unix"))
#t)
(exit 0)