diff --git a/.gitignore b/.gitignore index fe47a0c..56c96cc 100644 --- a/.gitignore +++ b/.gitignore @@ -34,3 +34,5 @@ retropikzel/pffi/version/main.rkt *.sld *.rkt site +test +schubert diff --git a/Makefile b/Makefile index 8cabd73..56a485f 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,7 @@ -TEST_PACKAGES_APT=libcurl4 libcurl4-openssl-dev +TEST_PACKAGES_APT="libcurl4-openssl-dev libuv1" +SCHEME_RUNNER=PACKAGES=${TEST_PACKAGES_APT} scheme_runner +TESTFILES=$(shell ls tests/*.scm) +SRFI_BUNDLE_VERSION=v0-1-0 build: retropikzel/r7rs-pffi/version/*.scm cp retropikzel/r7rs-pffi/version/main.scm retropikzel/r7rs-pffi/version/main.sld @@ -12,54 +15,75 @@ test-all: \ test-chicken\ test-cyclone \ test-gambit \ - test-gerbil \ test-guile \ test-kawa \ test-sagittarius \ - test-racket \ - test-stklos + test-racket -test-chicken: build - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner chicken "bash test-chicken.sh" +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 + ${SCHEME_RUNNER} chicken "${CHICKEN_LIB} retropikzel.r7rs-pffi.version.chicken.scm" + cp retropikzel/r7rs-pffi/version/main.scm retropikzel.r7rs-pffi.version.main.scm + ${SCHEME_RUNNER} chicken "${CHICKEN_LIB} retropikzel.r7rs-pffi.version.main.scm" -test-cyclone: build +CHICKEN=csc -X r7rs -R r7rs -L -lcurl +test-chicken: clean build build-chicken-libs + ${SCHEME_RUNNER} chicken "${CHICKEN} test.scm" + ${SCHEME_RUNNER} chicken "./test" + +CYCLONE=cyclone -A . -A ./schubert +build-cyclone-libs: + ${SCHEME_RUNNER} cyclone "${CYCLONE} retropikzel/r7rs-pffi/version/cyclone.scm" + ${SCHEME_RUNNER} cyclone "${CYCLONE} retropikzel/r7rs-pffi/version/main.scm" + ${SCHEME_RUNNER} cyclone "${CYCLONE} test.scm" + ${SCHEME_RUNNER} cyclone "./test" + +CYCLONE=cyclone -A . -A ./schubert +test-cyclone: clean build build-cyclone-libs PACKAGES="${TEST_PACKAGES_APT}" \ scheme_runner cyclone "bash test-cyclone.sh" -test-gambit: build - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner gambit "bash test-gambit.sh" +GAMBIT_LIB=gsc -:r7rs,search=. -dynamic +build-gambit-libs: + ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/pffi/version/gambit.scm" + ${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/pffi/version/main.sld" -test-gerbil: build - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner gerbil "bash test-gerbil.sh" +GAMBIT=gsc -:r7rs,search=. -ld-options -lcurl -exe +test-gambit: clean build + ${SCHEME_RUNNER} gambit "${GAMBIT} test.scm" +GUILE=guile -L . -L ./schubert test-guile: build - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner guile "bash test-guile.sh" + ${SCHEME_RUNNER} guile "${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 - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner kawa "bash test-kawa.sh" + ${SCHEME_RUNNER} kawa "${KAWA} test.scm" +SASH=sash -L . -L ./schubert test-sagittarius: build - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner sagittarius "bash test-sagittarius.sh" + ${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 - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner racket "bash test-racket.sh" + #${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 - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_runner stklos "bash test-stklos.sh" + ${SCHEME_RUNNER} stklos "${STKLOS} test.scm" -test-amd64-wine: build - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_testrunner sagittarius_wine "bash test-sagittarius-wine.sh" - PACKAGES="${TEST_PACKAGES_APT}" \ - scheme_testrunner racket_wine "bash test-racket-wine.sh" tmp: mkdir -p tmp @@ -84,4 +108,4 @@ clean: rm -rf *.o rm -rf *.so rm -rf *.a - find ./test -type f -not -name "*.scm" -exec bash -c "test -x {} && rm {}" \; + rm -rf test diff --git a/composition.scm b/composition.scm index f33dca6..8b53ba2 100644 --- a/composition.scm +++ b/composition.scm @@ -1,7 +1,9 @@ ((packager . "retropikzel") - (name . "r7rs-pffi") - (version . "v0-4-4") - (type . "library") - (description . "Portable Foreign Function Interface for R7RS schemes") - (license . "LGPL") - (dependencies ())) + (name . "r7rs-pffi") + (version . "v0-4-4") + (type . "library") + (description . "Portable Foreign Function Interface for R7RS schemes") + (license . "LGPL") + (dependencies ()) + (development-dependencies ()) + ) \ No newline at end of file diff --git a/old-tests/100_hello b/old-tests/100_hello new file mode 100755 index 0000000..e6372c6 Binary files /dev/null and b/old-tests/100_hello differ diff --git a/test/100_hello.scm b/old-tests/100_hello.scm similarity index 100% rename from test/100_hello.scm rename to old-tests/100_hello.scm diff --git a/old-tests/200_import b/old-tests/200_import new file mode 100755 index 0000000..68f0502 Binary files /dev/null and b/old-tests/200_import differ diff --git a/test/200_import.scm b/old-tests/200_import.scm similarity index 100% rename from test/200_import.scm rename to old-tests/200_import.scm diff --git a/old-tests/300_size-of b/old-tests/300_size-of new file mode 100755 index 0000000..a0f367a Binary files /dev/null and b/old-tests/300_size-of differ diff --git a/test/300_size-of.scm b/old-tests/300_size-of.scm similarity index 100% rename from test/300_size-of.scm rename to old-tests/300_size-of.scm diff --git a/test/400_pointer-allocate-free.scm b/old-tests/400_pointer-allocate-free.scm similarity index 100% rename from test/400_pointer-allocate-free.scm rename to old-tests/400_pointer-allocate-free.scm diff --git a/test/401_is-pointer.scm b/old-tests/401_is-pointer.scm similarity index 100% rename from test/401_is-pointer.scm rename to old-tests/401_is-pointer.scm diff --git a/test/402_null-pointer.scm b/old-tests/402_null-pointer.scm similarity index 100% rename from test/402_null-pointer.scm rename to old-tests/402_null-pointer.scm diff --git a/test/410_pointer-set-get.scm b/old-tests/410_pointer-set-get.scm similarity index 100% rename from test/410_pointer-set-get.scm rename to old-tests/410_pointer-set-get.scm diff --git a/test/500_string-to-pointer-to-string.scm b/old-tests/500_string-to-pointer-to-string.scm similarity index 100% rename from test/500_string-to-pointer-to-string.scm rename to old-tests/500_string-to-pointer-to-string.scm diff --git a/test/600_libc.scm b/old-tests/600_libc.scm similarity index 100% rename from test/600_libc.scm rename to old-tests/600_libc.scm diff --git a/test/700_pffi-define.scm b/old-tests/700_pffi-define.scm similarity index 100% rename from test/700_pffi-define.scm rename to old-tests/700_pffi-define.scm diff --git a/test/800_libcurl.scm b/old-tests/800_libcurl.scm similarity index 100% rename from test/800_libcurl.scm rename to old-tests/800_libcurl.scm diff --git a/retropikzel/r7rs-pffi/version/chicken.scm b/retropikzel/r7rs-pffi/version/chicken.scm index 99c5809..c006585 100644 --- a/retropikzel/r7rs-pffi/version/chicken.scm +++ b/retropikzel/r7rs-pffi/version/chicken.scm @@ -242,8 +242,8 @@ (define pffi-pointer-null? (lambda (pointer) (if (not (pointer? pointer)) - (error "pffi-pointer-null? -- Argument is not pointer" pointer)) - (= (pointer->address pointer) 0))) + #f + (= (pointer->address pointer) 0)))) (define pffi-pointer-set! (lambda (pointer type offset value) diff --git a/schubert/retropikzel/r7rs-pffi/version/chicken b/schubert/retropikzel/r7rs-pffi/version/chicken deleted file mode 100755 index 96c1db8..0000000 Binary files a/schubert/retropikzel/r7rs-pffi/version/chicken and /dev/null differ diff --git a/schubert/retropikzel/r7rs-pffi/version/chicken.scm b/schubert/retropikzel/r7rs-pffi/version/chicken.scm deleted file mode 100644 index 33ed21f..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/chicken.scm +++ /dev/null @@ -1,259 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version chicken) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (chicken foreign) - (chicken syntax) - (chicken memory) - (chicken random)) - (export pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32) - ((equal? type 'uint32) 'unsigned-int32) - ((equal? type 'int64) 'integer-64) - ((equal? type 'uint64) 'unsigned-integer64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((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)))) ) - - (define pffi-pointer? - (lambda (object) - (pointer? object))) - - (define-syntax pffi-define - (er-macro-transformer - (lambda (expr rename compare) - (let* ((pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32) - ((equal? type 'uint32) 'unsigned-int32) - ((equal? type 'int64) 'integer-64) - ((equal? type 'uint64) 'unsigned-integer64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((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))))) - (scheme-name (car (cdr expr))) - (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) - (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) - (argument-types - (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) - (if (null? types) - '() - (map pffi-type->native-type (map car (map cdr types))))))) - (if (null? argument-types) - `(define ,scheme-name - (foreign-safe-lambda ,return-type ,c-name)) - `(define ,scheme-name - (foreign-safe-lambda ,return-type ,c-name ,@ argument-types))))))) - - (define-syntax pffi-define-callback - (er-macro-transformer - (lambda (expr rename compare) - (let* ((pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32) - ((equal? type 'uint32) 'unsigned-int32) - ((equal? type 'int64) 'integer-64) - ((equal? type 'uint64) 'unsigned-integer64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((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))))) - (scheme-name (car (cdr expr))) - (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr))))))) - (argument-types - (let ((types (cdr (car (cdr (cdr (cdr expr))))))) - (if (null? types) - '() - (map pffi-type->native-type (map car (map cdr types)))))) - (argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr)))))))) - (arguments (map - (lambda (name type) - `(,name ,type)) - argument-types argument-names)) - (procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr))))))))) - `(begin (define-external ,(cons 'external_123456789 arguments) - ,return-type - (begin ,@ procedure-body)) - (define ,scheme-name (location external_123456789))) - )))) - - (define-syntax pffi-size-of - (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(int)" int)) - (else `(error "pffi-size-of -- No such pffi type" type))))))) - - (define pffi-pointer-allocate - (lambda (size) - (allocate size))) - - (define pffi-pointer-null - (lambda () - (address->pointer 0))) - - (define pffi-string->pointer - (lambda (string-content) - (location string-content))) - - (pffi-define strlen #f 'strlen 'int (list 'pointer)) - - (define pffi-pointer->string - (lambda (pointer) - (if (string? pointer) - pointer - (let* ((size (strlen pointer)) - (string-content (make-string size))) - (move-memory! pointer string-content size 0) - string-content)))) - - (define-syntax pffi-shared-object-load - (er-macro-transformer - (lambda (expr rename compare) - (let* ((headers (cdr (car (cdr expr))))) - `(begin - ,@ (map - (lambda (header) - `(foreign-declare ,(string-append "#include <" header ">"))) - headers)))))) - - (define pffi-pointer-free - (lambda (pointer) - (free pointer))) - - (define pffi-pointer-null? - (lambda (pointer) - (and (pffi-pointer? pointer) - (= (pointer->address pointer) 0)))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (cond - ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value)) - ((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value)) - ((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value)) - ((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value)) - ((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value)) - ((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value)) - ((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value)) - ((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value)) - ((equal? type 'pointer) (pointer-u32-set! (pointer+ pointer offset) value))))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (cond - ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset))) - ((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset))) - ((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset))) - ((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset))) - ((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset))) - ((equal? type 'char) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset))) - ((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset))) - ((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'double) (pointer-s32-ref (pointer+ pointer offset))) - ((equal? type 'pointer) (pointer-u32-ref (pointer+ pointer offset)))))) - - (define pffi-pointer-deref - (lambda (pointer) - pointer)))) diff --git a/schubert/retropikzel/r7rs-pffi/version/cyclone.scm b/schubert/retropikzel/r7rs-pffi/version/cyclone.scm deleted file mode 100644 index 4b136ca..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/cyclone.scm +++ /dev/null @@ -1,145 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version cyclone) - (import (scheme base) - (scheme write) - (scheme file) - (scheme eval) - (scheme process-context) - (scheme eval) - (cyclone foreign) - (scheme cyclone primitives)) - (export pffi-shared-object-load - pffi-define - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) int) - ((equal? type 'uint8) int) - ((equal? type 'int16) int) - ((equal? type 'uint16) int) - ((equal? type 'int32) int) - ((equal? type 'uint32) int) - ((equal? type 'int64) int) - ((equal? type 'uint64) int) - ((equal? type 'char) char) - ((equal? type 'unsigned-char) char) - ((equal? type 'short) int) - ((equal? type 'unsigned-short) int) - ((equal? type 'int) int) - ((equal? type 'unsigned-int) int) - ((equal? type 'long) int) - ((equal? type 'unsigned-long) int) - ((equal? type 'float) float) - ((equal? type 'double) double) - ((equal? type 'pointer) opaque) - ((equal? type 'string) string) - ((equal? type 'void) c-void) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - - (define pffi-pointer? - (lambda (object) - (error "Not defined"))) - - - (define-syntax pffi-define - (er-macro-transformer - (lambda (expr rename compare) - (let* ((pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32) - ((equal? type 'uint32) 'unsigned-int32) - ((equal? type 'int64) 'integer-64) - ((equal? type 'uint64) 'unsigned-integer64) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'unsigned-char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((equal? type 'float) 'float) - ((equal? type 'double) 'double) - ((equal? type 'pointer) 'c-pointer) - ((equal? type 'string) 'c-string) - ((equal? type 'void) 'void) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - (scheme-name (car (cdr expr))) - (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) - (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) - (argument-types - (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) - (if (null? types) - '() - (map pffi-type->native-type (map car (map cdr types))))))) - (if (null? argument-types) - `(c-define ,scheme-name ,return-type ,c-name) - `(c-define ,scheme-name - ,return-type ,c-name ,@ argument-types)))))) - - - (define pffi-size-of - (lambda (type) - (error "Not defined"))) - - (define pffi-pointer-allocate - (lambda (size) - (error "Not defined"))) - - (define pffi-pointer-null - (lambda () - (error "Not defined"))) - - (define pffi-string->pointer - (lambda (string-content) - (error "Not defined"))) - - (define pffi-pointer->string - (lambda (pointer) - pointer)) - - (define-syntax pffi-shared-object-load - (er-macro-transformer - (lambda (expr rename compare) - `(begin - ,@ (map - (lambda (header) - `(include-c-header ,(string-append "<" header ">"))) - (cdr (car (cdr expr)))))))) - - (define pffi-pointer-free - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-null? - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (error "Not defined"))) - - (define pffi-pointer-deref - (lambda (pointer) - (error "Not defined"))))) diff --git a/schubert/retropikzel/r7rs-pffi/version/empty.scm b/schubert/retropikzel/r7rs-pffi/version/empty.scm deleted file mode 100644 index 027fe07..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/empty.scm +++ /dev/null @@ -1,79 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version empty) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context)) - (export pffi-shared-object-load - pffi-define - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (error "Not defined"))) - - (define pffi-pointer? - (lambda (object) - (error "Not defined"))) - - (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (error "Not defined")))) - - - (define pffi-size-of - (lambda (type) - (error "Not defined"))) - - (define pffi-pointer-allocate - (lambda (size) - (error "Not defined"))) - - (define pffi-pointer-null - (lambda () - (error "Not defined"))) - - (define pffi-string->pointer - (lambda (string-content) - (error "Not defined"))) - - (define pffi-pointer->string - (lambda (pointer) - pointer)) - - (define pffi-shared-object-load - (lambda (header path) - (error "Not defined"))) - - (define pffi-pointer-free - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-null? - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (error "Not defined"))) - - (define pffi-pointer-deref - (lambda (pointer) - (error "Not defined"))))) diff --git a/schubert/retropikzel/r7rs-pffi/version/gambit.scm b/schubert/retropikzel/r7rs-pffi/version/gambit.scm deleted file mode 100644 index fdd9d36..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/gambit.scm +++ /dev/null @@ -1,77 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version gambit) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context)) - (export pffi-shared-object-load - pffi-define - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (error "Not defined"))) - - (define pffi-pointer? - (lambda (object) - (error "Not defined"))) - - (define pffi-define - (lambda (scheme-name shared-object c-name return-type argument-types) - (error "Not defined"))) - - (define pffi-size-of - (lambda (type) - (error "Not defined"))) - - (define pffi-pointer-allocate - (lambda (size) - (error "Not defined"))) - - (define pffi-pointer-null - (lambda () - (error "Not defined"))) - - (define pffi-string->pointer - (lambda (string-content) - (error "Not defined"))) - - (define pffi-pointer->string - (lambda (pointer) - pointer)) - - (define pffi-shared-object-load - (lambda (headers) - (error "Not defined"))) - - (define pffi-pointer-free - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-null? - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (error "Not defined"))) - - (define pffi-pointer-deref - (lambda (pointer) - (error "Not defined"))))) diff --git a/schubert/retropikzel/r7rs-pffi/version/gerbil.scm b/schubert/retropikzel/r7rs-pffi/version/gerbil.scm deleted file mode 100644 index 8e454d7..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/gerbil.scm +++ /dev/null @@ -1,79 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version gerbil) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context)) - (export pffi-shared-object-load - pffi-define - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (error "Not defined"))) - - (define pffi-pointer? - (lambda (object) - (error "Not defined"))) - - (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (error "Not defined")))) - - - (define pffi-size-of - (lambda (type) - (error "Not defined"))) - - (define pffi-pointer-allocate - (lambda (size) - (error "Not defined"))) - - (define pffi-pointer-null - (lambda () - (error "Not defined"))) - - (define pffi-string->pointer - (lambda (string-content) - (error "Not defined"))) - - (define pffi-pointer->string - (lambda (pointer) - pointer)) - - (define pffi-shared-object-load - (lambda (header path) - (error "Not defined"))) - - (define pffi-pointer-free - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-null? - (lambda (pointer) - (error "Not defined"))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (error "Not defined")))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (error "Not defined"))) - - (define pffi-pointer-deref - (lambda (pointer) - (error "Not defined"))))) diff --git a/schubert/retropikzel/r7rs-pffi/version/guile.scm b/schubert/retropikzel/r7rs-pffi/version/guile.scm deleted file mode 100644 index 5b3ffee..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/guile.scm +++ /dev/null @@ -1,154 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version guile) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (rnrs bytevectors) - (system foreign) - (system foreign-library)) - (export pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) int8) - ((equal? type 'uint8) uint8) - ((equal? type 'int16) int16) - ((equal? type 'uint16) uint16) - ((equal? type 'int32) int32) - ((equal? type 'uint32) uint32) - ((equal? type 'int64) int64) - ((equal? type 'uint64) uint64) - ((equal? type 'char) int) - ((equal? type 'unsigned-char) int) - ((equal? type 'short) short) - ((equal? type 'unsigned-short) unsigned-short) - ((equal? type 'int) int) - ((equal? type 'unsigned-int) unsigned-int) - ((equal? type 'long) long) - ((equal? type 'unsigned-long) unsigned-long) - ((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))))) - - (define pffi-pointer? - (lambda (object) - (pointer? object))) - - (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (foreign-library-function shared-object - (symbol->string c-name) - #:return-type (pffi-type->native-type return-type) - #:arg-types (map pffi-type->native-type argument-types)))))) - - (define-syntax pffi-define-callback - (syntax-rules () - ((pffi-define scheme-name return-type argument-types procedure) - (define scheme-name - (procedure->pointer (pffi-type->native-type return-type) - procedure - (map pffi-type->native-type argument-types)))))) - - - (define pffi-size-of - (lambda (type) - (sizeof (pffi-type->native-type type)))) - - (define pffi-pointer-allocate - (lambda (size) - (bytevector->pointer (make-bytevector size 0)))) - - (define pffi-pointer-null - (lambda () - (make-pointer 0))) - - (define pffi-string->pointer - (lambda (string-content) - (string->pointer string-content))) - - (define pffi-pointer->string - (lambda (pointer) - (pointer->string pointer))) - - (define pffi-shared-object-load - (lambda (header path) - (load-foreign-library path))) - - (define pffi-pointer-free - (lambda (pointer) - #t)) - - (define pffi-pointer-null? - (lambda (pointer) - (and (pffi-pointer? pointer) - (null-pointer? pointer)))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p (pointer->bytevector pointer (+ offset 100))) - (native-type (pffi-type->native-type type))) - (cond ((equal? native-type int8) (bytevector-s8-set! p offset value)) - ((equal? native-type uint8) (bytevector-u8-set! p offset value)) - ((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness))) - ((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness))) - ((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness))) - ((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness))) - ((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness))) - ((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness))) - ((equal? native-type short) (bytevector-s8-set! p offset value (native-endianness))) - ((equal? native-type unsigned-short) (bytevector-u8-set! p offset value)) - ((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type))) - ((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type))) - ((equal? native-type long) (bytevector-s64-set! p offset value (native-endianness))) - ((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness))) - ((equal? native-type float) (bytevector-u64-set! p offset value (native-endianness))) - ((equal? native-type double) (bytevector-u64-set! p offset value (native-endianness))) - ((equal? native-type '*) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type)))) - ))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (let ((p (pointer->bytevector pointer (+ offset 100))) - (native-type (pffi-type->native-type type))) - (cond ((equal? native-type int8) (bytevector-s8-ref p offset)) - ((equal? native-type uint8) (bytevector-u8-ref p offset)) - ((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness))) - ((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness))) - ((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness))) - ((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness))) - ((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness))) - ((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness))) - ((equal? native-type short) (bytevector-s8-ref p offset)) - ((equal? native-type unsigned-short) (bytevector-u8-ref p offset)) - ((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))) - ((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type))) - ((equal? native-type long) (bytevector-s64-ref p offset (native-endianness))) - ((equal? native-type unsigned-long) (bytevector-u64-ref p offset (native-endianness))) - ((equal? native-type float) (bytevector-u64-ref p offset (native-endianness))) - ((equal? native-type double) (bytevector-u64-ref p offset (native-endianness))) - ((equal? native-type '*) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))))))) - - (define pffi-pointer-deref - (lambda (pointer) - (dereference-pointer pointer))))) diff --git a/schubert/retropikzel/r7rs-pffi/version/kawa.scm b/schubert/retropikzel/r7rs-pffi/version/kawa.scm deleted file mode 100644 index cfd4ef0..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/kawa.scm +++ /dev/null @@ -1,132 +0,0 @@ - -(define arena (invoke-static java.lang.foreign.Arena 'global)) - -(define value->object - (lambda (value type) - (cond ((equal? type 'byte) - (java.lang.Byte value)) - ((equal? type 'short) - (java.lang.Short value)) - ((equal? type 'int) - (java.lang.Integer value)) - ((equal? type 'long) - (java.lang.Long value)) - ((equal? type 'float) - (java.lang.Float value)) - ((equal? type 'double) - (java.lang.Double value)) - ((equal? type 'char) - (java.lang.Char value)) - (else value)))) - - -(define pffi-type->native-type - (lambda (type) - (cond - ((equal? type 'int8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) - ((equal? type 'uint8) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 1)) - ((equal? type 'int16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) - ((equal? type 'uint16) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 2)) - ((equal? type 'int32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) - ((equal? type 'uint32) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 4)) - ((equal? type 'int64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) - ((equal? type 'uint64) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_INT) 'withByteAlignment 8)) - ((equal? type 'char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR)) - ((equal? type 'unsigned-char) (static-field java.lang.foreign.ValueLayout 'JAVA_CHAR)) - ((equal? type 'short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT)) - ((equal? type 'unsigned-short) (static-field java.lang.foreign.ValueLayout 'JAVA_SHORT)) - ((equal? type 'int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) - ((equal? type 'unsigned-int) (static-field java.lang.foreign.ValueLayout 'JAVA_INT)) - ((equal? type 'long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG)) - ((equal? type 'unsigned-long) (static-field java.lang.foreign.ValueLayout 'JAVA_LONG)) - ((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->native-type -- No such pffi type" type))))) - -(define pffi-pointer? - (lambda (object) - (string=? (invoke (invoke object 'getClass) 'getName) - "jdk.internal.foreign.NativeMemorySegmentImpl"))) - -(define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid)) - (of (class-methods java.lang.foreign.FunctionDescriptor 'of)) - (function-descriptor (if (equal? return-type 'void) - (apply of-void (map pffi-type->native-type argument-types)) - (apply of (append (list (pffi-type->native-type return-type)) (map pffi-type->native-type argument-types))))) - (method-handle (invoke (cdr (assoc 'linker shared-object)) - 'downcallHandle - (invoke (invoke (cdr (assoc 'lookup shared-object)) - 'find - (symbol->string c-name)) - 'orElseThrow) - function-descriptor))) - - (lambda vals - (invoke method-handle 'invokeWithArguments (map value->object vals argument-types)))))))) - - - -(define pffi-size-of - (lambda (type) - (invoke (pffi-type->native-type type) 'byteAlignment))) - -(define pffi-pointer-allocate - (lambda (size) - (invoke arena 'allocate size 1))) - -(define pffi-pointer-null - (lambda () - (static-field java.lang.foreign.MemorySegment 'NULL))) - -(define pffi-string->pointer - (lambda (string-content) - (invoke arena 'allocateUtf8String string-content))) - -(define pffi-pointer->string - (lambda (pointer) - (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getUtf8String 0))) - -(define pffi-shared-object-load - (lambda (header path) - (let* ((library-file (make java.io.File path)) - (file-name (invoke library-file 'getName)) - (library-parent-folder (make java.io.File (invoke library-file 'getParent))) - (absolute-path (string-append (invoke library-parent-folder 'getCanonicalPath) - "/" - file-name)) - ;(set! arena (invoke-static java.lang.foreign.Arena 'ofConfined)) - - (linker (invoke-static java.lang.foreign.Linker 'nativeLinker)) - (lookup (invoke-static java.lang.foreign.SymbolLookup - 'libraryLookup - absolute-path - arena))) - (list (cons 'linker linker) - (cons 'lookup lookup))))) - -(define pffi-pointer-free - (lambda (pointer) - #t)) - -(define pffi-pointer-null? - (lambda (pointer) - (invoke pointer 'equals (pffi-pointer-null)))) - -(define pffi-pointer-set! - (lambda (pointer type offset value) - (invoke pointer 'set (pffi-type->native-type type) offset value))) - -(define pffi-pointer-get - (lambda (pointer type offset) - (invoke pointer 'get (pffi-type->native-type type) offset))) - -(define pffi-pointer-deref - (lambda (pointer) - (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0))) diff --git a/schubert/retropikzel/r7rs-pffi/version/main.rkt b/schubert/retropikzel/r7rs-pffi/version/main.rkt deleted file mode 100644 index 99d8971..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/main.rkt +++ /dev/null @@ -1,234 +0,0 @@ -#lang r7rs -(define-library - (retropikzel r7rs-pffi version main) - (cond-expand - (sagittarius - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version sagittarius))) - (guile - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version guile))) - (racket - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (only (racket base) system-type) - (retropikzel r7rs-pffi version racket))) - (stklos - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (stklos) - (retropikzel r7rs-pffi version stklos))) - (kawa - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context))) - (cyclone - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version cyclone))) - (gambit - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version gambit))) - (chicken - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version chicken))) - (chibi - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version chibi))) - (mit-scheme - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version mit-scheme)))) - (export pffi-shared-object-auto-load - pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - - #|doc Testing multiline comment |# - - - - (define library-version "v0-3-0") - (define slash (cond-expand (windows (string #\\)) (else "/"))) - - (define platform-file-extension - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) - (windows ".dll") - (else ".so"))) - - (define platform-lib-prefix - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) "" "lib")) - (windows "") - (else "lib"))) - - (define pffi-types - '(int8 - uint8 - int16 - uint16 - int32 - uint32 - int64 - uint64 - char - unsigned-char - short - unsigned-short - int - unsigned-int - long - unsigned-long - float - double - string - pointer - void)) - - (define string-split - (lambda (str mark) - (let* ((str-l (string->list str)) - (res (list)) - (last-index 0) - (index 0) - (splitter (lambda (c) - (cond ((char=? c mark) - (begin - (set! res (append res (list (string-copy str last-index index)))) - (set! last-index (+ index 1)))) - ((equal? (length str-l) (+ index 1)) - (set! res (append res (list (string-copy str last-index (+ index 1))))))) - (set! index (+ index 1))))) - (for-each splitter str-l) - res))) - - (define auto-load-paths - (append - (cond-expand - (windows - (append - (if (get-environment-variable "SYSTEM") - (list (get-environment-variable "SYSTEM")) - (list)) - (if (get-environment-variable "WINDIR") - (list (get-environment-variable "WINDIR")) - (list)) - (if (get-environment-variable "WINEDLLDIR0") - (list (get-environment-variable "WINEDLLDIR0")) - (list)) - (if (get-environment-variable "SystemRoot") - (list (string-append - (get-environment-variable "SystemRoot") - slash - "system32")) - (list)) - (list ".") - (if (get-environment-variable "PATH") - (string-split (get-environment-variable "PATH") #\;) - (list)))) - (else - (append - ; Guix - (list (if (get-environment-variable "GUIX_ENVIRONMENT") - (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") - "") - "/run/current-system/profile/lib") - ; Debian - (if (get-environment-variable "LD_LIBRARY_PATH") - (list (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)) - (list)) - (list - ;;; x86-64 - ; Debian - "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ;;; aarch64 - ; Debian - "/lib/aarch64-linux-gnu" - "/usr/lib/aarch64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - )))))) - - (define auto-load-versions (list "")) - - (define-syntax pffi-shared-object-auto-load - (syntax-rules () - ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) - (cond-expand - (cyclone (pffi-shared-object-load headers)) - (chicken (pffi-shared-object-load headers)) - (gambit (pffi-shared-object-load headers)) - (else - (let* ((paths (append auto-load-paths additional-paths)) - (versions (append auto-load-versions additional-versions)) - (shared-object #f)) - (for-each - (lambda (path) - (for-each - (lambda (version) - (let ((library-path (string-append path - slash - platform-lib-prefix - object-name - platform-file-extension - version))) - (if (file-exists? library-path) - (set! shared-object library-path)))) - versions)) - paths) - (if (not shared-object) - (error "Could not load shared object" - (list (cons 'object object-name) - (cons 'paths paths) - (cons 'platform-file-extension platform-file-extension) - (cons 'versions versions))) - (pffi-shared-object-load headers shared-object)))))))) - - (cond-expand - (kawa (include "kawa.scm")) - (else #t)))) diff --git a/schubert/retropikzel/r7rs-pffi/version/main.scm b/schubert/retropikzel/r7rs-pffi/version/main.scm deleted file mode 100644 index d0a5241..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/main.scm +++ /dev/null @@ -1,233 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version main) - (cond-expand - (sagittarius - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version sagittarius))) - (guile - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version guile))) - (racket - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (only (racket base) system-type) - (retropikzel r7rs-pffi version racket))) - (stklos - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (stklos) - (retropikzel r7rs-pffi version stklos))) - (kawa - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context))) - (cyclone - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version cyclone))) - (gambit - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version gambit))) - (chicken - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version chicken))) - (chibi - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version chibi))) - (mit-scheme - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version mit-scheme)))) - (export pffi-shared-object-auto-load - pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - - #|doc Testing multiline comment |# - - - - (define library-version "v0-3-0") - (define slash (cond-expand (windows (string #\\)) (else "/"))) - - (define platform-file-extension - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) - (windows ".dll") - (else ".so"))) - - (define platform-lib-prefix - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) "" "lib")) - (windows "") - (else "lib"))) - - (define pffi-types - '(int8 - uint8 - int16 - uint16 - int32 - uint32 - int64 - uint64 - char - unsigned-char - short - unsigned-short - int - unsigned-int - long - unsigned-long - float - double - string - pointer - void)) - - (define string-split - (lambda (str mark) - (let* ((str-l (string->list str)) - (res (list)) - (last-index 0) - (index 0) - (splitter (lambda (c) - (cond ((char=? c mark) - (begin - (set! res (append res (list (string-copy str last-index index)))) - (set! last-index (+ index 1)))) - ((equal? (length str-l) (+ index 1)) - (set! res (append res (list (string-copy str last-index (+ index 1))))))) - (set! index (+ index 1))))) - (for-each splitter str-l) - res))) - - (define auto-load-paths - (append - (cond-expand - (windows - (append - (if (get-environment-variable "SYSTEM") - (list (get-environment-variable "SYSTEM")) - (list)) - (if (get-environment-variable "WINDIR") - (list (get-environment-variable "WINDIR")) - (list)) - (if (get-environment-variable "WINEDLLDIR0") - (list (get-environment-variable "WINEDLLDIR0")) - (list)) - (if (get-environment-variable "SystemRoot") - (list (string-append - (get-environment-variable "SystemRoot") - slash - "system32")) - (list)) - (list ".") - (if (get-environment-variable "PATH") - (string-split (get-environment-variable "PATH") #\;) - (list)))) - (else - (append - ; Guix - (list (if (get-environment-variable "GUIX_ENVIRONMENT") - (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") - "") - "/run/current-system/profile/lib") - ; Debian - (if (get-environment-variable "LD_LIBRARY_PATH") - (list (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)) - (list)) - (list - ;;; x86-64 - ; Debian - "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ;;; aarch64 - ; Debian - "/lib/aarch64-linux-gnu" - "/usr/lib/aarch64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - )))))) - - (define auto-load-versions (list "")) - - (define-syntax pffi-shared-object-auto-load - (syntax-rules () - ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) - (cond-expand - (cyclone (pffi-shared-object-load headers)) - (chicken (pffi-shared-object-load headers)) - (gambit (pffi-shared-object-load headers)) - (else - (let* ((paths (append auto-load-paths additional-paths)) - (versions (append auto-load-versions additional-versions)) - (shared-object #f)) - (for-each - (lambda (path) - (for-each - (lambda (version) - (let ((library-path (string-append path - slash - platform-lib-prefix - object-name - platform-file-extension - version))) - (if (file-exists? library-path) - (set! shared-object library-path)))) - versions)) - paths) - (if (not shared-object) - (error "Could not load shared object" - (list (cons 'object object-name) - (cons 'paths paths) - (cons 'platform-file-extension platform-file-extension) - (cons 'versions versions))) - (pffi-shared-object-load headers shared-object)))))))) - - (cond-expand - (kawa (include "kawa.scm")) - (else #t)))) diff --git a/schubert/retropikzel/r7rs-pffi/version/main.sld b/schubert/retropikzel/r7rs-pffi/version/main.sld deleted file mode 100644 index d0a5241..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/main.sld +++ /dev/null @@ -1,233 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version main) - (cond-expand - (sagittarius - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version sagittarius))) - (guile - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version guile))) - (racket - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (only (racket base) system-type) - (retropikzel r7rs-pffi version racket))) - (stklos - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (stklos) - (retropikzel r7rs-pffi version stklos))) - (kawa - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context))) - (cyclone - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version cyclone))) - (gambit - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version gambit))) - (chicken - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version chicken))) - (chibi - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version chibi))) - (mit-scheme - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (retropikzel r7rs-pffi version mit-scheme)))) - (export pffi-shared-object-auto-load - pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - - #|doc Testing multiline comment |# - - - - (define library-version "v0-3-0") - (define slash (cond-expand (windows (string #\\)) (else "/"))) - - (define platform-file-extension - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so")) - (windows ".dll") - (else ".so"))) - - (define platform-lib-prefix - (cond-expand - (racket (if (equal? (system-type 'os) 'windows) "" "lib")) - (windows "") - (else "lib"))) - - (define pffi-types - '(int8 - uint8 - int16 - uint16 - int32 - uint32 - int64 - uint64 - char - unsigned-char - short - unsigned-short - int - unsigned-int - long - unsigned-long - float - double - string - pointer - void)) - - (define string-split - (lambda (str mark) - (let* ((str-l (string->list str)) - (res (list)) - (last-index 0) - (index 0) - (splitter (lambda (c) - (cond ((char=? c mark) - (begin - (set! res (append res (list (string-copy str last-index index)))) - (set! last-index (+ index 1)))) - ((equal? (length str-l) (+ index 1)) - (set! res (append res (list (string-copy str last-index (+ index 1))))))) - (set! index (+ index 1))))) - (for-each splitter str-l) - res))) - - (define auto-load-paths - (append - (cond-expand - (windows - (append - (if (get-environment-variable "SYSTEM") - (list (get-environment-variable "SYSTEM")) - (list)) - (if (get-environment-variable "WINDIR") - (list (get-environment-variable "WINDIR")) - (list)) - (if (get-environment-variable "WINEDLLDIR0") - (list (get-environment-variable "WINEDLLDIR0")) - (list)) - (if (get-environment-variable "SystemRoot") - (list (string-append - (get-environment-variable "SystemRoot") - slash - "system32")) - (list)) - (list ".") - (if (get-environment-variable "PATH") - (string-split (get-environment-variable "PATH") #\;) - (list)))) - (else - (append - ; Guix - (list (if (get-environment-variable "GUIX_ENVIRONMENT") - (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") - "") - "/run/current-system/profile/lib") - ; Debian - (if (get-environment-variable "LD_LIBRARY_PATH") - (list (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)) - (list)) - (list - ;;; x86-64 - ; Debian - "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - ;;; aarch64 - ; Debian - "/lib/aarch64-linux-gnu" - "/usr/lib/aarch64-linux-gnu" - "/usr/local/lib" - ; Fedora/Alpine - "/usr/lib" - "/usr/lib64" - )))))) - - (define auto-load-versions (list "")) - - (define-syntax pffi-shared-object-auto-load - (syntax-rules () - ((pffi-shared-object-auto-load headers additional-paths object-name additional-versions) - (cond-expand - (cyclone (pffi-shared-object-load headers)) - (chicken (pffi-shared-object-load headers)) - (gambit (pffi-shared-object-load headers)) - (else - (let* ((paths (append auto-load-paths additional-paths)) - (versions (append auto-load-versions additional-versions)) - (shared-object #f)) - (for-each - (lambda (path) - (for-each - (lambda (version) - (let ((library-path (string-append path - slash - platform-lib-prefix - object-name - platform-file-extension - version))) - (if (file-exists? library-path) - (set! shared-object library-path)))) - versions)) - paths) - (if (not shared-object) - (error "Could not load shared object" - (list (cons 'object object-name) - (cons 'paths paths) - (cons 'platform-file-extension platform-file-extension) - (cons 'versions versions))) - (pffi-shared-object-load headers shared-object)))))))) - - (cond-expand - (kawa (include "kawa.scm")) - (else #t)))) diff --git a/schubert/retropikzel/r7rs-pffi/version/racket.scm b/schubert/retropikzel/r7rs-pffi/version/racket.scm deleted file mode 100644 index 3f438f3..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/racket.scm +++ /dev/null @@ -1,118 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version racket) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (compatibility mlist) - (ffi unsafe) - (ffi vector)) - (export pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) _int8) - ((equal? type 'uint8) _uint8) - ((equal? type 'int16) _int16) - ((equal? type 'uint16) _uint16) - ((equal? type 'int32) _int32) - ((equal? type 'uint32) _uint32) - ((equal? type 'int64) _int64) - ((equal? type 'uint64) _uint64) - ((equal? type 'char) _int) - ((equal? type 'unsigned-char) _int) - ((equal? type 'short) _short) - ((equal? type 'unsigned-short) _ushort) - ((equal? type 'int) _int) - ((equal? type 'unsigned-int) _uint) - ((equal? type 'long) _long) - ((equal? type 'unsigned-long) _ulong) - ((equal? type 'float) _float) - ((equal? type 'double) _double) - ((equal? type 'pointer) _pointer) - ((equal? type 'string) _pointer) - ((equal? type 'void) _void) - ((equal? type 'callback) _pointer) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - - (define pffi-pointer? - (lambda (object) - (cpointer? object))) - - (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (get-ffi-obj c-name - shared-object - (_cprocedure (mlist->list (map pffi-type->native-type argument-types)) - (pffi-type->native-type return-type))))))) - - (define-syntax pffi-define-callback - (syntax-rules () - ((pffi-define-callback scheme-name return-type argument-types procedure) - (define scheme-name (function-ptr procedure - (_cprocedure - (mlist->list (map pffi-type->native-type argument-types)) - (pffi-type->native-type return-type))) - )))) - - (define pffi-size-of - (lambda (type) - (ctype-sizeof (pffi-type->native-type type)))) - - (define pffi-pointer-allocate - (lambda (size) - (malloc size 'raw))) - - (define pffi-pointer-null - (lambda () - #f ; In racket #f is null pointer - )) - - (define pffi-string->pointer - (lambda (string-content) - (cast string-content _string _pointer))) - - (define pffi-pointer->string - (lambda (pointer) - (cast pointer _pointer _string))) - - (define pffi-shared-object-load - (lambda (header path) - (ffi-lib path))) - - (define pffi-pointer-free - (lambda (pointer) - (free pointer))) - - (define pffi-pointer-null? - (lambda (pointer) - (not pointer) ; #f is the null pointer on racket - )) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (ptr-set! pointer (pffi-type->native-type type) offset value))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (ptr-ref pointer (pffi-type->native-type type) offset))) - - (define pffi-pointer-deref - (lambda (pointer) - pointer)))) diff --git a/schubert/retropikzel/r7rs-pffi/version/sagittarius.scm b/schubert/retropikzel/r7rs-pffi/version/sagittarius.scm deleted file mode 100644 index 11aba70..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/sagittarius.scm +++ /dev/null @@ -1,171 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version sagittarius) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (sagittarius ffi) - (sagittarius)) - (export pffi-shared-object-load - pffi-define - pffi-define-callback - pffi-size-of - pffi-pointer-allocate - pffi-pointer-null - pffi-string->pointer - pffi-pointer->string - pffi-pointer-free - pffi-pointer? - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer-get - pffi-pointer-deref) - (begin - - (define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) 'int8_t) - ((equal? type 'uint8) 'uint8_t) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32_t) - ((equal? type 'uint32) 'uint32_t) - ((equal? type 'int64) 'int64_t) - ((equal? type 'uint64) 'uint64_t) - ((equal? type 'char) 'char) - ((equal? type 'unsigned-char) 'char) - ((equal? type 'short) 'short) - ((equal? type 'unsigned-short) 'unsigned-short) - ((equal? type 'int) 'int) - ((equal? type 'unsigned-int) 'unsigned-int) - ((equal? type 'long) 'long) - ((equal? type 'unsigned-long) 'unsigned-long) - ((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))))) - - (define pffi-pointer? (lambda (object) (pointer? object))) - - (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (make-c-function shared-object - (pffi-type->native-type return-type) - c-name - (map pffi-type->native-type argument-types)))))) - - (define-syntax pffi-define-callback - (syntax-rules () - ((pffi-define-callback 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) - procedure))))) - - (define pffi-size-of - (lambda (type) - (cond ((eq? type 'int8) size-of-int8_t) - ((eq? type 'uint8) size-of-uint8_t) - ((eq? type 'int16) size-of-int16_t) - ((eq? type 'uint16) size-of-uint16_t) - ((eq? type 'int32) size-of-int32_t) - ((eq? type 'uint32) size-of-uint32_t) - ((eq? type 'int64) size-of-int64_t) - ((eq? type 'uint64) size-of-uint64_t) - ((eq? type 'char) size-of-char) - ((eq? type 'unsigned-char) size-of-char) - ((eq? type 'short) size-of-short) - ((eq? type 'unsigned-short) size-of-unsigned-short) - ((eq? type 'int) size-of-int) - ((eq? type 'unsigned-int) size-of-unsigned-int) - ((eq? type 'long) size-of-long) - ((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))))) - - (define pffi-pointer-allocate - (lambda (size) - (c-malloc size))) - - (define pffi-pointer-null - (lambda () - (integer->pointer 0))) - - (define pffi-string->pointer - (lambda (string-content) - string-content)) - - (define pffi-pointer->string - (lambda (pointer) - (if (string? pointer) - pointer - (pointer->string pointer)))) - - (define pffi-shared-object-load - (lambda (header path) - (open-shared-library path))) - - (define pffi-pointer-free - (lambda (pointer) - (c-free pointer))) - - (define pffi-pointer-null? - (lambda (pointer) - (null-pointer? pointer))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (let ((p pointer)) - (cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value)) - ((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value)) - ((equal? type 'int16) (pointer-set-c-int16_t! p offset value)) - ((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value)) - ((equal? type 'int32) (pointer-set-c-int32_t! p offset value)) - ((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value)) - ((equal? type 'int64) (pointer-set-c-int64_t! p offset value)) - ((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value)) - ((equal? type 'char) (pointer-set-c-char! p offset value)) - ((equal? type 'short) (pointer-set-c-short! p offset value)) - ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value)) - ((equal? type 'int) (pointer-set-c-int! p offset value)) - ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value)) - ((equal? type 'long) (pointer-set-c-long! p offset value)) - ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value)) - ((equal? type 'float) (pointer-set-c-float! p offset value)) - ((equal? type 'double) (pointer-set-c-double! p offset value)) - ((equal? type 'void*) (pointer-set-c-pointer p offset value)))))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (let ((p pointer) - (native-type (pffi-type->native-type type))) - (cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset)) - ((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset)) - ((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset)) - ((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset)) - ((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset)) - ((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset)) - ((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset)) - ((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset)) - ((equal? native-type 'char) (pointer-ref-c-char p offset)) - ((equal? native-type 'short) (pointer-set-c-short p offset value)) - ((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) - ((equal? native-type 'int) (pointer-ref-c-int p offset)) - ((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset)) - ((equal? native-type 'long) (pointer-ref-c-long p offset)) - ((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) - ((equal? native-type 'float) (pointer-ref-c-float p offset)) - ((equal? native-type 'double) (pointer-ref-c-double p offset)) - ((equal? native-type 'void*) (pointer-ref-c-pointer p offset)))))) - - (define pffi-pointer-deref - (lambda (pointer) - (deref pointer 0))))) diff --git a/schubert/retropikzel/r7rs-pffi/version/stklos.scm b/schubert/retropikzel/r7rs-pffi/version/stklos.scm deleted file mode 100644 index 8877f23..0000000 --- a/schubert/retropikzel/r7rs-pffi/version/stklos.scm +++ /dev/null @@ -1,105 +0,0 @@ -(define-library - (retropikzel r7rs-pffi version stklos) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (stklos)) - (export pffi-define - pffi-pointer->string - pffi-pointer-allocate - pffi-pointer-deref - pffi-pointer-free - pffi-pointer-get - pffi-pointer-null - pffi-pointer-null? - pffi-pointer-set! - pffi-pointer? - pffi-shared-object-load - pffi-size-of - pffi-string->pointer) - (begin - - (define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) :int) - ((equal? type 'uint8) :uint) - ((equal? type 'int16) :int) - ((equal? type 'uint16) :uint) - ((equal? type 'int32) :int) - ((equal? type 'uint32) :uint) - ((equal? type 'int64) :int) - ((equal? type 'uint64) :uint) - ((equal? type 'char) :char) - ((equal? type 'unsigned-char) :uchar) - ((equal? type 'short) :short) - ((equal? type 'unsigned-short) :ushort) - ((equal? type 'int) :int) - ((equal? type 'unsigned-int) :uint) - ((equal? type 'long) :long) - ((equal? type 'unsigned-long) :ulong) - ((equal? type 'float) :float) - ((equal? type 'double) :double) - ((equal? type 'pointer) :pointer) - ((equal? type 'string) :string) - ((equal? type 'void) :void) - (else (error "pffi-type->native-type -- No such pffi type" type))))) - - (define pffi-pointer? - (lambda (object) - (cpointer? object))) - - (define-syntax pffi-define - (syntax-rules () - ((pffi-define scheme-name shared-object c-name return-type argument-types) - (define scheme-name - (make-external-function - (symbol->string c-name) - (map pffi-type->native-type argument-types) - (pffi-type->native-type return-type) - shared-object))))) - - - (define pffi-size-of - (lambda (type) - (error "Not implemented"))) - - (define pffi-pointer-allocate - (lambda (size) - (allocate-bytes size))) - - (define pffi-pointer-null - (lambda () - (let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p))) - - (define pffi-string->pointer - (lambda (string-content) - string-content)) - - (define pffi-pointer->string - (lambda (pointer) - pointer)) - - (define pffi-shared-object-load - (lambda (header path) - path)) - - (define pffi-pointer-free - (lambda (pointer) - (free-bytes pointer))) - - (define pffi-pointer-null? - (lambda (pointer) - (cpointer-null? pointer))) - - (define pffi-pointer-set! - (lambda (pointer type offset value) - (error "Not implemented"))) - - (define pffi-pointer-get - (lambda (pointer type offset) - (error "Not implemented"))) - - (define pffi-pointer-deref - (lambda (pointer) - (error "Not implemented"))))) diff --git a/test-racket-wine b/test-racket-wine deleted file mode 100755 index 5775876..0000000 --- a/test-racket-wine +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash -source scripts/init-test.sh - -SCHEME="racket.exe -I r7rs --make -S . --script" - -source scripts/test-runs-dynamic.sh diff --git a/test-sagittarius-wine.sh b/test-sagittarius-wine.sh index b239ff4..34cd77c 100644 --- a/test-sagittarius-wine.sh +++ b/test-sagittarius-wine.sh @@ -2,6 +2,6 @@ source scripts/init-test.sh export WINEPATH=$(winepath ${HOME}/.wine/drive_c/Program\ Files/Sagittarius) -SCHEME="wine64 sash.exe -c -r7 -L ." +SCHEME="wine sash.exe -c -r7 -L ." source scripts/test-runs-dynamic.sh diff --git a/test.scm b/test.scm index 840d542..37091ad 100644 --- a/test.scm +++ b/test.scm @@ -1,17 +1,44 @@ (import (scheme base) (scheme write) - (scheme file) - (scheme process-context)) + (scheme load) + (scheme process-context) + (retropikzel r7rs-pffi version main)) -(define t "hello") +(define tag 'none) - -(define-syntax pffi-shared-object-load +(define-syntax assert (syntax-rules () - ((pffi-shared-object-load headers path) - (begin (display "hello") + ((_ check value) + (when (not (apply check (list value))) + (display "[") + (display tag) + (display "] ") + (display "Assert failed: ") + (write (list 'check 'value)) + (newline))))) - )) - ) - ) +(set! tag 'size-of) +(assert number? (pffi-size-of 'int8)) +(assert number? (pffi-size-of 'uint8)) +(assert number? (pffi-size-of 'int16)) +(assert number? (pffi-size-of 'uint16)) +(assert number? (pffi-size-of 'int32)) +(assert number? (pffi-size-of 'uint32)) +(assert number? (pffi-size-of 'int64)) +(assert number? (pffi-size-of 'uint64)) +(assert number? (pffi-size-of 'char)) +(assert number? (pffi-size-of 'unsigned-char)) +(assert number? (pffi-size-of 'short)) +(assert number? (pffi-size-of 'unsigned-short)) +(assert number? (pffi-size-of 'int)) +(assert number? (pffi-size-of 'unsigned-int)) +(assert number? (pffi-size-of 'long)) +(assert number? (pffi-size-of 'unsigned-long)) +(assert number? (pffi-size-of 'float)) +(assert number? (pffi-size-of 'double)) +(assert number? (pffi-size-of 'string)) +(assert string? (pffi-size-of 'pointer)) + + +(exit 0)