Clean up the repository
This commit is contained in:
parent
3146a6933f
commit
c4bdcee446
|
|
@ -31,4 +31,6 @@ dockerfiles/build
|
|||
.scheme_testrunner
|
||||
retropikzel/pffi/version/main.sld
|
||||
retropikzel/pffi/version/main.rkt
|
||||
*.sld
|
||||
*.rkt
|
||||
site
|
||||
|
|
|
|||
83
Makefile
83
Makefile
|
|
@ -1,4 +1,6 @@
|
|||
build:
|
||||
TEST_PACKAGES_APT=libcurl4 libcurl4-openssl-dev
|
||||
|
||||
build: retropikzel/r7rs-pffi/version/*.scm
|
||||
cp retropikzel/r7rs-pffi/version/main.scm retropikzel/r7rs-pffi/version/main.sld
|
||||
echo "#lang r7rs" > retropikzel/r7rs-pffi/version/main.rkt
|
||||
cat retropikzel/r7rs-pffi/version/main.scm >> retropikzel/r7rs-pffi/version/main.rkt
|
||||
|
|
@ -6,36 +8,58 @@ build:
|
|||
install:
|
||||
schubert install
|
||||
|
||||
test-arm64:
|
||||
#scheme_testrunner alpine:3.20 arm64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner alpine:3.20 arm64 sagittarius "bash test-sagittarius.sh"
|
||||
scheme_testrunner alpine:3.20 arm64 chicken "bash test-chicken.sh"
|
||||
#
|
||||
#scheme_testrunner debian:trixie arm64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner debian:trixie arm64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
#scheme_testrunner fedora:40 arm64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner fedora:40 arm64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
#scheme_testrunner opensuse/tumbleweed arm64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner opensuse/tumbleweed arm64 sagittarius "bash test-sagittarius.sh"
|
||||
test-all: \
|
||||
test-chicken\
|
||||
test-cyclone \
|
||||
test-gambit \
|
||||
test-gerbil \
|
||||
test-guile \
|
||||
test-kawa \
|
||||
test-sagittarius \
|
||||
test-racket \
|
||||
test-stklos
|
||||
|
||||
test-amd64:
|
||||
#scheme_testrunner alpine:3.20 amd64 guile "bash test-guile.sh"
|
||||
scheme_testrunner alpine:3.20 amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
#scheme_testrunner debian:trixie amd64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner debian:trixie amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
#scheme_testrunner fedora:40 amd64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner fedora:40 amd64 sagittarius "bash test-sagittarius.sh"
|
||||
#
|
||||
#scheme_testrunner opensuse/tumbleweed amd64 guile "bash test-guile.sh"
|
||||
#scheme_testrunner opensuse/tumbleweed amd64 sagittarius "bash test-sagittarius.sh"
|
||||
test-chicken: build
|
||||
PACKAGES="${TEST_PACKAGES_APT}" \
|
||||
scheme_runner chicken "bash test-chicken.sh"
|
||||
|
||||
test-amd64-wine:
|
||||
scheme_testrunner alpine:3.20 amd64 sagittarius_wine "bash test-sagittarius-wine.sh"
|
||||
scheme_testrunner alpine:3.20 amd64 racket_wine "bash test-racket-wine.sh"
|
||||
test-cyclone: build
|
||||
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"
|
||||
|
||||
test-gerbil: build
|
||||
PACKAGES="${TEST_PACKAGES_APT}" \
|
||||
scheme_runner gerbil "bash test-gerbil.sh"
|
||||
|
||||
test-guile: build
|
||||
PACKAGES="${TEST_PACKAGES_APT}" \
|
||||
scheme_runner guile "bash test-guile.sh"
|
||||
|
||||
test-kawa: build
|
||||
PACKAGES="${TEST_PACKAGES_APT}" \
|
||||
scheme_runner kawa "bash test-kawa.sh"
|
||||
|
||||
test-sagittarius: build
|
||||
PACKAGES="${TEST_PACKAGES_APT}" \
|
||||
scheme_runner sagittarius "bash test-sagittarius.sh"
|
||||
|
||||
test-racket: build
|
||||
PACKAGES="${TEST_PACKAGES_APT}" \
|
||||
scheme_runner racket "bash test-racket.sh"
|
||||
|
||||
test-stklos: build
|
||||
PACKAGES="${TEST_PACKAGES_APT}" \
|
||||
scheme_runner stklos "bash test-stklos.sh"
|
||||
|
||||
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
|
||||
|
|
@ -61,4 +85,3 @@ clean:
|
|||
rm -rf *.so
|
||||
rm -rf *.a
|
||||
find ./test -type f -not -name "*.scm" -exec bash -c "test -x {} && rm {}" \;
|
||||
rm -rf dockerfiles/build
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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")))))
|
||||
|
|
@ -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")))))
|
||||
|
|
@ -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")))))
|
||||
|
|
@ -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
build/guile.scm
154
build/guile.scm
|
|
@ -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
build/kawa.scm
132
build/kawa.scm
|
|
@ -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)))
|
||||
233
build/main.scm
233
build/main.scm
|
|
@ -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
build/racket.scm
118
build/racket.scm
|
|
@ -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))))
|
||||
|
|
@ -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
build/stklos.scm
105
build/stklos.scm
|
|
@ -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")))))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
|
||||
echo "# PFFI"
|
||||
echo ""
|
||||
echo "## Procedures"
|
||||
echo ""
|
||||
cat retropikzel/pffi/${VERSION}/schubert-doc.md
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
FROM alpine:3.20
|
||||
RUN apk add guile chicken racket gcc make cmake gc libffi zlib openssl wget bash curl
|
||||
#RUN wget https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.11.tar.gz && tar -xf sagittarius-0.9.11.tar.gz && cd sagittarius-0.9.11 && cmake . && make && make install
|
||||
WORKDIR /workdir
|
||||
ENTRYPOINT ["bash", "/workdir/test-guile.sh"]
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
FROM debian:bookworm
|
||||
RUN apt-get update && apt-get install -y build-essential bash git wget make cmake libgc-dev zlib1g-dev libffi-dev libssl-dev guile-3.0 chicken-bin racket
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
FROM fedora:40
|
||||
RUN dnf group install "Development Tools" -y && dnf install -y openssl-devel guile30 chicken racket-minimal
|
||||
RUN ln -s /usr/bin/guile3.0 /usr/bin/guile
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
RUN mkdir -p /workdir
|
||||
#RUN wget https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.11.tar.gz && tar -xf sagittarius-0.9.11.tar.gz && cd sagittarius-0.9.11 && cmake . && make && make install
|
||||
WORKDIR /workdir
|
||||
ENTRYPOINT ["bash", "test-guile.sh"]
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
FROM alpine:3.20
|
||||
ENV WINEDEBUG=-all
|
||||
RUN apk add wine innoextract 7zip
|
||||
ADD https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/setup_sagittarius_0.9.11_x64.exe /
|
||||
ADD https://download.racket-lang.org/installers/8.13/racket-8.13-x86_64-win32-cs.exe /
|
||||
RUN wine hostname
|
||||
RUN innoextract setup_sagittarius_0.9.11_x64.exe
|
||||
RUN 7z racket-8.13-x86_64-win32-cs.exe -y
|
||||
WORKDIR /workdir
|
||||
RUN apk add bash make
|
||||
ENTRYPOINT ["bash", "/workdir/test-sagittarius-container-wine.sh"]
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
# PFFI
|
||||
|
||||
## Procedures
|
||||
|
||||
# pffi
|
||||
|
||||
|
||||
## Procedures
|
||||
|
||||
|
||||
### pffi-call
|
||||
|
||||
Arguments:
|
||||
|
||||
- shared-object (object)
|
||||
- Shared object returned by pffi-shared-object-load or pffi-shared-object-auto-load
|
||||
- name (symbol)
|
||||
- Name of the C function you want to call
|
||||
- type (symbol)
|
||||
- Return type of the C function you want to call
|
||||
- arguments (list (cons type value)...)
|
||||
- Arguments you want to pass to the C function as pairs of type and value
|
||||
|
||||
Example:
|
||||
|
||||
(define sdl2* (pffi-shared-object-auto-load "SDL2" (list))
|
||||
|
||||
(pffi-call sdl2* 'SDL_Init 'int '((int . 32)))
|
||||
|
||||
(define window* (pffi-call sdl2*
|
||||
'SDL_CreateWindow
|
||||
'pointer
|
||||
(list (cons 'pointer (pffi-string->pointer "Hello"))
|
||||
(cons 'int 1)
|
||||
(cons 'int 1)
|
||||
(cons 'int 400)
|
||||
(cons 'int 400)
|
||||
(cons 'int 4))
|
||||
|
||||
|
||||
### pffi-shared-object-load
|
||||
|
||||
Arguments:
|
||||
- path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
|
||||
|
||||
Returns:
|
||||
|
||||
|
||||
|
||||
### pffi-shared-object-auto-load
|
||||
|
||||
Arguments:
|
||||
- object-name (symbol)
|
||||
- The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
|
||||
- addition-paths (list (string)...)
|
||||
- Any additional paths you want to search for the library
|
||||
|
||||
Returns:
|
||||
- (object) Shared object, the type depends on the implementation
|
||||
|
||||
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#!/usr/bin/env bash
|
||||
|
||||
export CHICKEN_INSTALL_REPOSITORY=${HOME}/eggs/lib/chicken/5
|
||||
export CHICKEN_REPOSITORY_PATH=${CHICKEN_REPOSITORY_PATH}:${HOME}/.local/share/eggs/lib/chicken/5
|
||||
|
||||
#chicken-install -init ${HOME}/eggs/lib/chicken/5
|
||||
chicken-install r7rs
|
||||
Binary file not shown.
|
|
@ -1,3 +1,246 @@
|
|||
#lang r7rs
|
||||
(import (scheme base))
|
||||
(include "main.scm")
|
||||
(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)
|
||||
(ffi winapi)
|
||||
(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-init
|
||||
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
|
||||
pffi-os-name)
|
||||
(begin
|
||||
|
||||
(define-syntax pffi-init
|
||||
(syntax-rules ()
|
||||
((pffi-init)
|
||||
(cond-expand
|
||||
(chicken (import (chicken foreign)))
|
||||
(else #t)))))
|
||||
|
||||
|
||||
(define pffi-os-name
|
||||
(cond-expand
|
||||
(windows "windows")
|
||||
(racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
|
||||
(else "unix")))
|
||||
|
||||
(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
|
||||
(if (string=? pffi-os-name "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))
|
||||
(if (get-environment-variable "PWD")
|
||||
(list (get-environment-variable "PWD"))
|
||||
(list)))
|
||||
(append
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
(scheme file)
|
||||
(scheme process-context)
|
||||
(only (racket base) system-type)
|
||||
(ffi winapi)
|
||||
(retropikzel r7rs-pffi version racket)))
|
||||
(stklos
|
||||
(import (scheme base)
|
||||
|
|
@ -62,7 +63,8 @@
|
|||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel r7rs-pffi version mit-scheme))))
|
||||
(export pffi-shared-object-auto-load
|
||||
(export pffi-init
|
||||
pffi-shared-object-auto-load
|
||||
pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
|
|
@ -76,13 +78,23 @@
|
|||
pffi-pointer-null?
|
||||
pffi-pointer-set!
|
||||
pffi-pointer-get
|
||||
pffi-pointer-deref)
|
||||
pffi-pointer-deref
|
||||
pffi-os-name)
|
||||
(begin
|
||||
|
||||
|
||||
#|doc Testing multiline comment |#
|
||||
(define-syntax pffi-init
|
||||
(syntax-rules ()
|
||||
((pffi-init)
|
||||
(cond-expand
|
||||
(chicken (import (chicken foreign)))
|
||||
(else #t)))))
|
||||
|
||||
|
||||
(define pffi-os-name
|
||||
(cond-expand
|
||||
(windows "windows")
|
||||
(racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
|
||||
(else "unix")))
|
||||
|
||||
(define library-version "v0-3-0")
|
||||
(define slash (cond-expand (windows (string #\\)) (else "/")))
|
||||
|
|
@ -140,58 +152,58 @@
|
|||
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"
|
||||
))))))
|
||||
(if (string=? pffi-os-name "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))
|
||||
(if (get-environment-variable "PWD")
|
||||
(list (get-environment-variable "PWD"))
|
||||
(list)))
|
||||
(append
|
||||
; Guix
|
||||
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
|
||||
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
|
||||
"")
|
||||
"/run/current-system/profile/lib")
|
||||
; Debian
|
||||
(if (get-environment-variable "LD_LIBRARY_PATH")
|
||||
(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 ""))
|
||||
|
||||
|
|
|
|||
|
|
@ -7,8 +7,8 @@ SCHEME_LIB="gsc -v -:r7rs,search=. -obj"
|
|||
SCHEME_I="gsi -:r7rs,search=."
|
||||
|
||||
|
||||
${SCHEME_LIB} retropikzel/pffi/${VERSION}/gambit.scm
|
||||
${SCHEME_LIB} retropikzel/pffi/${VERSION}/main.sld
|
||||
${SCHEME_LIB} retropikzel/pffi/version/gambit.scm
|
||||
${SCHEME_LIB} retropikzel/pffi/version/main.sld
|
||||
|
||||
|
||||
source scripts/test-runs-compilers.sh
|
||||
Loading…
Reference in New Issue