Lots of fixes
This commit is contained in:
parent
407bf14590
commit
1b285c7204
34
Dockerfile
34
Dockerfile
|
|
@ -1,34 +1,8 @@
|
||||||
ARG IMPLEMENTATION
|
ARG IMPLEMENTATION
|
||||||
FROM schemers/$IMPLEMENTATION
|
FROM schemers/$IMPLEMENTATION
|
||||||
ARG IMPLEMENTATION
|
ARG IMPLEMENTATION
|
||||||
RUN echo "deb http://ftp.fi.debian.org/debian/ bookworm main" > /etc/apt/sources.list
|
|
||||||
WORKDIR /workdir
|
WORKDIR /workdir
|
||||||
RUN echo 'this system will not be supported in the future' > /etc/unsupported-skip-usrmerge-conversion
|
RUN if [ "${IMPLEMENTATION}" = "kawa" ]; then apt update && apt install -y curl zip unzip && apt clean; fi
|
||||||
#RUN echo debconf usrmerge/autoconvert select true | debconf-set-selections && apt-get update && apt-get -y install usrmerge
|
RUN if [ "${IMPLEMENTATION}" = "kawa" ]; then bash -c "curl -s "https://get.sdkman.io" | bash && source $HOME/.sdkman/bin/sdkman-init.sh && sdk install java 22.0.2-tem"; fi
|
||||||
RUN sed -i 's/bullseye/bookworm/g' /etc/apt/sources.list
|
RUN if [ "${IMPLEMENTATION}" = "kawa" ]; then apt remove -y openjdk*; fi
|
||||||
RUN apt update && apt full-upgrade -y && apt install -y make git curl wget zip unzip bash && apt clean
|
ENV PATH=/root/.sdkman/candidates/java/22.0.2-tem/bin:$PATH
|
||||||
RUN apt full-upgrade -y
|
|
||||||
RUN cat /etc/issue
|
|
||||||
RUN if [ "$IMPLEMENTATION" = "kawa" ] ; then \
|
|
||||||
apt remove -y openjdk* --purge && apt autoremove -y && apt clean; \
|
|
||||||
curl -s "https://get.sdkman.io" | bash; \
|
|
||||||
bash -c "source ${HOME}/.sdkman/bin/sdkman-init.sh && sdk install java 22.0.2-tem"; \
|
|
||||||
cp -r ${HOME}/.sdkman/candidates/java/22.0.2-tem/bin/* /usr/local/bin; \
|
|
||||||
cp -r ${HOME}/.sdkman/candidates/java/22.0.2-tem/lib/* /usr/local/lib; \
|
|
||||||
sed -i 's/--no-console//' /usr/local/bin/kawa; \
|
|
||||||
fi
|
|
||||||
RUN if [ ! "$IMPLEMENTATION" = "guile" ] ; then apt install -y guile-3.0; fi
|
|
||||||
RUN git clone https://git.sr.ht/~retropikzel/schubert --depth=1 --branch=v0-16-3 && cd schubert && make && make install
|
|
||||||
RUN if [ "$IMPLEMENTATION" = "chicken" ] ; then chicken-install r7rs; fi
|
|
||||||
RUN if [ "$IMPLEMENTATION" = "racket" ] ; then raco pkg install --auto r7rs || true; fi
|
|
||||||
ARG WINE
|
|
||||||
RUN if [ "$WINE" = "true" ] ; then \
|
|
||||||
dpkg --add-architecture i386; \
|
|
||||||
mkdir -pm755 /etc/apt/keyrings; \
|
|
||||||
wget -O /etc/apt/keyrings/winehq-archive.key https://dl.winehq.org/wine-builds/winehq.key; \
|
|
||||||
wget -NP /etc/apt/sources.list.d/ https://dl.winehq.org/wine-builds/debian/dists/bookworm/winehq-bookworm.sources; \
|
|
||||||
apt update; \
|
|
||||||
apt install -y wine-binfmt --install-recommends winehq-stable; \
|
|
||||||
fi
|
|
||||||
ARG PACKAGES=curl
|
|
||||||
RUN apt update && apt install -y $PACKAGES
|
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,20 @@ pipeline {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
stage('Cyclone') {
|
||||||
|
steps {
|
||||||
|
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
||||||
|
sh 'make test-cyclone'
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
stage('Gambit') {
|
||||||
|
steps {
|
||||||
|
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
||||||
|
sh 'make test-gambit'
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
stage('Guile') {
|
stage('Guile') {
|
||||||
steps {
|
steps {
|
||||||
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
||||||
|
|
@ -26,13 +40,6 @@ pipeline {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
stage('Kawa') {
|
|
||||||
steps {
|
|
||||||
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
|
||||||
sh 'make test-kawa'
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
stage('Sagittarius') {
|
stage('Sagittarius') {
|
||||||
steps {
|
steps {
|
||||||
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
||||||
|
|
@ -47,17 +54,10 @@ pipeline {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
stage('Cyclone') {
|
stage('Kawa') {
|
||||||
steps {
|
steps {
|
||||||
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
||||||
sh 'make test-cyclone'
|
sh 'make test-kawa'
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
stage('Gambit') {
|
|
||||||
steps {
|
|
||||||
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
|
|
||||||
sh 'make test-gambit'
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
||||||
87
Makefile
87
Makefile
|
|
@ -15,53 +15,58 @@ test-tier2: \
|
||||||
test-gambit \
|
test-gambit \
|
||||||
test-stklos
|
test-stklos
|
||||||
|
|
||||||
CHICKEN_LIB=csc -X r7rs -R r7rs -s -J
|
CHICKEN=csc -X r7rs -R r7rs
|
||||||
build-chicken-libs:
|
CHICKEN_LIB=csc -X r7rs -R r7rs -include-path ./retropikzel -s -J
|
||||||
|
test-chicken: clean
|
||||||
|
docker build . --build-arg IMPLEMENTATION=chicken -f Dockerfile --tag=r7rs-pffi-chicken
|
||||||
cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld
|
cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld
|
||||||
${SCHEME_RUNNER} chicken "${CHICKEN_LIB} retropikzel.r7rs-pffi.sld"
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-chicken bash -c "cd /workdir && ${CHICKEN_LIB} retropikzel.r7rs-pffi.sld"
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-chicken bash -c "cd /workdir && ${CHICKEN} test.scm && ./test"
|
||||||
|
|
||||||
CHICKEN=csc -X r7rs -R r7rs -L -lcurl
|
CYCLONE=cyclone -A .
|
||||||
test-chicken: clean build-chicken-libs
|
test-cyclone: clean
|
||||||
${SCHEME_RUNNER} chicken "${CHICKEN} test.scm"
|
docker build . --build-arg IMPLEMENTATION=cyclone -f Dockerfile --tag=r7rs-pffi-cyclone
|
||||||
${SCHEME_RUNNER} chicken "./test"
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-cyclone bash -c "cd /workdir && ${CYCLONE} retropikzel/r7rs-pffi.sld"
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-cyclone bash -c "cd /workdir && ${CYCLONE} test.scm && ./test"
|
||||||
|
|
||||||
CYCLONE=cyclone -A . -A ./schubert
|
GAMBIT_LIB=gsc . retropikzel/r7rs-pffi
|
||||||
build-cyclone-libs:
|
GAMBIT_CC=gsc -exe . -nopreload
|
||||||
${SCHEME_RUNNER} cyclone "${CYCLONE} retropikzel/r7rs-pffi.sld"
|
test-gambit: clean
|
||||||
|
docker build . --build-arg IMPLEMENTATION=gambit -f Dockerfile --tag=r7rs-pffi-gambit
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-gambit bash -c "cd /workdir && ${GAMBIT_LIB} retropikzel/r7rs-pffi.sld; echo $$?"
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-gambit bash -c "cd /workdir && ${GAMBIT_CC} test.scm; echo $$?"
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-gambit bash -c "cd /workdir && ./test -:search=.; echo $$?"
|
||||||
|
|
||||||
CYCLONE=cyclone -A . -A ./schubert
|
GUILE=guile --r7rs --fresh-auto-compile -L .
|
||||||
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/gambit.scm"
|
|
||||||
${SCHEME_RUNNER} gambit "${GAMBIT_LIB} retropikzel/r7rs-pffi.sld"
|
|
||||||
|
|
||||||
GAMBIT=gsc -:r7rs,search=.:./schubert -ld-options -lcurl -exe
|
|
||||||
test-gambit: clean build-gambit-libs
|
|
||||||
${SCHEME_RUNNER} gambit "${GAMBIT} test.scm && ./test"
|
|
||||||
|
|
||||||
GUILE=guile --r7rs -L . -L ./schubert
|
|
||||||
test-guile:
|
test-guile:
|
||||||
${SCHEME_RUNNER} guile "${GUILE} test.scm"
|
docker build . --build-arg IMPLEMENTATION=guile -f Dockerfile --tag=r7rs-pffi-guile
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-guile bash -c "cd /workdir && ${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=.:*.sld
|
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:
|
test-kawa:
|
||||||
#${SCHEME_RUNNER} kawa "${KAWA} test.scm"
|
docker build . --build-arg IMPLEMENTATION=kawa -f Dockerfile --tag=r7rs-pffi-kawa
|
||||||
${KAWA} test.scm
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-kawa bash -c "cd /workdir && ${KAWA} test.scm"
|
||||||
|
|
||||||
SASH=sash -L . -L ./schubert
|
SASH=sash -r7 -L . -L ./schubert
|
||||||
test-sagittarius:
|
test-sagittarius:
|
||||||
${SCHEME_RUNNER} sagittarius "${SASH} test.scm"
|
docker build . --build-arg IMPLEMENTATION=sagittarius -f Dockerfile --tag=r7rs-pffi-sagittarius
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-sagittarius bash -c "cd /workdir && ${SASH} test.scm"
|
||||||
|
|
||||||
RACKET=racket -I r7rs -S . -S ./schubert --script
|
RACKET=racket -I r7rs -S . -S ./schubert --script
|
||||||
test-racket:
|
test-racket:
|
||||||
${SCHEME_RUNNER} racket "${RACKET} test.scm"
|
docker build . --build-arg IMPLEMENTATION=racket -f Dockerfile --tag=r7rs-pffi-racket
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-racket bash -c "cd /workdir && ${RACKET} test.scm"
|
||||||
|
|
||||||
STKLOS=stklos -A . -A ./schubert -f
|
STKLOS=stklos -A . -f
|
||||||
test-stklos:
|
test-stklos:
|
||||||
${SCHEME_RUNNER} stklos "${STKLOS} test.scm"
|
docker build . --build-arg IMPLEMENTATION=stklos -f Dockerfile --tag=r7rs-pffi-stklos
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-stklos bash -c "cd /workdir && ${STKLOS} test.scm"
|
||||||
|
|
||||||
|
CHIBI=chibi-scheme
|
||||||
|
CHIBI_STUB=chibi-ffi
|
||||||
|
test-chibi:
|
||||||
|
docker build . --build-arg IMPLEMENTATION=chibi -f Dockerfile --tag=r7rs-pffi-chibi
|
||||||
|
docker run -it -v ${PWD}:/workdir r7rs-pffi-chibi bash -c "cd /workdir && ${CHIBI_STUB} retropikzel/r7rs-pffi/chibi.stub"
|
||||||
|
|
||||||
documentation:
|
documentation:
|
||||||
cat README.md > docs/index.md
|
cat README.md > docs/index.md
|
||||||
|
|
@ -80,16 +85,16 @@ clean:
|
||||||
@rm -rf retropikzel/r7rs-pffi/retropikzel.*
|
@rm -rf retropikzel/r7rs-pffi/retropikzel.*
|
||||||
@rm -rf retropikzel/r7rs-pffi/compiled
|
@rm -rf retropikzel/r7rs-pffi/compiled
|
||||||
@rm -rf retropikzel.*
|
@rm -rf retropikzel.*
|
||||||
@rm -rf test/*.c
|
find . -name "*.meta" -delete
|
||||||
@rm -rf test/*.o*
|
|
||||||
@rm -rf test/*.so
|
|
||||||
@rm -rf test/*.meta
|
|
||||||
@rm -rf test/pffi-define
|
@rm -rf test/pffi-define
|
||||||
@rm -rf test/*gambit*
|
@rm -rf test/*gambit*
|
||||||
@rm -rf test/*.link
|
find . -name "*.link" -delete
|
||||||
@rm -rf *.c
|
find . -name "*.c" -delete
|
||||||
@rm -rf *.o
|
find . -name "*.o" -delete
|
||||||
@rm -rf *.so
|
find . -name "*.o[1-9]" -delete
|
||||||
@rm -rf *.a
|
find . -name "*.so" -delete
|
||||||
|
find . -name "*.a" -delete
|
||||||
@rm -rf test
|
@rm -rf test
|
||||||
@rm -rf tmp
|
@rm -rf tmp
|
||||||
|
find . -name "core.1" -delete
|
||||||
|
find . -name "test@gambit*" -delete
|
||||||
|
|
|
||||||
85
README.md
85
README.md
|
|
@ -8,76 +8,67 @@ Any help in form of constructive advice and bug reports are appreciated.
|
||||||
|
|
||||||
[Documentation](https://retropikzel.neocities.org/r7rs-pffi/) or run mkdocs serve or see docs/.
|
[Documentation](https://retropikzel.neocities.org/r7rs-pffi/) or run mkdocs serve or see docs/.
|
||||||
|
|
||||||
[Issue tracker](https://todo.sr.ht/~retropikzel/r7rs-pffi)
|
[Issue trackers](https://sr.ht/~retropikzel/r7rs-pffi/trackers)
|
||||||
|
|
||||||
[Maling lists](https://sr.ht/~retropikzel/r7rs-pffi/lists)
|
[Maling lists](https://sr.ht/~retropikzel/r7rs-pffi/lists)
|
||||||
|
|
||||||
|
|
||||||
For documentation see [retropikzel.neocities.org/r7rs-pffi](retropikzel.neocities.org/r7rs-pffi)
|
For documentation see [retropikzel.neocities.org/r7rs-pffi](retropikzel.neocities.org/r7rs-pffi)
|
||||||
or run mkdocs serve or see or docs/ directory.
|
or run mkdocs serve or see or docs/ directory.
|
||||||
|
|
||||||
For status of what tests pass on which implementations see
|
For status of what tests pass on which implementations see
|
||||||
[Jenkins](https://jenkins.staging.scheme.org/job/r7rs-pffi/job/master/).
|
[Jenkins](https://jenkins.staging.scheme.org/job/r7rs-pffi/job/master/).
|
||||||
|
|
||||||
# Goals
|
## Goals
|
||||||
|
|
||||||
- Support only R7RS implementations (for now)
|
- Support only R7RS implementations
|
||||||
- Same interface on all implementations
|
- Same interface on all implementations
|
||||||
- Some things that are procedures on one implementation are macros on other,
|
- Some things that are procedures on one implementation are macros on other,
|
||||||
but they must behave the same
|
but they must behave the same
|
||||||
|
|
||||||
# Non goals
|
## Non goals
|
||||||
|
|
||||||
- To have every possible FFI feature
|
- To have every possible FFI feature
|
||||||
- Compiling of C code at any point
|
- Compiling of C code at any point
|
||||||
- That is no stubs, no C code generated by the library and so on
|
- That is no stubs, no C code generated by the library and so on
|
||||||
|
|
||||||
# Support tiers
|
## Known issues that are worked on
|
||||||
|
|
||||||
Support is defined in tiers, each tier has short explanation about it after the title.
|
- Passing struct does not work on Chicken
|
||||||
|
- For example [SDL2-ttf TTF_RenderUTF8_Solid](https://wiki.libsdl.org/SDL2_ttf/TTF_RenderUTF8_Solid)
|
||||||
|
wants the color to be passed as struct.
|
||||||
|
- Not a problem on Guile, Sagittarius or Racket
|
||||||
|
- Cyclone status unknown, assumed same as Chicken
|
||||||
|
|
||||||
Currently the interface of the library is okay. Now work needs to be done to make tests and see
|
## Status
|
||||||
that each implementation passes those tests. This will be done in tiered order starting from tier 1.
|
|
||||||
|
|
||||||
Untiered, support needs to be investigated:
|
Currently the interface of the library is in okay shape. It propably will not change much but no
|
||||||
|
guarantees are being made just yet.
|
||||||
|
|
||||||
- [Gerbil](https://cons.io/)
|
### Usable
|
||||||
- [Ypsilon](http://www.littlewingpinball.com/doc/en/ypsilon/)
|
|
||||||
- [Larceny](https://larcenists.org/)
|
|
||||||
- [Mosh](https://mosh.monaos.org)
|
|
||||||
- [Skint](https://github.com/false-schemers/skint)
|
|
||||||
- [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html)
|
|
||||||
|
|
||||||
## Tier 1
|
|
||||||
|
|
||||||
Aiming to support these first
|
|
||||||
|
|
||||||
- [Chicken](https://www.call-cc.org/)
|
|
||||||
- [Guile](https://www.gnu.org/software/guile/)
|
- [Guile](https://www.gnu.org/software/guile/)
|
||||||
|
- [Sagittarius](https://bitbucket.org/ktakashi/sagittarius-scheme/wiki/Home)
|
||||||
|
- [Chicken 5](https://www.call-cc.org/)
|
||||||
|
- Needs [r7rs egg](https://wiki.call-cc.org/eggref/5/r7rs)
|
||||||
|
- [Racket](https://racket-lang.org/)
|
||||||
|
- Needs [racket-r7rs](https://github.com/lexi-lambda/racket-r7rs)
|
||||||
|
|
||||||
|
### Work in progress
|
||||||
|
|
||||||
|
- [Cyclone](https://justinethier.github.io/cyclone/)
|
||||||
|
- No callbacks implemented yet
|
||||||
- [Kawa](https://www.gnu.org/software/kawa/index.html)
|
- [Kawa](https://www.gnu.org/software/kawa/index.html)
|
||||||
|
- No callbacks implemented yet
|
||||||
- Needs at least java version 22
|
- Needs at least java version 22
|
||||||
- Needs jvm flags:
|
- Needs jvm flags:
|
||||||
- --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED
|
- --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.layout=ALL-UNNAMED
|
||||||
- --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED
|
- --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED
|
||||||
- --enable-native-access=ALL-UNNAMED
|
- --enable-native-access=ALL-UNNAMED
|
||||||
- [Sagittarius](https://bitbucket.org/ktakashi/sagittarius-scheme/wiki/Home)
|
|
||||||
- [Racket](https://racket-lang.org/)
|
|
||||||
|
|
||||||
## Tier 2
|
|
||||||
|
|
||||||
Work in progress
|
|
||||||
|
|
||||||
- [Gambit](https://gambitscheme.org)
|
- [Gambit](https://gambitscheme.org)
|
||||||
- Propably able to support everything but so annoying to deal with that it's currently in tier 2
|
|
||||||
- [STKlos](https://stklos.net/)
|
- [STKlos](https://stklos.net/)
|
||||||
- No callback support
|
|
||||||
- [Cyclone](https://justinethier.github.io/cyclone/)
|
|
||||||
- No callback support
|
|
||||||
|
|
||||||
## Tier 3
|
### Design/exploration
|
||||||
|
|
||||||
In queue
|
|
||||||
|
|
||||||
- [LIPS](https://lips.js.org/)
|
- [LIPS](https://lips.js.org/)
|
||||||
- Will work on nodejs by using some Javascript FFI
|
- Will work on nodejs by using some Javascript FFI
|
||||||
|
|
@ -85,11 +76,6 @@ In queue
|
||||||
- [Biwascheme](https://www.biwascheme.org/)
|
- [Biwascheme](https://www.biwascheme.org/)
|
||||||
- Will work on nodejs by using some Javascript FFI
|
- Will work on nodejs by using some Javascript FFI
|
||||||
- Javascript side needs design
|
- Javascript side needs design
|
||||||
|
|
||||||
## Tier 4
|
|
||||||
|
|
||||||
Support needs investigation and serious design or making dynamic FFI for the implementation
|
|
||||||
|
|
||||||
- [Chibi](https://synthcode.com/scheme/chibi)
|
- [Chibi](https://synthcode.com/scheme/chibi)
|
||||||
- FFI requires C code
|
- FFI requires C code
|
||||||
- [MIT-Scheme](https://www.gnu.org/software/mit-scheme/)
|
- [MIT-Scheme](https://www.gnu.org/software/mit-scheme/)
|
||||||
|
|
@ -98,19 +84,22 @@ Support needs investigation and serious design or making dynamic FFI for the imp
|
||||||
- FFI requires C code
|
- FFI requires C code
|
||||||
- [Gauche](https://practical-scheme.net/gauche/)
|
- [Gauche](https://practical-scheme.net/gauche/)
|
||||||
- FFI requires C code
|
- FFI requires C code
|
||||||
|
- [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html)
|
||||||
## Tier 5
|
- FFI requires C code
|
||||||
|
- [Gerbil](https://cons.io/)
|
||||||
Support maybe possible/dreaming about.
|
- Should be possible as built on gambit, but makes sense to make gambit support first
|
||||||
|
- [Ypsilon](http://www.littlewingpinball.com/doc/en/ypsilon/)
|
||||||
|
- [Larceny](https://larcenists.org/)
|
||||||
|
- [Mosh](https://mosh.monaos.org)
|
||||||
|
- [Skint](https://github.com/false-schemers/skint)
|
||||||
- [Airship](https://gitlab.com/mbabich/airship-scheme)
|
- [Airship](https://gitlab.com/mbabich/airship-scheme)
|
||||||
- [Other gambit targets](https://gambitscheme.org/)
|
- [Other gambit targets](https://gambitscheme.org/)
|
||||||
- Gambit compiles to different targets other than C too, for example Javascript. It would be cool
|
- Gambit compiles to different targets other than C too, for example Javascript. It would be cool
|
||||||
and interesting to see if this FFI could also support some of those
|
and interesting to see if this FFI could also support some of those
|
||||||
|
- [s48-r7rs](https://codeberg.org/prescheme/s48-r7rs)
|
||||||
|
- [prescheme](https://codeberg.org/prescheme/prescheme)
|
||||||
|
|
||||||
## Tier 6
|
### Will/can not be supported
|
||||||
|
|
||||||
Other.
|
|
||||||
|
|
||||||
- [Loko](https://scheme.fail/)
|
- [Loko](https://scheme.fail/)
|
||||||
- Desires no C interop, I can respect that
|
- Desires no C interop, I can respect that
|
||||||
|
|
|
||||||
|
|
@ -229,15 +229,3 @@ Returns:
|
||||||
|
|
||||||
- object
|
- object
|
||||||
- The value in the poiner in the given offset as given type
|
- The value in the poiner in the given offset as given type
|
||||||
|
|
||||||
## pffi-pointer-deref
|
|
||||||
|
|
||||||
Arguments:
|
|
||||||
|
|
||||||
- pointer
|
|
||||||
- The pointer to dereference
|
|
||||||
|
|
||||||
Returns:
|
|
||||||
|
|
||||||
- object
|
|
||||||
- Whatever the pointer holds
|
|
||||||
|
|
|
||||||
|
|
@ -5,6 +5,7 @@
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
|
(scheme char)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(chicken foreign)
|
(chicken foreign)
|
||||||
(chicken locative)
|
(chicken locative)
|
||||||
|
|
@ -14,6 +15,7 @@
|
||||||
(cyclone
|
(cyclone
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(cyclone foreign)
|
(cyclone foreign)
|
||||||
|
|
@ -21,11 +23,13 @@
|
||||||
(gambit
|
(gambit
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)))
|
(scheme process-context)))
|
||||||
(guile
|
(guile
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(rnrs bytevectors)
|
(rnrs bytevectors)
|
||||||
|
|
@ -34,11 +38,13 @@
|
||||||
(kawa
|
(kawa
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)))
|
(scheme process-context)))
|
||||||
(racket
|
(racket
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(only (racket base) system-type)
|
(only (racket base) system-type)
|
||||||
|
|
@ -49,6 +55,7 @@
|
||||||
(sagittarius
|
(sagittarius
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(sagittarius ffi)
|
(sagittarius ffi)
|
||||||
|
|
@ -56,6 +63,7 @@
|
||||||
(stklos
|
(stklos
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
|
(scheme char)
|
||||||
(scheme file)
|
(scheme file)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(stklos)))
|
(stklos)))
|
||||||
|
|
@ -74,19 +82,19 @@
|
||||||
pffi-pointer?
|
pffi-pointer?
|
||||||
pffi-pointer-null?
|
pffi-pointer-null?
|
||||||
pffi-pointer-set!
|
pffi-pointer-set!
|
||||||
pffi-pointer-get
|
pffi-pointer-get)
|
||||||
pffi-pointer-deref
|
|
||||||
pffi-os-name)
|
|
||||||
(begin
|
(begin
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(chicken (include "r7rs-pffi/chicken.scm"))
|
(chicken (include "r7rs-pffi/chicken.scm"))
|
||||||
(cyclone (include "r7rs-pffi/cyclone.scm"))
|
(cyclone (include "retropikzel/r7rs-pffi/cyclone.scm"))
|
||||||
(gambit (include "r7rs-pffi/gambit.scm"))
|
(gambit (include "r7rs-pffi/gambit.scm"))
|
||||||
(guile (include "r7rs-pffi/guile.scm"))
|
(guile (include "r7rs-pffi/guile.scm"))
|
||||||
(kawa (include "r7rs-pffi/kawa.scm"))
|
(kawa (include "r7rs-pffi/kawa.scm"))
|
||||||
(racket (include "r7rs-pffi/racket.scm"))
|
(racket (include "r7rs-pffi/racket.scm"))
|
||||||
(sagittarius (include "r7rs-pffi/sagittarius.scm"))
|
(sagittarius (include "r7rs-pffi/sagittarius.scm"))
|
||||||
(stklos (include "r7rs-pffi/stklos.scm"))
|
(stklos (include "retropikzel/r7rs-pffi/stklos.scm"))
|
||||||
(else #t))
|
(else #t))
|
||||||
(include "r7rs-pffi/main.scm")
|
(cond-expand
|
||||||
))
|
(cyclone (include "retropikzel/r7rs-pffi/main.scm"))
|
||||||
|
(stklos (include "retropikzel/r7rs-pffi/main.scm"))
|
||||||
|
(else (include "r7rs-pffi/main.scm")))))
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,9 @@
|
||||||
|
(define-syntax pffi-init
|
||||||
|
(er-macro-transformer
|
||||||
|
(lambda (expr rename compare)
|
||||||
|
'(import (chicken foreign)
|
||||||
|
(chicken memory)))))
|
||||||
|
|
||||||
(define pffi-type->native-type
|
(define pffi-type->native-type
|
||||||
(lambda (type)
|
(lambda (type)
|
||||||
(cond ((equal? type 'int8) 'byte)
|
(cond ((equal? type 'int8) 'byte)
|
||||||
|
|
@ -25,8 +31,7 @@
|
||||||
|
|
||||||
(define pffi-pointer?
|
(define pffi-pointer?
|
||||||
(lambda (object)
|
(lambda (object)
|
||||||
(or (string? object)
|
(pointer? object)))
|
||||||
(pointer? object))))
|
|
||||||
|
|
||||||
(define-syntax pffi-define
|
(define-syntax pffi-define
|
||||||
(er-macro-transformer
|
(er-macro-transformer
|
||||||
|
|
@ -149,49 +154,28 @@
|
||||||
(pffi-define puts #f 'puts 'int (list 'pointer))
|
(pffi-define puts #f 'puts 'int (list 'pointer))
|
||||||
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
|
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
|
||||||
|
|
||||||
(define pffi-string->pointer
|
#;(define pffi-string->pointer
|
||||||
(lambda (string-content)
|
(lambda (string-content)
|
||||||
(let* ((size (string-length string-content))
|
(let* ((size (string-length string-content))
|
||||||
(pointer (pffi-pointer-allocate (+ size 1))))
|
(pointer (pffi-pointer-allocate (+ size 1))))
|
||||||
(memset pointer 0 size)
|
(memset pointer 0 (+ size 1))
|
||||||
(display "STRING-LENGTH: ")
|
|
||||||
(display size)
|
|
||||||
(display " / ")
|
|
||||||
(display pointer)
|
|
||||||
(display " === ")
|
|
||||||
(strncpy-ps pointer (location string-content) size)
|
(strncpy-ps pointer (location string-content) size)
|
||||||
;(move-memory! string-content pointer size 0)
|
|
||||||
;(pffi-pointer-set! pointer 'char size #\null)
|
|
||||||
(puts pointer)
|
(puts pointer)
|
||||||
(display " ::: ")
|
|
||||||
(write string-content)
|
|
||||||
(display " OTHER: ")
|
|
||||||
(display (strlen pointer))
|
|
||||||
(newline)
|
|
||||||
;(pointer-s8-set! pointer size (foreign-value "\0" char))
|
|
||||||
pointer)))
|
pointer)))
|
||||||
|
|
||||||
|
(define pffi-string->pointer
|
||||||
|
(foreign-lambda* c-pointer
|
||||||
|
((c-string str))
|
||||||
|
"C_return((void*)str);"))
|
||||||
|
|
||||||
|
|
||||||
(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||||
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
||||||
|
|
||||||
(define pffi-pointer->string
|
(define pffi-pointer->string
|
||||||
(lambda (pointer)
|
(foreign-lambda* c-string
|
||||||
(cond ((pffi-pointer? pointer)
|
((c-pointer p))
|
||||||
(let* ((size (strlen pointer))
|
"C_return((char*)p);"))
|
||||||
(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
|
(define-syntax pffi-shared-object-load
|
||||||
(er-macro-transformer
|
(er-macro-transformer
|
||||||
|
|
@ -226,7 +210,7 @@
|
||||||
((equal? type 'uint32) (pointer-u32-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 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
|
||||||
((equal? type 'uint64) (pointer-u64-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 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value)))
|
||||||
((equal? type 'short) (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 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
|
||||||
((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
|
((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||||
|
|
@ -248,7 +232,7 @@
|
||||||
((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
|
((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
|
||||||
((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
|
((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
|
||||||
((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
|
((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
|
||||||
((equal? type 'char) (pointer-s8-ref (pointer+ pointer offset)))
|
((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset))))
|
||||||
((equal? type 'short) (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 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
|
||||||
((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
|
((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
|
||||||
|
|
@ -259,6 +243,3 @@
|
||||||
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
|
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
|
||||||
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
|
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
|
||||||
|
|
||||||
(define pffi-pointer-deref
|
|
||||||
(lambda (pointer)
|
|
||||||
pointer))
|
|
||||||
|
|
|
||||||
|
|
@ -24,7 +24,7 @@
|
||||||
|
|
||||||
(define pffi-pointer?
|
(define pffi-pointer?
|
||||||
(lambda (object)
|
(lambda (object)
|
||||||
(error "Not defined")))
|
(opaque? object)))
|
||||||
|
|
||||||
(define-syntax pffi-define
|
(define-syntax pffi-define
|
||||||
(er-macro-transformer
|
(er-macro-transformer
|
||||||
|
|
@ -65,6 +65,10 @@
|
||||||
`(c-define ,scheme-name
|
`(c-define ,scheme-name
|
||||||
,return-type ,c-name ,@ argument-types))))))
|
,return-type ,c-name ,@ argument-types))))))
|
||||||
|
|
||||||
|
(define pffi-define-callback
|
||||||
|
(lambda (scheme-name return-type argument-types procedure)
|
||||||
|
(error "pffi-define-callback not yet implemented on Cyclone")))
|
||||||
|
|
||||||
(define pffi-size-of
|
(define pffi-size-of
|
||||||
(lambda (type)
|
(lambda (type)
|
||||||
(cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
|
(cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
|
||||||
|
|
@ -88,22 +92,24 @@
|
||||||
((equal? type 'pointer) (c-value "sizeof(void*)" int))
|
((equal? type 'pointer) (c-value "sizeof(void*)" int))
|
||||||
(else (error "pffi-size-of -- No such pffi type" type)))))
|
(else (error "pffi-size-of -- No such pffi type" type)))))
|
||||||
|
|
||||||
(define pffi-pointer-allocate
|
(define-c pffi-pointer-allocate
|
||||||
(lambda (size)
|
"(void *data, int argc, closure _, object k, object size)"
|
||||||
(error "Not defined")))
|
"make_c_opaque(opq, malloc(obj_obj2int(size)));
|
||||||
|
return_closcall1(data, k, &opq);")
|
||||||
|
|
||||||
(define pffi-pointer-null
|
(define pffi-pointer-null
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(error "Not defined")))
|
(make-opaque)))
|
||||||
|
|
||||||
(define pffi-string->pointer
|
(define-c pffi-string->pointer
|
||||||
(lambda (string-content)
|
"(void *data, int argc, closure _, object k, object s)"
|
||||||
(error "Not defined")
|
"make_c_opaque(opq, string_str(s));
|
||||||
))
|
return_closcall1(data, k, &opq);")
|
||||||
|
|
||||||
(define pffi-pointer->string
|
(define-c pffi-pointer->string
|
||||||
(lambda (pointer)
|
"(void *data, int argc, closure _, object k, object p)"
|
||||||
pointer))
|
"make_string(s, opaque_ptr(p));
|
||||||
|
return_closcall1(data, k, &s);")
|
||||||
|
|
||||||
(define-syntax pffi-shared-object-load
|
(define-syntax pffi-shared-object-load
|
||||||
(er-macro-transformer
|
(er-macro-transformer
|
||||||
|
|
@ -114,27 +120,262 @@
|
||||||
`(include-c-header ,(string-append "<" header ">")))
|
`(include-c-header ,(string-append "<" header ">")))
|
||||||
(cdr (car (cdr expr))))))))
|
(cdr (car (cdr expr))))))))
|
||||||
|
|
||||||
(define pffi-pointer-free
|
(define-c pffi-pointer-free
|
||||||
(lambda (pointer)
|
"(void *data, int argc, closure _, object k, object pointer)"
|
||||||
(error "Not defined")))
|
"free(opaque_ptr(pointer));
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
(define pffi-pointer-null?
|
(define pffi-pointer-null?
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
(error "Not defined")))
|
(and (opaque? pointer)
|
||||||
|
(opaque-null? pointer))))
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int8-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint8-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int16-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint16-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int32-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint32-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int64-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint64-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-char-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2char(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-short-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-unsigned-short-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-unsigned-int-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-long-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-unsigned-long-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = obj_obj2int(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-float-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"float* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = double_value(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-double-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"double* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = double_value(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-pointer-set!
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset, object value)"
|
||||||
|
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
*p = &opaque_ptr(value);
|
||||||
|
return_closcall1(data, k, make_boolean(boolean_t));")
|
||||||
|
|
||||||
(define pffi-pointer-set!
|
(define pffi-pointer-set!
|
||||||
(lambda (pointer type offset value)
|
(lambda (pointer type offset value)
|
||||||
(let ((p pointer))
|
(cond
|
||||||
(error "Not defined"))))
|
((equal? type 'int8) (pffi-pointer-int8-set! pointer offset value))
|
||||||
|
((equal? type 'uint8) (pffi-pointer-uint8-set! pointer offset value))
|
||||||
|
((equal? type 'int16) (pffi-pointer-int16-set! pointer offset value))
|
||||||
|
((equal? type 'uint16) (pffi-pointer-uint16-set! pointer offset value))
|
||||||
|
((equal? type 'int32) (pffi-pointer-int32-set! pointer offset value))
|
||||||
|
((equal? type 'uint32) (pffi-pointer-uint32-set! pointer offset value))
|
||||||
|
((equal? type 'int64) (pffi-pointer-int64-set! pointer offset value))
|
||||||
|
((equal? type 'uint64) (pffi-pointer-uint64-set! pointer offset value))
|
||||||
|
((equal? type 'char) (pffi-pointer-char-set! pointer offset value))
|
||||||
|
((equal? type 'short) (pffi-pointer-short-set! pointer offset value))
|
||||||
|
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-set! pointer offset value))
|
||||||
|
((equal? type 'int) (pffi-pointer-int-set! pointer offset value))
|
||||||
|
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-set! pointer offset value))
|
||||||
|
((equal? type 'long) (pffi-pointer-long-set! pointer offset value))
|
||||||
|
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-set! pointer offset value))
|
||||||
|
((equal? type 'float) (pffi-pointer-float-set! pointer offset value))
|
||||||
|
((equal? type 'double) (pffi-pointer-double-set! pointer offset value))
|
||||||
|
((equal? type 'pointer) (pffi-pointer-pointer-set! pointer offset value))
|
||||||
|
)))
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int8-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"int8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint8-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"uint8_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int16-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"int16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint16-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"uint16_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int32-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"int32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint32-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"uint32_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int64-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"int64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-uint64-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"uint64_t* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-char-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"char* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_char2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-short-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-unsigned-short-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"unsigned short* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-int-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-unsigned-int-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"unsigned int* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-long-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-unsigned-long-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"unsigned long* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
return_closcall1(data, k, obj_int2obj(*p));")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-float-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"float* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
alloca_double(d, *p);
|
||||||
|
return_closcall1(data, k, d);")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-double-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"double* p = opaque_ptr(pointer) + obj_obj2int(offset);
|
||||||
|
alloca_double(d, *p);
|
||||||
|
return_closcall1(data, k, d);")
|
||||||
|
|
||||||
|
(define-c pffi-pointer-pointer-get
|
||||||
|
"(void *data, int argc, closure _, object k, object pointer, object offset)"
|
||||||
|
"make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset));
|
||||||
|
return_closcall1(data, k, &opq);")
|
||||||
|
|
||||||
(define pffi-pointer-get
|
(define pffi-pointer-get
|
||||||
(lambda (pointer type offset)
|
(lambda (pointer type offset)
|
||||||
(error "Not defined")))
|
(cond
|
||||||
|
((equal? type 'int8) (pffi-pointer-int8-get pointer offset))
|
||||||
|
((equal? type 'uint8) (pffi-pointer-uint8-get pointer offset))
|
||||||
|
((equal? type 'int16) (pffi-pointer-int16-get pointer offset))
|
||||||
|
((equal? type 'uint16) (pffi-pointer-uint16-get pointer offset))
|
||||||
|
((equal? type 'int32) (pffi-pointer-int32-get pointer offset))
|
||||||
|
((equal? type 'uint32) (pffi-pointer-uint32-get pointer offset))
|
||||||
|
((equal? type 'int64) (pffi-pointer-int64-get pointer offset))
|
||||||
|
((equal? type 'uint64) (pffi-pointer-uint64-get pointer offset))
|
||||||
|
((equal? type 'char) (pffi-pointer-char-get pointer offset))
|
||||||
|
((equal? type 'short) (pffi-pointer-short-get pointer offset))
|
||||||
|
((equal? type 'unsigned-short) (pffi-pointer-unsigned-short-get pointer offset))
|
||||||
|
((equal? type 'int) (pffi-pointer-int-get pointer offset))
|
||||||
|
((equal? type 'unsigned-int) (pffi-pointer-unsigned-int-get pointer offset))
|
||||||
|
((equal? type 'long) (pffi-pointer-long-get pointer offset))
|
||||||
|
((equal? type 'unsigned-long) (pffi-pointer-unsigned-long-get pointer offset))
|
||||||
|
((equal? type 'float) (pffi-pointer-float-get pointer offset))
|
||||||
|
((equal? type 'double) (pffi-pointer-double-get pointer offset))
|
||||||
|
((equal? type 'pointer) (pffi-pointer-pointer-get pointer offset))
|
||||||
|
)))
|
||||||
|
|
||||||
(define pffi-pointer-deref
|
(define pffi-pointer-cast->struct
|
||||||
(lambda (pointer)
|
(lambda (struct-name pointer)
|
||||||
(error "Not defined")))
|
pointer))
|
||||||
|
|
||||||
(define pffi-define-callback
|
|
||||||
(lambda (scheme-name return-type argument-types procedure)
|
|
||||||
(error "pffi-define-callback not yet implemented on Cyclone")))
|
|
||||||
|
|
|
||||||
|
|
@ -1,38 +1,82 @@
|
||||||
|
|
||||||
|
(c-declare "#include <stdint.h>")
|
||||||
|
|
||||||
(define pffi-type->native-type
|
(define pffi-type->native-type
|
||||||
(lambda (type)
|
(lambda (type)
|
||||||
(error "Not defined")))
|
(cond ((equal? type 'int8) int8)
|
||||||
|
((equal? type 'uint8) unsigned-int8)
|
||||||
|
((equal? type 'int16) int16)
|
||||||
|
((equal? type 'uint16) unsigned-int16)
|
||||||
|
((equal? type 'int32) int32)
|
||||||
|
((equal? type 'uint32) unsigned-int32)
|
||||||
|
((equal? type 'int64) int64)
|
||||||
|
((equal? type 'uint64) unsigned-int64)
|
||||||
|
((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) pointer)
|
||||||
|
((equal? type 'void) void)
|
||||||
|
((equal? type 'callback) pointer)
|
||||||
|
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||||
|
|
||||||
(define pffi-pointer?
|
(define pffi-pointer?
|
||||||
(lambda (object)
|
(lambda (object)
|
||||||
(error "Not defined")))
|
(error "Not defined")))
|
||||||
|
|
||||||
(define pffi-define
|
(define-syntax pffi-define
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ scheme-name shared-object c-name return-type argument-types)
|
||||||
|
(define scheme-name
|
||||||
|
#f
|
||||||
|
#;(c-lambda argument-types return-type c-name)
|
||||||
|
|
||||||
|
))))
|
||||||
|
|
||||||
|
(define pffi-define-callback
|
||||||
(lambda (scheme-name shared-object c-name return-type argument-types)
|
(lambda (scheme-name shared-object c-name return-type argument-types)
|
||||||
(error "Not defined")))
|
(error "Not defined")))
|
||||||
|
|
||||||
|
(c-declare "int size_of_int8() { return sizeof(int8_t);}")
|
||||||
|
;(define size-of-int8 (c-lambda () int "__return(sizeof(int8_t));"))
|
||||||
|
;(define int8-size ((c-lambda () int "__return(sizeof(int8_t));")))
|
||||||
|
;(define int8-size (c-lambda () int "__return(1);"))
|
||||||
|
|
||||||
(define pffi-size-of
|
(define pffi-size-of
|
||||||
(lambda (type)
|
(lambda (type)
|
||||||
(error "Not defined")))
|
(cond ((equal? type 'int8) 1)
|
||||||
|
(else (error "pffi-size-of -- No such pffi type" type)))))
|
||||||
|
|
||||||
(define pffi-pointer-allocate
|
(define-syntax pffi-pointer-allocate
|
||||||
(lambda (size)
|
(syntax-rules
|
||||||
(error "Not defined")))
|
((pffi-pointer-allocate size)
|
||||||
|
(c-declare (string-append "malloc(" (number->string size) ")")))))
|
||||||
|
|
||||||
(define pffi-pointer-null
|
(define-syntax pffi-pointer-null
|
||||||
(lambda ()
|
(syntax-rules
|
||||||
(error "Not defined")))
|
((pffi-pointer-null)
|
||||||
|
(c-declare "NULL"))))
|
||||||
|
|
||||||
(define pffi-string->pointer
|
(define pffi-string->pointer
|
||||||
(lambda (string-content)
|
(lambda (string-content)
|
||||||
(error "Not defined")))
|
string-content))
|
||||||
|
|
||||||
(define pffi-pointer->string
|
(define pffi-pointer->string
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
pointer))
|
pointer))
|
||||||
|
|
||||||
(define pffi-shared-object-load
|
(define-syntax pffi-shared-object-load
|
||||||
(lambda (headers)
|
(syntax-rules ()
|
||||||
(error "Not defined")))
|
((pffi-shared-object-load headers)
|
||||||
|
(c-declare (apply string-append
|
||||||
|
(map (lambda (header)
|
||||||
|
(string-append "#include <" header ">"))))))))
|
||||||
|
|
||||||
(define pffi-pointer-free
|
(define pffi-pointer-free
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
|
|
|
||||||
|
|
@ -79,50 +79,50 @@
|
||||||
|
|
||||||
(define pffi-pointer-set!
|
(define pffi-pointer-set!
|
||||||
(lambda (pointer type offset value)
|
(lambda (pointer type offset value)
|
||||||
(let ((p (pointer->bytevector pointer (+ offset 100)))
|
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||||
(native-type (pffi-type->native-type type)))
|
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
|
||||||
(cond ((equal? native-type int8) (bytevector-s8-set! p offset value))
|
((equal? type 'uint8) (bytevector-u8-set! p offset value))
|
||||||
((equal? native-type uint8) (bytevector-u8-set! p offset value))
|
((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
|
||||||
((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness)))
|
((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
|
||||||
((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness)))
|
((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
|
||||||
((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness)))
|
((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
|
||||||
((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness)))
|
((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
|
||||||
((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness)))
|
((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
|
||||||
((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness)))
|
((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
|
||||||
((equal? native-type short) (bytevector-s8-set! p offset value))
|
((equal? type 'short) (bytevector-s8-set! p offset value))
|
||||||
((equal? native-type unsigned-short) (bytevector-u8-set! p offset value))
|
((equal? 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? 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? 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? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
|
||||||
((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
|
((equal? 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? 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 '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 '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)))))))
|
((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (pffi-size-of type)))))))
|
||||||
|
|
||||||
(define pffi-pointer-get
|
(define pffi-pointer-get
|
||||||
(lambda (pointer type offset)
|
(lambda (pointer type offset)
|
||||||
(let ((p (pointer->bytevector pointer (+ offset 100)))
|
(let ((p (pointer->bytevector pointer (+ offset 100))))
|
||||||
(native-type (pffi-type->native-type type)))
|
(cond ((equal? type 'int8) (bytevector-s8-ref p offset))
|
||||||
(cond ((equal? native-type int8) (bytevector-s8-ref p offset))
|
((equal? type 'uint8) (bytevector-u8-ref p offset))
|
||||||
((equal? native-type uint8) (bytevector-u8-ref p offset))
|
((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
|
||||||
((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness)))
|
((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
|
||||||
((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness)))
|
((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
|
||||||
((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness)))
|
((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
|
||||||
((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness)))
|
((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
|
||||||
((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness)))
|
((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
|
||||||
((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness)))
|
((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
|
||||||
((equal? native-type short) (bytevector-s8-ref p offset))
|
((equal? type 'short) (bytevector-s8-ref p offset))
|
||||||
((equal? native-type unsigned-short) (bytevector-u8-ref p offset))
|
((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
|
||||||
((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))
|
((equal? 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? 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? type 'long) (bytevector-s64-ref p offset (native-endianness)))
|
||||||
((equal? native-type unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
|
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
|
||||||
((equal? native-type float) (bytevector-ieee-single-ref p offset (native-endianness)))
|
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
|
||||||
((equal? native-type double) (bytevector-ieee-double-ref p offset (native-endianness)))
|
((equal? 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 '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)))))))))
|
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))))))))
|
||||||
|
|
||||||
(define pffi-pointer-deref
|
(define pffi-pointer-cast->struct
|
||||||
(lambda (pointer)
|
(lambda (struct-name pointer)
|
||||||
(dereference-pointer pointer)))
|
pointer))
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,3 @@
|
||||||
|
|
||||||
(define arena (invoke-static java.lang.foreign.Arena 'global))
|
(define arena (invoke-static java.lang.foreign.Arena 'global))
|
||||||
(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup))
|
(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup))
|
||||||
(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
|
||||||
|
|
@ -9,10 +8,16 @@
|
||||||
(java.lang.Byte value))
|
(java.lang.Byte value))
|
||||||
((equal? type 'short)
|
((equal? type 'short)
|
||||||
(java.lang.Short value))
|
(java.lang.Short value))
|
||||||
|
((equal? type 'unsigned-short)
|
||||||
|
(java.lang.Short value))
|
||||||
((equal? type 'int)
|
((equal? type 'int)
|
||||||
(java.lang.Integer value))
|
(java.lang.Integer value))
|
||||||
|
((equal? type 'unsigned-int)
|
||||||
|
(java.lang.Integer value))
|
||||||
((equal? type 'long)
|
((equal? type 'long)
|
||||||
(java.lang.Long value))
|
(java.lang.Long value))
|
||||||
|
((equal? type 'unsigned-long)
|
||||||
|
(java.lang.Long value))
|
||||||
((equal? type 'float)
|
((equal? type 'float)
|
||||||
(java.lang.Float value))
|
(java.lang.Float value))
|
||||||
((equal? type 'double)
|
((equal? type 'double)
|
||||||
|
|
@ -176,14 +181,17 @@
|
||||||
|
|
||||||
(define pffi-pointer-get
|
(define pffi-pointer-get
|
||||||
(lambda (pointer type offset)
|
(lambda (pointer type offset)
|
||||||
(invoke (invoke pointer
|
(let ((r (invoke (invoke pointer 'reinterpret
|
||||||
'reinterpret
|
(static-field java.lang.Integer 'MAX_VALUE))
|
||||||
(static-field java.lang.Integer 'MAX_VALUE))
|
'get
|
||||||
'get
|
(invoke (pffi-type->native-type type) 'withByteAlignment 1)
|
||||||
(invoke (pffi-type->native-type type) 'withByteAlignment 1)
|
offset)))
|
||||||
offset)))
|
r)))
|
||||||
|
|
||||||
(define pffi-pointer-deref
|
(define pffi-pointer-deref
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
(invoke pointer 'get (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1) 0)))
|
(invoke pointer 'get (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1) 0)))
|
||||||
|
|
||||||
|
(define pffi-pointer-cast->struct
|
||||||
|
(lambda (struct-name pointer)
|
||||||
|
pointer))
|
||||||
|
|
|
||||||
|
|
@ -1,31 +1,6 @@
|
||||||
|
(cond-expand
|
||||||
(define pffi-os-name
|
(chicken #t)
|
||||||
(cond-expand
|
(else (define pffi-init (lambda () #t))))
|
||||||
(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
|
(define pffi-types
|
||||||
'(int8
|
'(int8
|
||||||
|
|
@ -67,59 +42,6 @@
|
||||||
(for-each splitter str-l)
|
(for-each splitter str-l)
|
||||||
res)))
|
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 auto-load-versions (list ""))
|
||||||
|
|
||||||
|
|
@ -131,8 +53,75 @@
|
||||||
(chicken (pffi-shared-object-load headers))
|
(chicken (pffi-shared-object-load headers))
|
||||||
(gambit (pffi-shared-object-load headers))
|
(gambit (pffi-shared-object-load headers))
|
||||||
(else
|
(else
|
||||||
(let* ((paths (append auto-load-paths additional-paths))
|
(let* ((slash (cond-expand (windows (string #\\)) (else "/")))
|
||||||
|
(auto-load-paths
|
||||||
|
(cond-expand
|
||||||
|
(windows
|
||||||
|
(append
|
||||||
|
(if (get-environment-variable "SYSTEM")
|
||||||
|
(list (get-environment-variable "SYSTEM"))
|
||||||
|
(list))
|
||||||
|
(if (get-environment-variable "WINDIR")
|
||||||
|
(list (get-environment-variable "WINDIR"))
|
||||||
|
(list))
|
||||||
|
(if (get-environment-variable "WINEDLLDIR0")
|
||||||
|
(list (get-environment-variable "WINEDLLDIR0"))
|
||||||
|
(list))
|
||||||
|
(if (get-environment-variable "SystemRoot")
|
||||||
|
(list (string-append
|
||||||
|
(get-environment-variable "SystemRoot")
|
||||||
|
slash
|
||||||
|
"system32"))
|
||||||
|
(list))
|
||||||
|
(list ".")
|
||||||
|
(if (get-environment-variable "PATH")
|
||||||
|
(string-split (get-environment-variable "PATH") #\;)
|
||||||
|
(list))
|
||||||
|
(if (get-environment-variable "PWD")
|
||||||
|
(list (get-environment-variable "PWD"))
|
||||||
|
(list))))
|
||||||
|
(else
|
||||||
|
(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"
|
||||||
|
)))))
|
||||||
|
(auto-load-versions (list))
|
||||||
|
(paths (append auto-load-paths additional-paths))
|
||||||
(versions (append auto-load-versions additional-versions))
|
(versions (append auto-load-versions additional-versions))
|
||||||
|
(platform-lib-prefix
|
||||||
|
(cond-expand
|
||||||
|
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
|
||||||
|
(windows "")
|
||||||
|
(else "lib")))
|
||||||
|
(platform-file-extension
|
||||||
|
(cond-expand
|
||||||
|
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
|
||||||
|
(windows ".dll")
|
||||||
|
(else ".so")))
|
||||||
(shared-object #f))
|
(shared-object #f))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (path)
|
(lambda (path)
|
||||||
|
|
|
||||||
|
|
@ -1,120 +1,106 @@
|
||||||
(define-library
|
(define pffi-type->native-type
|
||||||
(retropikzel r7rs-pffi version racket)
|
(lambda (type)
|
||||||
(import (scheme base)
|
(cond ((equal? type 'int8) _int8)
|
||||||
(scheme write)
|
((equal? type 'uint8) _uint8)
|
||||||
(scheme file)
|
((equal? type 'int16) _int16)
|
||||||
(scheme process-context)
|
((equal? type 'uint16) _uint16)
|
||||||
(compatibility mlist)
|
((equal? type 'int32) _int32)
|
||||||
(only (racket base) system-type)
|
((equal? type 'uint32) _uint32)
|
||||||
(ffi unsafe)
|
((equal? type 'int64) _int64)
|
||||||
(ffi vector))
|
((equal? type 'uint64) _uint64)
|
||||||
(export pffi-shared-object-load
|
((equal? type 'char) _int8)
|
||||||
pffi-define
|
((equal? type 'unsigned-char) _uint8)
|
||||||
pffi-define-callback
|
((equal? type 'short) _short)
|
||||||
pffi-size-of
|
((equal? type 'unsigned-short) _ushort)
|
||||||
pffi-pointer-allocate
|
((equal? type 'int) _int)
|
||||||
pffi-pointer-null
|
((equal? type 'unsigned-int) _uint)
|
||||||
pffi-string->pointer
|
((equal? type 'long) _long)
|
||||||
pffi-pointer->string
|
((equal? type 'unsigned-long) _ulong)
|
||||||
pffi-pointer-free
|
((equal? type 'float) _float)
|
||||||
pffi-pointer?
|
((equal? type 'double) _double)
|
||||||
pffi-pointer-null?
|
((equal? type 'pointer) _pointer)
|
||||||
pffi-pointer-set!
|
((equal? type 'void) _void)
|
||||||
pffi-pointer-get
|
((equal? type 'callback) _pointer)
|
||||||
pffi-pointer-deref)
|
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||||
(begin
|
|
||||||
|
|
||||||
(define pffi-type->native-type
|
(define pffi-pointer?
|
||||||
(lambda (type)
|
(lambda (object)
|
||||||
(cond ((equal? type 'int8) _int8)
|
(cpointer? object)))
|
||||||
((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) _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 'void) _void)
|
|
||||||
((equal? type 'callback) _pointer)
|
|
||||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
|
||||||
|
|
||||||
(define pffi-pointer?
|
(define-syntax pffi-define
|
||||||
(lambda (object)
|
(syntax-rules ()
|
||||||
(cpointer? object)))
|
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
||||||
|
(define scheme-name
|
||||||
|
(get-ffi-obj c-name
|
||||||
|
shared-object
|
||||||
|
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
|
||||||
|
(pffi-type->native-type return-type)))))))
|
||||||
|
|
||||||
(define-syntax pffi-define
|
(define-syntax pffi-define-callback
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((pffi-define scheme-name shared-object c-name return-type argument-types)
|
((pffi-define-callback scheme-name return-type argument-types procedure)
|
||||||
(define scheme-name
|
(define scheme-name (function-ptr procedure
|
||||||
(get-ffi-obj c-name
|
(_cprocedure
|
||||||
shared-object
|
(mlist->list (map pffi-type->native-type argument-types))
|
||||||
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
|
(pffi-type->native-type return-type)))))))
|
||||||
(pffi-type->native-type return-type)))))))
|
|
||||||
|
|
||||||
(define-syntax pffi-define-callback
|
(define pffi-size-of
|
||||||
(syntax-rules ()
|
(lambda (type)
|
||||||
((pffi-define-callback scheme-name return-type argument-types procedure)
|
(ctype-sizeof (pffi-type->native-type type))))
|
||||||
(define scheme-name (function-ptr procedure
|
|
||||||
(_cprocedure
|
|
||||||
(mlist->list (map pffi-type->native-type argument-types))
|
|
||||||
(pffi-type->native-type return-type)))))))
|
|
||||||
|
|
||||||
(define pffi-size-of
|
(define pffi-pointer-allocate
|
||||||
(lambda (type)
|
(lambda (size)
|
||||||
(ctype-sizeof (pffi-type->native-type type))))
|
(malloc 'raw size)))
|
||||||
|
|
||||||
(define pffi-pointer-allocate
|
(define pffi-pointer-null
|
||||||
(lambda (size)
|
(lambda ()
|
||||||
(malloc 'raw size)))
|
#f )) ; #f is the null pointer on racket
|
||||||
|
|
||||||
(define pffi-pointer-null
|
(define pffi-string->pointer
|
||||||
(lambda ()
|
(lambda (string-content)
|
||||||
#f )) ; #f is the null pointer on racket
|
(let* ((size (string-length string-content))
|
||||||
|
(pointer (pffi-pointer-allocate (+ size 1))))
|
||||||
|
(memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1))
|
||||||
|
pointer)))
|
||||||
|
|
||||||
(define pffi-string->pointer
|
(define pffi-pointer->string
|
||||||
(lambda (string-content)
|
(lambda (pointer)
|
||||||
(let* ((size (string-length string-content))
|
(when (pffi-pointer-null? pointer)
|
||||||
(pointer (pffi-pointer-allocate (+ size 1))))
|
(error "Can not make string from null pointer" pointer))
|
||||||
(memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1))
|
(string-copy (cast pointer _pointer _string))))
|
||||||
pointer)))
|
|
||||||
|
|
||||||
(define pffi-pointer->string
|
(define pffi-shared-object-load
|
||||||
(lambda (pointer)
|
(lambda (header path)
|
||||||
(when (pffi-pointer-null? pointer)
|
(ffi-lib path)))
|
||||||
(error "Can not make string from null pointer" pointer))
|
|
||||||
(string-copy (cast pointer _pointer _string))))
|
|
||||||
|
|
||||||
(define pffi-shared-object-load
|
(define pffi-pointer-free
|
||||||
(lambda (header path)
|
(lambda (pointer)
|
||||||
(ffi-lib path)))
|
(free pointer)))
|
||||||
|
|
||||||
(define pffi-pointer-free
|
(define pffi-pointer-null?
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
(free pointer)))
|
(not pointer))) ; #f is the null pointer on racket
|
||||||
|
|
||||||
(define pffi-pointer-null?
|
(define pffi-pointer-set!
|
||||||
(lambda (pointer)
|
(lambda (pointer type offset value)
|
||||||
(not pointer))) ; #f is the null pointer on racket
|
(ptr-set! pointer
|
||||||
|
(pffi-type->native-type type)
|
||||||
|
'abs
|
||||||
|
offset
|
||||||
|
(if (equal? type 'char)
|
||||||
|
(char->integer value)
|
||||||
|
value))))
|
||||||
|
|
||||||
(define pffi-pointer-set!
|
(define pffi-pointer-get
|
||||||
(lambda (pointer type offset value)
|
(lambda (pointer type offset)
|
||||||
(ptr-set! pointer (pffi-type->native-type type) 'abs offset value)))
|
(let ((r (ptr-ref pointer
|
||||||
|
(pffi-type->native-type type)
|
||||||
|
'abs
|
||||||
|
offset)))
|
||||||
|
(if (equal? type 'char)
|
||||||
|
(integer->char r)
|
||||||
|
r))))
|
||||||
|
|
||||||
(define pffi-pointer-get
|
(define pffi-pointer-cast->struct
|
||||||
(lambda (pointer type offset)
|
(lambda (struct-name pointer)
|
||||||
(ptr-ref pointer (pffi-type->native-type type) 'abs offset)))
|
pointer))
|
||||||
|
|
||||||
(define pffi-pointer-deref
|
|
||||||
(lambda (pointer)
|
|
||||||
pointer))))
|
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,7 @@
|
||||||
((equal? type 'float) 'float)
|
((equal? type 'float) 'float)
|
||||||
((equal? type 'double) 'double)
|
((equal? type 'double) 'double)
|
||||||
((equal? type 'pointer) 'void*)
|
((equal? type 'pointer) 'void*)
|
||||||
|
((equal? type 'string) 'string)
|
||||||
((equal? type 'void) 'void)
|
((equal? type 'void) 'void)
|
||||||
((equal? type 'callback) 'callback)
|
((equal? type 'callback) 'callback)
|
||||||
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
(else (error "pffi-type->native-type -- No such pffi type" type)))))
|
||||||
|
|
@ -74,17 +75,25 @@
|
||||||
|
|
||||||
(define pffi-pointer-null
|
(define pffi-pointer-null
|
||||||
(lambda ()
|
(lambda ()
|
||||||
null-pointer))
|
(empty-pointer)))
|
||||||
|
|
||||||
(define pffi-string->pointer
|
(define pffi-string->pointer
|
||||||
(lambda (string-content)
|
(lambda (string-content)
|
||||||
string-content))
|
(letrec* ((bytes (string->utf8 string-content))
|
||||||
|
(bytes-length (bytevector-length bytes))
|
||||||
|
(pointer-length (+ bytes-length 1))
|
||||||
|
(pointer (pffi-pointer-allocate pointer-length))
|
||||||
|
(looper
|
||||||
|
(lambda (index)
|
||||||
|
(when (< index bytes-length)
|
||||||
|
(pointer-set-c-uint8_t! pointer index (bytevector-u8-ref bytes index))
|
||||||
|
(looper (+ index 1))))))
|
||||||
|
(looper 0)
|
||||||
|
pointer)))
|
||||||
|
|
||||||
(define pffi-pointer->string
|
(define pffi-pointer->string
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
(if (string? pointer)
|
(pointer->string pointer)))
|
||||||
pointer
|
|
||||||
(pointer->string pointer))))
|
|
||||||
|
|
||||||
(define pffi-shared-object-load
|
(define pffi-shared-object-load
|
||||||
(lambda (header path)
|
(lambda (header path)
|
||||||
|
|
@ -109,7 +118,7 @@
|
||||||
((equal? type 'uint32) (pointer-set-c-uint32_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 'int64) (pointer-set-c-int64_t! pointer offset value))
|
||||||
((equal? type 'uint64) (pointer-set-c-uint64_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 'char) (pointer-set-c-char! pointer offset (char->integer value)))
|
||||||
((equal? type 'short) (pointer-set-c-short! 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 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
|
||||||
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
((equal? type 'int) (pointer-set-c-int! pointer offset value))
|
||||||
|
|
@ -118,7 +127,7 @@
|
||||||
((equal? type 'unsigned-long) (pointer-set-c-unsigned-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 'float) (pointer-set-c-float! pointer offset value))
|
||||||
((equal? type 'double) (pointer-set-c-double! 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 'void) (pointer-set-c-pointer! pointer offset value))
|
||||||
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
|
||||||
|
|
||||||
(define pffi-pointer-get
|
(define pffi-pointer-get
|
||||||
|
|
@ -131,7 +140,7 @@
|
||||||
((equal? type 'uint32) (pointer-ref-c-uint32_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 'int64) (pointer-ref-c-int64_t pointer offset))
|
||||||
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
|
||||||
((equal? type 'char) (pointer-ref-c-char pointer offset))
|
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
|
||||||
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
((equal? type 'short) (pointer-ref-c-short pointer offset))
|
||||||
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-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 'int) (pointer-ref-c-int pointer offset))
|
||||||
|
|
@ -143,6 +152,6 @@
|
||||||
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
|
||||||
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
|
||||||
|
|
||||||
(define pffi-pointer-deref
|
(define pffi-pointer-cast->struct
|
||||||
(lambda (pointer)
|
(lambda (struct-name pointer)
|
||||||
(deref pointer 0)))
|
pointer))
|
||||||
|
|
|
||||||
|
|
@ -37,14 +37,36 @@
|
||||||
(pffi-type->native-type return-type)
|
(pffi-type->native-type return-type)
|
||||||
shared-object)))))
|
shared-object)))))
|
||||||
|
|
||||||
|
|
||||||
(define pffi-define-callback
|
(define pffi-define-callback
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(error "STklos does not support callbacks")))
|
(error "Not implemented")
|
||||||
|
))
|
||||||
|
|
||||||
|
; If youre reading this, this is just a temp hack. Dont judge me :D
|
||||||
(define pffi-size-of
|
(define pffi-size-of
|
||||||
(lambda (type)
|
(lambda (type)
|
||||||
(error "Not implemented")))
|
(cond
|
||||||
|
((equal? type 'int8) 1)
|
||||||
|
((equal? type 'uint8) 1)
|
||||||
|
((equal? type 'int16) 2)
|
||||||
|
((equal? type 'uint16) 2)
|
||||||
|
((equal? type 'int32) 4)
|
||||||
|
((equal? type 'uint32) 4)
|
||||||
|
((equal? type 'int64) 8)
|
||||||
|
((equal? type 'uint64) 8)
|
||||||
|
((equal? type 'char) 1)
|
||||||
|
((equal? type 'unsigned-char) 1)
|
||||||
|
((equal? type 'short) 2)
|
||||||
|
((equal? type 'unsigned-short) 2)
|
||||||
|
((equal? type 'int) 4)
|
||||||
|
((equal? type 'unsigned-int) 4)
|
||||||
|
((equal? type 'long) 8)
|
||||||
|
((equal? type 'unsigned-long) 8)
|
||||||
|
((equal? type 'float) 4)
|
||||||
|
((equal? type 'double) 8)
|
||||||
|
((equal? type 'pointer) 8)
|
||||||
|
|
||||||
|
)))
|
||||||
|
|
||||||
(define pffi-pointer-allocate
|
(define pffi-pointer-allocate
|
||||||
(lambda (size)
|
(lambda (size)
|
||||||
|
|
@ -52,7 +74,9 @@
|
||||||
|
|
||||||
(define pffi-pointer-null
|
(define pffi-pointer-null
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((p (allocate-bytes 0))) (cpointer-data-set! p 0) p)))
|
(let ((p (allocate-bytes 0)))
|
||||||
|
(free-bytes p)
|
||||||
|
p)))
|
||||||
|
|
||||||
(define pffi-string->pointer
|
(define pffi-string->pointer
|
||||||
(lambda (string-content)
|
(lambda (string-content)
|
||||||
|
|
@ -60,7 +84,9 @@
|
||||||
|
|
||||||
(define pffi-pointer->string
|
(define pffi-pointer->string
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
pointer))
|
(if (string? pointer)
|
||||||
|
pointer
|
||||||
|
(cpointer->string pointer))))
|
||||||
|
|
||||||
(define pffi-shared-object-load
|
(define pffi-shared-object-load
|
||||||
(lambda (header path)
|
(lambda (header path)
|
||||||
|
|
@ -72,11 +98,21 @@
|
||||||
|
|
||||||
(define pffi-pointer-null?
|
(define pffi-pointer-null?
|
||||||
(lambda (pointer)
|
(lambda (pointer)
|
||||||
(cpointer-null? pointer)))
|
(and (cpointer? pointer)
|
||||||
|
(cpointer-null? pointer))))
|
||||||
|
|
||||||
(define pffi-pointer-set!
|
(define pffi-pointer-set!
|
||||||
(lambda (pointer type offset value)
|
(lambda (pointer type offset value)
|
||||||
(error "Not implemented")))
|
(let ((null-pointer (pffi-pointer-null))
|
||||||
|
(offset-address (cpointer-data pointer)))
|
||||||
|
(cpointer-data-set! null-pointer offset-address)
|
||||||
|
(display "HERE")
|
||||||
|
(newline)
|
||||||
|
(write null-pointer)
|
||||||
|
(newline)
|
||||||
|
(exit)
|
||||||
|
;(error "Not implemented")
|
||||||
|
)))
|
||||||
|
|
||||||
(define pffi-pointer-get
|
(define pffi-pointer-get
|
||||||
(lambda (pointer type offset)
|
(lambda (pointer type offset)
|
||||||
|
|
|
||||||
|
|
@ -1,33 +0,0 @@
|
||||||
#!/bin/bash
|
|
||||||
|
|
||||||
set -e
|
|
||||||
DOCKERFILE=Dockerfile
|
|
||||||
|
|
||||||
if test "${1}" = "" -o "${2}" = "";
|
|
||||||
then
|
|
||||||
echo "Example: "
|
|
||||||
echo "scheme_runner debian guile \"make test\""
|
|
||||||
exit
|
|
||||||
else
|
|
||||||
implementation="${1}"
|
|
||||||
cmd="${2}"
|
|
||||||
tag="scheme-runner-${implementation}"
|
|
||||||
if [ "${WINE}" = "true" ];
|
|
||||||
then
|
|
||||||
tag=${tag}-wine
|
|
||||||
fi
|
|
||||||
|
|
||||||
echo "Running command: ${cmd}, with implementation: ${implementation}"
|
|
||||||
docker build \
|
|
||||||
--build-arg IMPLEMENTATION=${implementation} \
|
|
||||||
--build-arg PACKAGES="${PACKAGES}" \
|
|
||||||
--build-arg WINE="${WINE}" \
|
|
||||||
-f ${DOCKERFILE} \
|
|
||||||
--tag ${tag}:latest \
|
|
||||||
.
|
|
||||||
docker run \
|
|
||||||
-e CHICKEN_INCLUDE_PATH=/workdir/retropikzel \
|
|
||||||
-v ${PWD}:/workdir:z \
|
|
||||||
${tag}:latest \
|
|
||||||
${cmd}
|
|
||||||
fi
|
|
||||||
179
test.scm
179
test.scm
|
|
@ -1,6 +1,6 @@
|
||||||
(import (scheme base)
|
(import (scheme base)
|
||||||
(scheme write)
|
(scheme write)
|
||||||
(scheme load)
|
(scheme char)
|
||||||
(scheme process-context)
|
(scheme process-context)
|
||||||
(retropikzel r7rs-pffi))
|
(retropikzel r7rs-pffi))
|
||||||
|
|
||||||
|
|
@ -47,6 +47,12 @@
|
||||||
(write value)
|
(write value)
|
||||||
(newline)))))
|
(newline)))))
|
||||||
|
|
||||||
|
;; pffi-init
|
||||||
|
|
||||||
|
(print-header 'pffi-init)
|
||||||
|
|
||||||
|
(pffi-init)
|
||||||
|
|
||||||
;; pffi-size-of
|
;; pffi-size-of
|
||||||
|
|
||||||
(print-header 'pffi-size-of)
|
(print-header 'pffi-size-of)
|
||||||
|
|
@ -162,55 +168,16 @@
|
||||||
(assert equal? (number? size-pointer) #t)
|
(assert equal? (number? size-pointer) #t)
|
||||||
(assert = size-pointer 8)
|
(assert = size-pointer 8)
|
||||||
|
|
||||||
;; pffi-init
|
|
||||||
|
|
||||||
(print-header 'pffi-init)
|
|
||||||
|
|
||||||
(pffi-init)
|
|
||||||
|
|
||||||
;; pffi-shared-object-auto-load
|
;; pffi-shared-object-auto-load
|
||||||
|
|
||||||
(print-header 'pffi-shared-object-auto-load)
|
(print-header 'pffi-shared-object-auto-load)
|
||||||
|
|
||||||
(define libc-stdlib
|
(define libc-stdlib
|
||||||
(if (string=? pffi-os-name "windows")
|
(cond-expand
|
||||||
(pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))
|
(windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list "")))
|
||||||
(pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6"))))
|
(else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6")))))
|
||||||
|
|
||||||
;; pffi-string->pointer
|
(debug libc-stdlib)
|
||||||
|
|
||||||
(print-header 'pffi-string->pointer)
|
|
||||||
|
|
||||||
(define string-pointer (pffi-string->pointer "Hello world"))
|
|
||||||
(debug string-pointer)
|
|
||||||
(assert equal? (pffi-pointer? string-pointer) #t)
|
|
||||||
(assert equal? (pffi-pointer-null? string-pointer) #f)
|
|
||||||
|
|
||||||
;; pffi-pointer->string
|
|
||||||
|
|
||||||
(print-header 'pffi-pointer->string)
|
|
||||||
|
|
||||||
(define pointer-string (pffi-pointer->string string-pointer))
|
|
||||||
(debug pointer-string)
|
|
||||||
(assert equal? (string? pointer-string) #t)
|
|
||||||
(assert string=? pointer-string "Hello world")
|
|
||||||
(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org")
|
|
||||||
(define test-url-string "https://scheme.org")
|
|
||||||
(debug test-url-string)
|
|
||||||
(define test-url (pffi-string->pointer test-url-string))
|
|
||||||
(debug test-url)
|
|
||||||
(debug (pffi-pointer->string test-url))
|
|
||||||
(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;; pffi-pointer-allocate
|
|
||||||
|
|
||||||
(print-header 'pffi-pointer-allocate)
|
|
||||||
|
|
||||||
(define test-pointer (pffi-pointer-allocate 100))
|
|
||||||
(debug test-pointer)
|
|
||||||
(assert equal? (pffi-pointer? test-pointer) #t)
|
|
||||||
|
|
||||||
;; pffi-pointer-null
|
;; pffi-pointer-null
|
||||||
|
|
||||||
|
|
@ -220,14 +187,24 @@
|
||||||
(debug null-pointer)
|
(debug null-pointer)
|
||||||
(assert equal? (pffi-pointer-null? null-pointer) #t)
|
(assert equal? (pffi-pointer-null? null-pointer) #t)
|
||||||
|
|
||||||
;; pffi-pointer-free
|
;; pffi-pointer-null?
|
||||||
|
|
||||||
(print-header 'pffi-pointer-free)
|
(print-header 'pffi-pointer-null?)
|
||||||
|
|
||||||
(define pointer-to-be-freed (pffi-pointer-allocate 100))
|
(define is-null-pointer (pffi-pointer-null))
|
||||||
(debug pointer-to-be-freed)
|
(debug is-null-pointer)
|
||||||
(pffi-pointer-free pointer-to-be-freed)
|
(assert equal? (pffi-pointer-null? is-null-pointer) #t)
|
||||||
(debug pointer-to-be-freed)
|
(assert equal? (pffi-pointer-null? 100) #f)
|
||||||
|
(assert equal? (pffi-pointer-null? 'bar) #f)
|
||||||
|
|
||||||
|
;; pffi-pointer-allocate
|
||||||
|
|
||||||
|
(print-header 'pffi-pointer-allocate)
|
||||||
|
|
||||||
|
(define test-pointer (pffi-pointer-allocate 100))
|
||||||
|
(debug test-pointer)
|
||||||
|
(assert equal? (pffi-pointer? test-pointer) #t)
|
||||||
|
(assert equal? (pffi-pointer-null? test-pointer) #f)
|
||||||
|
|
||||||
;; pffi-pointer?
|
;; pffi-pointer?
|
||||||
|
|
||||||
|
|
@ -239,22 +216,18 @@
|
||||||
(assert equal? (pffi-pointer? 100) #f)
|
(assert equal? (pffi-pointer? 100) #f)
|
||||||
(assert equal? (pffi-pointer? 'bar) #f)
|
(assert equal? (pffi-pointer? 'bar) #f)
|
||||||
|
|
||||||
;; pffi-pointer-null?
|
;; pffi-pointer-free
|
||||||
|
|
||||||
(print-header 'pffi-pointer-null?)
|
(print-header 'pffi-pointer-free)
|
||||||
|
|
||||||
(define is-null-pointer (pffi-pointer-null))
|
(define pointer-to-be-freed (pffi-pointer-allocate 100))
|
||||||
(debug is-null-pointer)
|
(debug pointer-to-be-freed)
|
||||||
(define is-not-null-pointer (pffi-pointer-allocate 100))
|
(pffi-pointer-free pointer-to-be-freed)
|
||||||
(debug is-not-null-pointer)
|
(debug pointer-to-be-freed)
|
||||||
(assert equal? (pffi-pointer-null? is-null-pointer) #t)
|
|
||||||
(assert equal? (pffi-pointer-null? is-not-null-pointer) #f)
|
|
||||||
(assert equal? (pffi-pointer-null? 100) #f)
|
|
||||||
(assert equal? (pffi-pointer-null? 'bar) #f)
|
|
||||||
|
|
||||||
;; pffi-pointer-set! and pffi-pointer-get
|
;; pffi-pointer-set! and pffi-pointer-get 1/2
|
||||||
|
|
||||||
(print-header "pffi-pointer-set! and pffi-pointer-get")
|
(print-header "pffi-pointer-set! and pffi-pointer-get 1/2")
|
||||||
|
|
||||||
(define set-pointer (pffi-pointer-allocate 256))
|
(define set-pointer (pffi-pointer-allocate 256))
|
||||||
(define offset 50)
|
(define offset 50)
|
||||||
|
|
@ -285,6 +258,10 @@
|
||||||
(test-type 'long)
|
(test-type 'long)
|
||||||
(test-type 'unsigned-long)
|
(test-type 'unsigned-long)
|
||||||
|
|
||||||
|
(pffi-pointer-set! set-pointer 'char offset #\X)
|
||||||
|
(debug (pffi-pointer-get set-pointer 'char offset))
|
||||||
|
(assert char=? (pffi-pointer-get set-pointer 'char offset) #\X)
|
||||||
|
|
||||||
(pffi-pointer-set! set-pointer 'float offset 1.5)
|
(pffi-pointer-set! set-pointer 'float offset 1.5)
|
||||||
(debug (pffi-pointer-get set-pointer 'float offset))
|
(debug (pffi-pointer-get set-pointer 'float offset))
|
||||||
(assert = (pffi-pointer-get set-pointer 'float offset) 1.5)
|
(assert = (pffi-pointer-get set-pointer 'float offset) 1.5)
|
||||||
|
|
@ -292,9 +269,66 @@
|
||||||
(debug (pffi-pointer-get set-pointer 'double offset))
|
(debug (pffi-pointer-get set-pointer 'double offset))
|
||||||
(assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
|
(assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
|
||||||
|
|
||||||
|
;; pffi-string->pointer
|
||||||
|
|
||||||
|
(print-header 'pffi-string->pointer)
|
||||||
|
|
||||||
|
(define string-pointer (pffi-string->pointer "Hello world"))
|
||||||
|
(debug string-pointer)
|
||||||
|
(assert equal? (pffi-pointer? string-pointer) #t)
|
||||||
|
(assert equal? (pffi-pointer-null? string-pointer) #f)
|
||||||
|
(debug (pffi-pointer-get string-pointer 'char 0))
|
||||||
|
(assert char=? (pffi-pointer-get string-pointer 'char 0) #\H)
|
||||||
|
(debug (pffi-pointer-get string-pointer 'char 1))
|
||||||
|
(assert char=? (pffi-pointer-get string-pointer 'char 1) #\e)
|
||||||
|
(debug (pffi-pointer-get string-pointer 'char 2))
|
||||||
|
(assert char=? (pffi-pointer-get string-pointer 'char 2) #\l)
|
||||||
|
(debug (pffi-pointer-get string-pointer 'char 3))
|
||||||
|
(assert char=? (pffi-pointer-get string-pointer 'char 3) #\l)
|
||||||
|
(debug (pffi-pointer-get string-pointer 'char 4))
|
||||||
|
(assert char=? (pffi-pointer-get string-pointer 'char 4) #\o)
|
||||||
|
(debug (pffi-pointer-get string-pointer 'char 10))
|
||||||
|
(assert char=? (pffi-pointer-get string-pointer 'char 10) #\d)
|
||||||
|
|
||||||
|
;; pffi-pointer->string
|
||||||
|
|
||||||
|
(print-header 'pffi-pointer->string)
|
||||||
|
|
||||||
|
(define pointer-string (pffi-pointer->string string-pointer))
|
||||||
|
(debug pointer-string)
|
||||||
|
(assert equal? (string? pointer-string) #t)
|
||||||
|
(assert string=? pointer-string "Hello world")
|
||||||
|
(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org")
|
||||||
|
(define test-url-string "https://scheme.org")
|
||||||
|
(debug test-url-string)
|
||||||
|
(define test-url (pffi-string->pointer test-url-string))
|
||||||
|
(debug test-url)
|
||||||
|
(debug (pffi-pointer->string test-url))
|
||||||
|
(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t)
|
||||||
|
|
||||||
|
;; pffi-pointer-get
|
||||||
|
|
||||||
|
(print-header "pffi-pointer-get")
|
||||||
|
|
||||||
|
(define hello-string "hello")
|
||||||
|
(define hello-string-pointer (pffi-string->pointer hello-string))
|
||||||
|
|
||||||
|
(debug (pffi-pointer-get hello-string-pointer 'char 0))
|
||||||
|
(assert char=? (pffi-pointer-get hello-string-pointer 'char 0) #\h)
|
||||||
|
(debug (pffi-pointer-get hello-string-pointer 'char 1))
|
||||||
|
(assert char=? (pffi-pointer-get hello-string-pointer 'char 1) #\e)
|
||||||
|
(debug (pffi-pointer-get hello-string-pointer 'char 4))
|
||||||
|
(assert char=? (pffi-pointer-get hello-string-pointer 'char 4) #\o)
|
||||||
|
|
||||||
|
;; pffi-pointer-set! and pffi-pointer-get 2/2
|
||||||
|
|
||||||
|
(print-header "pffi-pointer-set! and pffi-pointer-get 2/2")
|
||||||
|
|
||||||
(define pointer-to-be-set (pffi-string->pointer "FOOBAR"))
|
(define pointer-to-be-set (pffi-string->pointer "FOOBAR"))
|
||||||
(debug pointer-to-be-set)
|
(debug pointer-to-be-set)
|
||||||
|
(debug (pffi-pointer->string pointer-to-be-set))
|
||||||
(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set)
|
(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set)
|
||||||
|
|
||||||
(debug (pffi-pointer-get set-pointer 'pointer offset))
|
(debug (pffi-pointer-get set-pointer 'pointer offset))
|
||||||
(assert equal?
|
(assert equal?
|
||||||
(pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset))
|
(pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset))
|
||||||
|
|
@ -312,29 +346,11 @@
|
||||||
(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set))
|
(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set))
|
||||||
(assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR")
|
(assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR")
|
||||||
|
|
||||||
;; pffi-pointer-deref
|
#|
|
||||||
|
|
||||||
(print-header 'pffi-pointer-deref)
|
|
||||||
|
|
||||||
(define pointer-to-deref (pffi-pointer-allocate (pffi-size-of 'int)))
|
|
||||||
(debug pointer-to-deref)
|
|
||||||
(pffi-pointer-set! pointer-to-deref 'int 0 42)
|
|
||||||
(assert equal? (pffi-pointer? (pffi-pointer-deref pointer-to-deref)) #t)
|
|
||||||
|
|
||||||
;; pffi-os-name
|
|
||||||
|
|
||||||
(print-header 'pffi-os-name)
|
|
||||||
|
|
||||||
(assert equal?
|
|
||||||
(or (string=? pffi-os-name "windows")
|
|
||||||
(string=? pffi-os-name "unix"))
|
|
||||||
#t)
|
|
||||||
|
|
||||||
;; pffi-define
|
;; pffi-define
|
||||||
|
|
||||||
(print-header 'pffi-define)
|
(print-header 'pffi-define)
|
||||||
|
|
||||||
|
|
||||||
(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
|
(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
|
||||||
(assert = (atoi (pffi-string->pointer "100")) 100)
|
(assert = (atoi (pffi-string->pointer "100")) 100)
|
||||||
|
|
||||||
|
|
@ -375,3 +391,4 @@
|
||||||
(newline)
|
(newline)
|
||||||
|
|
||||||
(exit 0)
|
(exit 0)
|
||||||
|
|#
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue