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

Started building the unified test file

This commit is contained in:
retropikzel 2024-09-03 21:23:15 +03:00
parent 3b1fbc6643
commit 22e30570d0
7 changed files with 42 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Makefile
View File

@ -18,6 +18,12 @@ test-tier1: \
test-sagittarius \
test-racket
test-tier2:
test-cyclone \
test-gambit \
test-stklos
CHICKEN_LIB=csc -X r7rs -R r7rs -s -J
build-chicken-libs:
cp retropikzel/r7rs-pffi/version/chicken.scm retropikzel.r7rs-pffi.version.chicken.scm
@ -53,7 +59,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
@ -63,21 +70,10 @@ SASH=sash -L . -L ./schubert
test-sagittarius: build
${SCHEME_RUNNER} sagittarius "${SASH} test.scm"
test-sagittarius-wine: build
PACKAGES="${TEST_PACKAGES_APT}" \
WINE="true" \
scheme_runner sagittarius "bash"
RACKET=racket -I r7rs -S . -S ./schubert --script
test-racket: build
#${SCHEME_RUNNER} racket "racket --help"
${SCHEME_RUNNER} racket "${RACKET} test.scm"
test-racket-wine: build
PACKAGES="${TEST_PACKAGES_APT}" \
WINE=true \
scheme_runner racket "bash test-racket-wine.sh"
STKLOS=stklos -A . -A ./schubert -f
test-stklos: build
${SCHEME_RUNNER} stklos "${STKLOS} test.scm"

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

@ -143,32 +143,6 @@
(begin ,@ procedure-body))
(define ,scheme-name (location external_123456789)))))))
(define-syntax pffi-size-of-old
(er-macro-transformer
(lambda (expr rename compare)
(let ((type (car (cdr (car (cdr expr))))))
(cond ((equal? type 'int8) `(foreign-value "sizeof(int8_t)" int))
((equal? type 'uint8) `(foreign-value "sizeof(uint8_t)" int))
((equal? type 'int16) `(foreign-value "sizeof(int16_t)" int))
((equal? type 'uint16) `(foreign-value "sizeof(uint16_t)" int))
((equal? type 'int32) `(foreign-value "sizeof(int32_t)" int))
((equal? type 'uint32) `(foreign-value "sizeof(uint32_t)" int))
((equal? type 'int64) `(foreign-value "sizeof(int64_t)" int))
((equal? type 'uint64) `(foreign-value "sizeof(uint64_t)" int))
((equal? type 'char) `(foreign-value "sizeof(char)" int))
((equal? type 'unsigned-char) `(foreign-value "sizeof(unsigned char)" int))
((equal? type 'short) `(foreign-value "sizeof(short)" int))
((equal? type 'unsigned-short) `(foreign-value "sizeof(unsigned short)" int))
((equal? type 'int) `(foreign-value "sizeof(int)" int))
((equal? type 'unsigned-int) `(foreign-value "sizeof(unsigned int)" int))
((equal? type 'long) `(foreign-value "sizeof(long)" int))
((equal? type 'unsigned-long) `(foreign-value "sizeof(unsigned long)" int))
((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-size-of
(lambda (type)
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))

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

@ -70,7 +70,6 @@
procedure
(map pffi-type->native-type argument-types))))))
(define pffi-size-of
(lambda (type)
(sizeof (pffi-type->native-type type))))

4
retropikzel/r7rs-pffi/version/main.rkt
View File

@ -63,7 +63,8 @@
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel r7rs-pffi version mit-scheme))))
(retropikzel r7rs-pffi version mit-scheme)))
(else (error "Unsupported version")))
(export pffi-init
pffi-shared-object-auto-load
pffi-shared-object-load
@ -90,7 +91,6 @@
(chicken (import (chicken foreign)))
(else #t)))))
(define pffi-os-name
(cond-expand
(windows "windows")

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

@ -62,7 +62,8 @@
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel r7rs-pffi version mit-scheme))))
(retropikzel r7rs-pffi version mit-scheme)))
(else (error "Unsupported version")))
(export pffi-init
pffi-shared-object-auto-load
pffi-shared-object-load
@ -89,7 +90,6 @@
(chicken (import (chicken foreign)))
(else #t)))))
(define pffi-os-name
(cond-expand
(windows "windows")

4
retropikzel/r7rs-pffi/version/main.sld
View File

@ -62,7 +62,8 @@
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel r7rs-pffi version mit-scheme))))
(retropikzel r7rs-pffi version mit-scheme)))
(else (error "Unsupported version")))
(export pffi-init
pffi-shared-object-auto-load
pffi-shared-object-load
@ -89,7 +90,6 @@
(chicken (import (chicken foreign)))
(else #t)))))
(define pffi-os-name
(cond-expand
(windows "windows")

34
test.scm
View File

@ -4,19 +4,42 @@
(scheme process-context)
(retropikzel r7rs-pffi version main))
(define tag 'none)
(define exit-on-fail? #t)
(define tag 'none)
(define-syntax assert
(syntax-rules ()
((_ check value)
(when (not (apply check (list value)))
(let ((result (apply check (list value))))
(if (not result) (display "FAIL: ") (display "PASS: "))
(display "[")
(display tag)
(display "] ")
(display "Assert failed: ")
(write (list 'check 'value))
(newline)))))
(newline)
(when (and exit-on-fail? (not result)) (exit 1))
))))
;; pffi-init
(set! tag 'pffi-init)
(pffi-init)
;; pffi-shared-object-auto-load
(set! tag 'pffi-shared-object-auto-load-libc)
(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
(set! tag 'pffi-define-atoi)
(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
(assert number? (atoi (pffi-string->pointer "100")))
;; Size of
(set! tag 'size-of)
(assert number? (pffi-size-of 'int8))
@ -38,7 +61,6 @@
(assert number? (pffi-size-of 'float))
(assert number? (pffi-size-of 'double))
(assert number? (pffi-size-of 'string))
(assert string? (pffi-size-of 'pointer))
(assert number? (pffi-size-of 'pointer))
(exit 0)