Moving towards snow package format
This commit is contained in:
parent
feeb8371d3
commit
19ba0c42f5
60
Makefile
60
Makefile
|
|
@ -1,15 +1,7 @@
|
|||
TEST_PACKAGES_APT="libcurl4-openssl-dev libuv1"
|
||||
DOCKER_INIT=apt update && apt install libcurl4-openssl-dev libuv1 && cd /workdir
|
||||
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
|
||||
echo "#lang r7rs" > retropikzel/r7rs-pffi/version/main.rkt
|
||||
cat retropikzel/r7rs-pffi/version/main.scm >> retropikzel/r7rs-pffi/version/main.rkt
|
||||
|
||||
install:
|
||||
schubert install
|
||||
|
||||
test-tier1: \
|
||||
test-chicken\
|
||||
|
|
@ -22,60 +14,56 @@ test-tier2: \
|
|||
test-cyclone \
|
||||
test-gambit \
|
||||
test-stklos
|
||||
|
||||
|
||||
CHICKEN_LIB=csc -X r7rs -R r7rs -s -J
|
||||
build-chicken-libs:
|
||||
cp retropikzel/r7rs-pffi/version/chicken.scm retropikzel.r7rs-pffi.version.chicken.scm
|
||||
${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"
|
||||
cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld
|
||||
${SCHEME_RUNNER} chicken "${CHICKEN_LIB} retropikzel.r7rs-pffi.sld"
|
||||
|
||||
CHICKEN=csc -X r7rs -R r7rs -L -lcurl
|
||||
test-chicken: clean build build-chicken-libs
|
||||
test-chicken: clean 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.sld"
|
||||
${SCHEME_RUNNER} cyclone "${CYCLONE} retropikzel/r7rs-pffi/version/main.sld"
|
||||
${SCHEME_RUNNER} cyclone "${CYCLONE} retropikzel/r7rs-pffi.sld"
|
||||
|
||||
CYCLONE=cyclone -A . -A ./schubert
|
||||
test-cyclone: clean build build-cyclone-libs
|
||||
test-cyclone: clean build-cyclone-libs
|
||||
${SCHEME_RUNNER} cyclone "${CYCLONE} test.scm && icyc -s test.scm"
|
||||
|
||||
GAMBIT_LIB=gsc -:r7rs -dynamic
|
||||
build-gambit-libs:
|
||||
${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi/version/gambit.scm"
|
||||
${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi/version/main.scm"
|
||||
${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi/gambit.scm"
|
||||
${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi.sld"
|
||||
|
||||
GAMBIT=gsc -:r7rs,search=.:./schubert -ld-options -lcurl -exe
|
||||
test-gambit: clean build
|
||||
#${SCHEME_RUNNER} gambit "${GAMBIT} test.scm && ./test"
|
||||
${GAMBIT} test.scm && ./test
|
||||
test-gambit: clean build-gambit-libs
|
||||
${SCHEME_RUNNER} gambit "${GAMBIT} test.scm && ./test"
|
||||
#${GAMBIT} test.scm && ./test
|
||||
|
||||
GUILE=guile -L . -L ./schubert
|
||||
test-guile: build
|
||||
GUILE=guile --r7rs -L . -L ./schubert
|
||||
test-guile:
|
||||
#${SCHEME_RUNNER} guile "${GUILE} test.scm"
|
||||
${GUILE} test.scm
|
||||
|
||||
KAWA=java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar kawa.jar --r7rs --full-tailcalls -Dkawa.import.path=.:./schubert
|
||||
test-kawa: build
|
||||
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=.:*.sld
|
||||
test-kawa:
|
||||
#${SCHEME_RUNNER} kawa "${KAWA} test.scm"
|
||||
${KAWA} test.scm
|
||||
|
||||
SASH=sash -L . -L ./schubert
|
||||
test-sagittarius: build
|
||||
test-sagittarius:
|
||||
${SCHEME_RUNNER} sagittarius "${SASH} test.scm"
|
||||
|
||||
RACKET=racket -I r7rs -S . -S ./schubert --script
|
||||
test-racket: build
|
||||
test-racket:
|
||||
${SCHEME_RUNNER} racket "${RACKET} test.scm"
|
||||
#${RACKET} test.scm
|
||||
|
||||
STKLOS=stklos -A . -A ./schubert -f
|
||||
test-stklos: build
|
||||
test-stklos:
|
||||
${SCHEME_RUNNER} stklos "${STKLOS} test.scm"
|
||||
|
||||
documentation:
|
||||
|
|
@ -88,12 +76,12 @@ tmp:
|
|||
|
||||
clean:
|
||||
@rm -rf docutmp
|
||||
@rm -rf retropikzel/r7rs-pffi/version/*.c
|
||||
@rm -rf retropikzel/r7rs-pffi/version/*.o*
|
||||
@rm -rf retropikzel/r7rs-pffi/version/*.so
|
||||
@rm -rf retropikzel/r7rs-pffi/version/*.meta
|
||||
@rm -rf retropikzel/r7rs-pffi/version/retropikzel.*
|
||||
@rm -rf retropikzel/r7rs-pffi/version/compiled
|
||||
@rm -rf retropikzel/r7rs-pffi/*.c
|
||||
@rm -rf retropikzel/r7rs-pffi/*.o*
|
||||
@rm -rf retropikzel/r7rs-pffi/*.so
|
||||
@rm -rf retropikzel/r7rs-pffi/*.meta
|
||||
@rm -rf retropikzel/r7rs-pffi/retropikzel.*
|
||||
@rm -rf retropikzel/r7rs-pffi/compiled
|
||||
@rm -rf retropikzel.*
|
||||
@rm -rf test/*.c
|
||||
@rm -rf test/*.o*
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ that each implementation passes those tests. This will be done in tiered order s
|
|||
- [Sagittarius](https://bitbucket.org/ktakashi/sagittarius-scheme/wiki/Home)
|
||||
- [Racket](https://racket-lang.org/)
|
||||
|
||||
## Tier 2
|
||||
## Tier 2 - Work in progress
|
||||
|
||||
- [Gambit](https://gambitscheme.org)
|
||||
- Propably able to support everything but so annoying to deal with that it's currently in tier 2
|
||||
|
|
|
|||
|
|
@ -0,0 +1,264 @@
|
|||
(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 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(or (string? 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 '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 '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 pffi-size-of
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (foreign-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (foreign-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (foreign-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (foreign-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (foreign-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (foreign-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (foreign-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (foreign-value "sizeof(float)" int))
|
||||
((equal? type 'double) (foreign-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
|
||||
(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)))
|
||||
|
||||
(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
(pffi-define puts #f 'puts 'int (list 'pointer))
|
||||
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let* ((size (string-length string-content))
|
||||
(pointer (pffi-pointer-allocate (+ size 1))))
|
||||
(memset pointer 0 size)
|
||||
(display "STRING-LENGTH: ")
|
||||
(display size)
|
||||
(display " / ")
|
||||
(display pointer)
|
||||
(display " === ")
|
||||
(strncpy-ps pointer (location string-content) size)
|
||||
;(move-memory! string-content pointer size 0)
|
||||
;(pffi-pointer-set! pointer 'char size #\null)
|
||||
(puts pointer)
|
||||
(display " ::: ")
|
||||
(write string-content)
|
||||
(display " OTHER: ")
|
||||
(display (strlen pointer))
|
||||
(newline)
|
||||
;(pointer-s8-set! pointer size (foreign-value "\0" char))
|
||||
pointer)))
|
||||
|
||||
(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(cond ((pffi-pointer? pointer)
|
||||
(let* ((size (strlen pointer))
|
||||
(string-content (make-string size)))
|
||||
(display "STRLEN: ")
|
||||
(display size)
|
||||
(display " / ")
|
||||
(display pointer)
|
||||
;(move-memory! pointer string-content size)
|
||||
(strncpy-pp (location string-content) pointer size)
|
||||
(display " ::: ")
|
||||
(write string-content)
|
||||
(display " === ")
|
||||
(puts pointer)
|
||||
(newline)
|
||||
string-content))
|
||||
(error "pffi-pointer->string -- Argument not pointer " pointer))))
|
||||
|
||||
(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)
|
||||
(if (not (pointer? pointer))
|
||||
(error "pffi-pointer-free -- Argument is not pointer" pointer))
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(if (not (pointer? pointer))
|
||||
#f
|
||||
(= (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-f32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address 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-f32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
|
||||
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
pointer))
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
(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 '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 '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)
|
||||
(cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (c-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (c-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (c-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (c-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (c-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (c-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (c-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (c-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (c-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (c-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (c-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (c-value "sizeof(float)" int))
|
||||
((equal? type 'double) (c-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (c-value "sizeof(void*)" int))
|
||||
(else (error "pffi-size-of -- No such pffi type" type)))))
|
||||
|
||||
(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")))
|
||||
|
||||
(define pffi-define-callback
|
||||
(lambda (scheme-name return-type argument-types procedure)
|
||||
(error "pffi-define-callback not yet implemented on Cyclone")))
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
(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")))
|
||||
|
|
@ -0,0 +1,128 @@
|
|||
(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) int8)
|
||||
((equal? type 'unsigned-char) uint8)
|
||||
((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 '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-callback 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))
|
||||
((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-ieee-single-set! p offset value (native-endianness)))
|
||||
((equal? native-type double) (bytevector-ieee-double-set! p offset value (native-endianness)))
|
||||
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type)))
|
||||
((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer 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-ieee-single-ref p offset (native-endianness)))
|
||||
((equal? native-type double) (bytevector-ieee-double-ref p offset (native-endianness)))
|
||||
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))))
|
||||
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(dereference-pointer pointer)))
|
||||
|
|
@ -0,0 +1,156 @@
|
|||
(define pffi-os-name
|
||||
(cond-expand
|
||||
(windows "windows")
|
||||
(racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
|
||||
(else "unix")))
|
||||
|
||||
(define-syntax pffi-init
|
||||
(syntax-rules ()
|
||||
((pffi-init)
|
||||
(cond-expand
|
||||
(chicken (import (chicken foreign)))
|
||||
(else #t)))))
|
||||
|
||||
(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))))))))
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
(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 '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 ()
|
||||
((_ 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 '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)
|
||||
(write string-content)
|
||||
(newline)
|
||||
(bytevector->pointer (string->utf8 string-content))))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(when (pointer? pointer)
|
||||
(c-free pointer))))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(null-pointer? pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset value))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void*) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||
((equal? type 'char) (pointer-ref-c-char pointer offset))
|
||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(deref pointer 0)))
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
(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-define-callback
|
||||
(lambda ()
|
||||
(error "STklos does not support callbacks")))
|
||||
|
||||
(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,291 +0,0 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version chicken)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(chicken foreign)
|
||||
(chicken locative)
|
||||
(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 'void) 'void)
|
||||
((equal? type 'callback) 'c-pointer)
|
||||
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
|
||||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(or (string? 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 '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 '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 pffi-size-of
|
||||
(lambda (type)
|
||||
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (foreign-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (foreign-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (foreign-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (foreign-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (foreign-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (foreign-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (foreign-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (foreign-value "sizeof(float)" int))
|
||||
((equal? type 'double) (foreign-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
|
||||
(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)))
|
||||
|
||||
(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
(pffi-define puts #f 'puts 'int (list 'pointer))
|
||||
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let* ((size (string-length string-content))
|
||||
(pointer (pffi-pointer-allocate (+ size 1))))
|
||||
(memset pointer 0 size)
|
||||
(display "STRING-LENGTH: ")
|
||||
(display size)
|
||||
(display " / ")
|
||||
(display pointer)
|
||||
(display " === ")
|
||||
(strncpy-ps pointer (location string-content) size)
|
||||
;(move-memory! string-content pointer size 0)
|
||||
;(pffi-pointer-set! pointer 'char size #\null)
|
||||
(puts pointer)
|
||||
(display " ::: ")
|
||||
(write string-content)
|
||||
(display " OTHER: ")
|
||||
(display (strlen pointer))
|
||||
(newline)
|
||||
;(pointer-s8-set! pointer size (foreign-value "\0" char))
|
||||
pointer)))
|
||||
|
||||
(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(cond ((pffi-pointer? pointer)
|
||||
(let* ((size (strlen pointer))
|
||||
(string-content (make-string size)))
|
||||
(display "STRLEN: ")
|
||||
(display size)
|
||||
(display " / ")
|
||||
(display pointer)
|
||||
;(move-memory! pointer string-content size)
|
||||
(strncpy-pp (location string-content) pointer size)
|
||||
(display " ::: ")
|
||||
(write string-content)
|
||||
(display " === ")
|
||||
(puts pointer)
|
||||
(newline)
|
||||
string-content))
|
||||
(error "pffi-pointer->string -- Argument not pointer " pointer))))
|
||||
|
||||
(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)
|
||||
(if (not (pointer? pointer))
|
||||
(error "pffi-pointer-free -- Argument is not pointer" pointer))
|
||||
(free pointer)))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(if (not (pointer? pointer))
|
||||
#f
|
||||
(= (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-f32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address 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-f32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
|
||||
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
pointer))))
|
||||
|
|
@ -1,167 +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
|
||||
pffi-define-callback)
|
||||
(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 '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 '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)
|
||||
(cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
|
||||
((equal? type 'uint8) (c-value "sizeof(uint8_t)" int))
|
||||
((equal? type 'int16) (c-value "sizeof(int16_t)" int))
|
||||
((equal? type 'uint16) (c-value "sizeof(uint16_t)" int))
|
||||
((equal? type 'int32) (c-value "sizeof(int32_t)" int))
|
||||
((equal? type 'uint32) (c-value "sizeof(uint32_t)" int))
|
||||
((equal? type 'int64) (c-value "sizeof(int64_t)" int))
|
||||
((equal? type 'uint64) (c-value "sizeof(uint64_t)" int))
|
||||
((equal? type 'char) (c-value "sizeof(char)" int))
|
||||
((equal? type 'unsigned-char) (c-value "sizeof(unsigned char)" int))
|
||||
((equal? type 'short) (c-value "sizeof(short)" int))
|
||||
((equal? type 'unsigned-short) (c-value "sizeof(unsigned short)" int))
|
||||
((equal? type 'int) (c-value "sizeof(int)" int))
|
||||
((equal? type 'unsigned-int) (c-value "sizeof(unsigned int)" int))
|
||||
((equal? type 'long) (c-value "sizeof(long)" int))
|
||||
((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int))
|
||||
((equal? type 'float) (c-value "sizeof(float)" int))
|
||||
((equal? type 'double) (c-value "sizeof(double)" int))
|
||||
((equal? type 'pointer) (c-value "sizeof(void*)" int))
|
||||
(else (error "pffi-size-of -- No such pffi type" type)))))
|
||||
|
||||
(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")))
|
||||
|
||||
(define pffi-define-callback
|
||||
(lambda (scheme-name return-type argument-types procedure)
|
||||
(error "pffi-define-callback not yet implemented on Cyclone")))))
|
||||
|
|
@ -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,153 +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) int8)
|
||||
((equal? type 'unsigned-char) uint8)
|
||||
((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 '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-callback 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))
|
||||
((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-ieee-single-set! p offset value (native-endianness)))
|
||||
((equal? native-type double) (bytevector-ieee-double-set! p offset value (native-endianness)))
|
||||
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type)))
|
||||
((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer 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-ieee-single-ref p offset (native-endianness)))
|
||||
((equal? native-type double) (bytevector-ieee-double-ref p offset (native-endianness)))
|
||||
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))))
|
||||
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(dereference-pointer pointer)))))
|
||||
|
|
@ -1,246 +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)
|
||||
(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)))
|
||||
(else (error "Unsupported version")))
|
||||
(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 pffi-os-name
|
||||
(cond-expand
|
||||
(windows "windows")
|
||||
(racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
|
||||
(else "unix")))
|
||||
|
||||
(define-syntax pffi-init
|
||||
(syntax-rules ()
|
||||
((pffi-init)
|
||||
(cond-expand
|
||||
(chicken (import (chicken foreign)))
|
||||
(else #t)))))
|
||||
|
||||
(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))))
|
||||
|
|
@ -1,245 +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)
|
||||
(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)))
|
||||
(else (error "Unsupported version")))
|
||||
(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 pffi-os-name
|
||||
(cond-expand
|
||||
(windows "windows")
|
||||
(racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
|
||||
(else "unix")))
|
||||
|
||||
(define-syntax pffi-init
|
||||
(syntax-rules ()
|
||||
((pffi-init)
|
||||
(cond-expand
|
||||
(chicken (import (chicken foreign)))
|
||||
(else #t)))))
|
||||
|
||||
(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))))
|
||||
|
|
@ -1,245 +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)
|
||||
(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)))
|
||||
(else (error "Unsupported version")))
|
||||
(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 pffi-os-name
|
||||
(cond-expand
|
||||
(windows "windows")
|
||||
(racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
|
||||
(else "unix")))
|
||||
|
||||
(define-syntax pffi-init
|
||||
(syntax-rules ()
|
||||
((pffi-init)
|
||||
(cond-expand
|
||||
(chicken (import (chicken foreign)))
|
||||
(else #t)))))
|
||||
|
||||
(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))))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang r7rs
|
||||
(import (scheme base))
|
||||
(include "racket.scm")
|
||||
|
|
@ -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 '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 ()
|
||||
((_ 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 '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)
|
||||
(write string-content)
|
||||
(newline)
|
||||
(bytevector->pointer (string->utf8 string-content))))
|
||||
|
||||
(define pffi-pointer->string
|
||||
(lambda (pointer)
|
||||
(pointer->string pointer)))
|
||||
|
||||
(define pffi-shared-object-load
|
||||
(lambda (header path)
|
||||
(open-shared-library path)))
|
||||
|
||||
(define pffi-pointer-free
|
||||
(lambda (pointer)
|
||||
(when (pointer? pointer)
|
||||
(c-free pointer))))
|
||||
|
||||
(define pffi-pointer-null?
|
||||
(lambda (pointer)
|
||||
(null-pointer? pointer)))
|
||||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
|
||||
((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
|
||||
((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
|
||||
((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
|
||||
((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
|
||||
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
|
||||
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
|
||||
((equal? type 'char) (pointer-set-c-char! pointer offset value))
|
||||
((equal? type 'short) (pointer-set-c-short! pointer offset value))
|
||||
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||
((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
|
||||
((equal? type 'long) (pointer-set-c-long! pointer offset value))
|
||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
|
||||
((equal? type 'float) (pointer-set-c-float! pointer offset value))
|
||||
((equal? type 'double) (pointer-set-c-double! pointer offset value))
|
||||
((equal? type 'void*) (pointer-set-c-pointer! pointer offset value))
|
||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
|
||||
((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
|
||||
((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
|
||||
((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
|
||||
((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
|
||||
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
|
||||
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||
((equal? type 'char) (pointer-ref-c-char pointer offset))
|
||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
|
||||
((equal? type 'int) (pointer-ref-c-int pointer offset))
|
||||
((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
|
||||
((equal? type 'long) (pointer-ref-c-long pointer offset))
|
||||
((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
|
||||
((equal? type 'float) (pointer-ref-c-float pointer offset))
|
||||
((equal? type 'double) (pointer-ref-c-double pointer offset))
|
||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
(lambda (pointer)
|
||||
(deref pointer 0)))))
|
||||
|
|
@ -1,110 +0,0 @@
|
|||
(define-library
|
||||
(retropikzel r7rs-pffi version stklos)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(stklos))
|
||||
(export pffi-shared-object-load
|
||||
pffi-define
|
||||
pffi-define-callback
|
||||
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-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-define-callback
|
||||
(lambda ()
|
||||
(error "STklos does not support callbacks")))
|
||||
|
||||
(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")))))
|
||||
|
|
@ -25,5 +25,10 @@ else
|
|||
-f ${DOCKERFILE} \
|
||||
--tag ${tag}:latest \
|
||||
.
|
||||
docker run -it -v ${PWD}:/workdir:z ${tag}:latest ${cmd}
|
||||
docker run \
|
||||
-it \
|
||||
-e CHICKEN_INCLUDE_PATH=/workdir/retropikzel \
|
||||
-v ${PWD}:/workdir:z \
|
||||
${tag}:latest \
|
||||
${cmd}
|
||||
fi
|
||||
|
|
|
|||
Loading…
Reference in New Issue