From 22e30570d06696edcc47f8774f97086d4fa14c04 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Tue, 3 Sep 2024 21:23:15 +0300 Subject: [PATCH] Started building the unified test file --- Makefile | 20 ++++++------- retropikzel/r7rs-pffi/version/chicken.scm | 26 ----------------- retropikzel/r7rs-pffi/version/guile.scm | 1 - retropikzel/r7rs-pffi/version/main.rkt | 4 +-- retropikzel/r7rs-pffi/version/main.scm | 4 +-- retropikzel/r7rs-pffi/version/main.sld | 4 +-- test.scm | 34 +++++++++++++++++++---- 7 files changed, 42 insertions(+), 51 deletions(-) diff --git a/Makefile b/Makefile index 318810a..b58a9fc 100644 --- a/Makefile +++ b/Makefile @@ -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" diff --git a/retropikzel/r7rs-pffi/version/chicken.scm b/retropikzel/r7rs-pffi/version/chicken.scm index c006585..50cc92c 100644 --- a/retropikzel/r7rs-pffi/version/chicken.scm +++ b/retropikzel/r7rs-pffi/version/chicken.scm @@ -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)) diff --git a/retropikzel/r7rs-pffi/version/guile.scm b/retropikzel/r7rs-pffi/version/guile.scm index 77c8856..04053f4 100644 --- a/retropikzel/r7rs-pffi/version/guile.scm +++ b/retropikzel/r7rs-pffi/version/guile.scm @@ -70,7 +70,6 @@ procedure (map pffi-type->native-type argument-types)))))) - (define pffi-size-of (lambda (type) (sizeof (pffi-type->native-type type)))) diff --git a/retropikzel/r7rs-pffi/version/main.rkt b/retropikzel/r7rs-pffi/version/main.rkt index 0a5ac63..5c3f403 100644 --- a/retropikzel/r7rs-pffi/version/main.rkt +++ b/retropikzel/r7rs-pffi/version/main.rkt @@ -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") diff --git a/retropikzel/r7rs-pffi/version/main.scm b/retropikzel/r7rs-pffi/version/main.scm index 2ac8ed4..f3798cc 100644 --- a/retropikzel/r7rs-pffi/version/main.scm +++ b/retropikzel/r7rs-pffi/version/main.scm @@ -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") diff --git a/retropikzel/r7rs-pffi/version/main.sld b/retropikzel/r7rs-pffi/version/main.sld index 2ac8ed4..f3798cc 100644 --- a/retropikzel/r7rs-pffi/version/main.sld +++ b/retropikzel/r7rs-pffi/version/main.sld @@ -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") diff --git a/test.scm b/test.scm index 37091ad..0524dc8 100644 --- a/test.scm +++ b/test.scm @@ -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)