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

Backup

This commit is contained in:
retropikzel 2024-09-15 15:45:28 +03:00
parent 7eecc0c0ec
commit 54712c1b4c
4 changed files with 80 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Makefile
View File

@ -18,7 +18,7 @@ test-tier1: \
test-sagittarius \ test-sagittarius \
test-racket test-racket
test-tier2: test-tier2: \
test-cyclone \ test-cyclone \
test-gambit \ test-gambit \
test-stklos test-stklos
@ -43,16 +43,17 @@ build-cyclone-libs:
CYCLONE=cyclone -A . -A ./schubert CYCLONE=cyclone -A . -A ./schubert
test-cyclone: clean build build-cyclone-libs test-cyclone: clean build build-cyclone-libs
${SCHEME_RUNNER} cyclone "icyc -s test.scm" ${SCHEME_RUNNER} cyclone "${CYCLONE} test.scm && icyc -s test.scm"
GAMBIT_LIB=gsc -:r7rs,search=.:./schubert -dynamic GAMBIT_LIB=gsc -:r7rs -dynamic
build-gambit-libs: build-gambit-libs:
${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/pffi/version/gambit.scm" ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi/version/gambit.scm"
${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/pffi/version/main.scm" ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi/version/main.scm"
GAMBIT=gsc -:r7rs,search=.:./schubert -ld-options -lcurl -exe GAMBIT=gsc -:r7rs,search=.:./schubert -ld-options -lcurl -exe
test-gambit: clean build test-gambit: clean build
${SCHEME_RUNNER} gambit "${GAMBIT} test.scm && ./test" #${SCHEME_RUNNER} gambit "${GAMBIT} test.scm && ./test"
${GAMBIT} test.scm && ./test
GUILE=guile -L . -L ./schubert GUILE=guile -L . -L ./schubert
test-guile: build test-guile: build

31
retropikzel/r7rs-pffi/version/cyclone.scm
View File

@ -45,7 +45,6 @@
((equal? type 'float) float) ((equal? type 'float) float)
((equal? type 'double) double) ((equal? type 'double) double)
((equal? type 'pointer) opaque) ((equal? type 'pointer) opaque)
((equal? type 'string) string)
((equal? type 'void) c-void) ((equal? type 'void) c-void)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
@ -78,7 +77,6 @@
((equal? type 'float) 'float) ((equal? type 'float) 'float)
((equal? type 'double) 'double) ((equal? type 'double) 'double)
((equal? type 'pointer) 'c-pointer) ((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
(else (error "pffi-type->native-type -- No such pffi type" type))))) (else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr))) (scheme-name (car (cdr expr)))
@ -94,10 +92,28 @@
`(c-define ,scheme-name `(c-define ,scheme-name
,return-type ,c-name ,@ argument-types)))))) ,return-type ,c-name ,@ argument-types))))))
(define pffi-size-of
(define pffi-size-of (lambda (type)
(lambda (type) (cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
(error "Not defined"))) ((equal? type 'uint8) (c-value "sizeof(uint8_t)" int))
((equal? type 'int16) (c-value "sizeof(int16_t)" int))
((equal? type 'uint16) (c-value "sizeof(uint16_t)" int))
((equal? type 'int32) (c-value "sizeof(int32_t)" int))
((equal? type 'uint32) (c-value "sizeof(uint32_t)" int))
((equal? type 'int64) (c-value "sizeof(int64_t)" int))
((equal? type 'uint64) (c-value "sizeof(uint64_t)" int))
((equal? type 'char) (c-value "sizeof(char)" int))
((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int))
((equal? type 'short) (c-value "sizeof(short)" int))
((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int))
((equal? type 'int) (c-value "sizeof(int)" int))
((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int))
((equal? type 'long) (c-value "sizeof(long)" int))
((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int))
((equal? type 'float) (c-value "sizeof(float)" int))
((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int))
(else (error "pffi-size-of -- No such pffi type" type)))))
(define pffi-pointer-allocate (define pffi-pointer-allocate
(lambda (size) (lambda (size)
@ -109,7 +125,8 @@
(define pffi-string->pointer (define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(error "Not defined"))) (error "Not defined")
))
(define pffi-pointer->string (define pffi-pointer->string
(lambda (pointer) (lambda (pointer)

2
scheme_runner
View File

@ -25,5 +25,5 @@ else
-f ${DOCKERFILE} \ -f ${DOCKERFILE} \
--tag ${tag}:latest \ --tag ${tag}:latest \
. .
docker run -v ${PWD}:/workdir:z ${tag}:latest ${cmd} docker run -it -v ${PWD}:/workdir:z ${tag}:latest ${cmd}
fi fi

95
test.scm
View File

@ -47,46 +47,6 @@
(write value) (write value)
(newline))))) (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-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)
(assert equal? (pffi-pointer-null? string-pointer) #f)
;; pffi-pointer->string
(print-header 'pffi-pointer->string)
(define pointer-string (pffi-pointer->string string-pointer))
(debug pointer-string)
(assert equal? (string? pointer-string) #t)
(assert string=? pointer-string "Hello world")
(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org")
(define test-url-string "https://scheme.org")
(debug test-url-string)
(define test-url (pffi-string->pointer test-url-string))
(debug test-url)
(debug (pffi-pointer->string test-url))
(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t)
;; pffi-size-of ;; pffi-size-of
(print-header 'pffi-size-of) (print-header 'pffi-size-of)
@ -202,6 +162,47 @@
(assert equal? (number? size-pointer) #t) (assert equal? (number? size-pointer) #t)
(assert = size-pointer 8) (assert = size-pointer 8)
;; 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-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)
(assert equal? (pffi-pointer-null? string-pointer) #f)
;; pffi-pointer->string
(print-header 'pffi-pointer->string)
(define pointer-string (pffi-pointer->string string-pointer))
(debug pointer-string)
(assert equal? (string? pointer-string) #t)
(assert string=? pointer-string "Hello world")
(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org")
(define test-url-string "https://scheme.org")
(debug test-url-string)
(define test-url (pffi-string->pointer test-url-string))
(debug test-url)
(debug (pffi-pointer->string test-url))
(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t)
;; pffi-pointer-allocate ;; pffi-pointer-allocate
@ -334,10 +335,11 @@
(print-header 'pffi-define) (print-header 'pffi-define)
(pffi-define atoi-pointer libc-stdlib 'atoi 'int (list 'pointer)) (pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
(assert = (atoi-pointer (pffi-string->pointer "100")) 100) (assert = (atoi (pffi-string->pointer "100")) 100)
(exit 0)
(exit)
;; pffi-define-callback ;; pffi-define-callback
(print-header 'pffi-define-callback) (print-header 'pffi-define-callback)
@ -361,17 +363,16 @@
'void 'void
(list 'pointer 'int 'int 'pointer) (list 'pointer 'int 'int 'pointer)
(lambda (pointer size nmemb client-pointer) (lambda (pointer size nmemb client-pointer)
(set! result (string-append result (pffi-pointer->string pointer))))) (set! result (string-append result (string-copy (pffi-pointer->string pointer))))))
(define handle (curl-easy-init)) (define handle (curl-easy-init))
(define url "https://scheme.org") (define url "https://scheme.org")
(define url-pointer (pffi-string->pointer url))
(debug url) (debug url)
(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url-pointer)) (define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION (pffi-string->pointer url)))
(debug curl-code1) (debug curl-code1)
(assert = curl-code1 0) (assert = curl-code1 0)
(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url-pointer)) (define curl-code2 (curl-easy-setopt handle CURLOPT-URL (pffi-string->pointer url)))
(debug curl-code2) (debug curl-code2)
(assert = curl-code2 0) (assert = curl-code2 0)