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

Move to running tests with scheme_runner

This commit is contained in:
retropikzel 2024-09-03 15:15:15 +03:00
parent c4bdcee446
commit be49da18d2
35 changed files with 104 additions and 2074 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -34,3 +34,5 @@ retropikzel/pffi/version/main.rkt
*.sld
*.rkt
site
test
schubert

84
Makefile
View File

@ -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

4
composition.scm
View File

@ -4,4 +4,6 @@
(type . "library")
(description . "Portable Foreign Function Interface for R7RS schemes")
(license . "LGPL")
(dependencies ()))
(dependencies ())
(development-dependencies ())
)

BIN
old-tests/100_hello Executable file
View File

Binary file not shown.

0
test/100_hello.scm → old-tests/100_hello.scm
View File

BIN
old-tests/200_import Executable file
View File

Binary file not shown.

0
test/200_import.scm → old-tests/200_import.scm
View File

BIN
old-tests/300_size-of Executable file
View File

Binary file not shown.

0
test/300_size-of.scm → old-tests/300_size-of.scm
View File

0
test/400_pointer-allocate-free.scm → old-tests/400_pointer-allocate-free.scm
View File

0
test/401_is-pointer.scm → old-tests/401_is-pointer.scm
View File

0
test/402_null-pointer.scm → old-tests/402_null-pointer.scm
View File

0
test/410_pointer-set-get.scm → old-tests/410_pointer-set-get.scm
View File

0
test/500_string-to-pointer-to-string.scm → old-tests/500_string-to-pointer-to-string.scm
View File

0
test/600_libc.scm → old-tests/600_libc.scm
View File

0
test/700_pffi-define.scm → old-tests/700_pffi-define.scm
View File

0
test/800_libcurl.scm → old-tests/800_libcurl.scm
View File

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

@ -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)

BIN
schubert/retropikzel/r7rs-pffi/version/chicken
View File

Binary file not shown.

259
schubert/retropikzel/r7rs-pffi/version/chicken.scm
View File

@ -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))))

145
schubert/retropikzel/r7rs-pffi/version/cyclone.scm
View File

@ -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")))))

79
schubert/retropikzel/r7rs-pffi/version/empty.scm
View File

@ -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")))))

77
schubert/retropikzel/r7rs-pffi/version/gambit.scm
View File

@ -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")))))

79
schubert/retropikzel/r7rs-pffi/version/gerbil.scm
View File

@ -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")))))

154
schubert/retropikzel/r7rs-pffi/version/guile.scm
View File

@ -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)))))

132
schubert/retropikzel/r7rs-pffi/version/kawa.scm
View File

@ -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)))

234
schubert/retropikzel/r7rs-pffi/version/main.rkt
View File

@ -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))))

233
schubert/retropikzel/r7rs-pffi/version/main.scm
View File

@ -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))))

233
schubert/retropikzel/r7rs-pffi/version/main.sld
View File

@ -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))))

118
schubert/retropikzel/r7rs-pffi/version/racket.scm
View File

@ -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))))

171
schubert/retropikzel/r7rs-pffi/version/sagittarius.scm
View File

@ -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)))))

105
schubert/retropikzel/r7rs-pffi/version/stklos.scm
View File

@ -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")))))

6
test-racket-wine
View File

@ -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

2
test-sagittarius-wine.sh
View File

@ -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

47
test.scm
View File

@ -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)