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

Lots of fixes

This commit is contained in:
retropikzel 2024-10-04 15:48:19 +03:00
parent 407bf14590
commit 1b285c7204
19 changed files with 840 additions and 598 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Dockerfile
View File

@ -1,34 +1,8 @@
ARG IMPLEMENTATION
FROM schemers/$IMPLEMENTATION
ARG IMPLEMENTATION
RUN echo "deb http://ftp.fi.debian.org/debian/ bookworm main" > /etc/apt/sources.list
WORKDIR /workdir
RUN echo 'this system will not be supported in the future' > /etc/unsupported-skip-usrmerge-conversion
#RUN echo debconf usrmerge/autoconvert select true | debconf-set-selections && apt-get update && apt-get -y install usrmerge
RUN sed -i 's/bullseye/bookworm/g' /etc/apt/sources.list
RUN apt update && apt full-upgrade -y && apt install -y make git curl wget zip unzip bash && apt clean
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
RUN if [ "${IMPLEMENTATION}" = "kawa" ]; then apt update && apt install -y curl zip unzip && apt clean; fi
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 if [ "${IMPLEMENTATION}" = "kawa" ]; then apt remove -y openjdk*; fi
ENV PATH=/root/.sdkman/candidates/java/22.0.2-tem/bin:$PATH

32
Jenkinsfile vendored
View File

@ -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') {
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
@ -26,13 +40,6 @@ pipeline {
}
}
}
stage('Kawa') {
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'make test-kawa'
}
}
}
stage('Sagittarius') {
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
@ -47,17 +54,10 @@ pipeline {
}
}
}
stage('Cyclone') {
stage('Kawa') {
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'make test-cyclone'
}
}
}
stage('Gambit') {
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'make test-gambit'
sh 'make test-kawa'
}
}
}

87
Makefile
View File

@ -15,53 +15,58 @@ test-tier2: \
test-gambit \
test-stklos
CHICKEN_LIB=csc -X r7rs -R r7rs -s -J
build-chicken-libs:
CHICKEN=csc -X r7rs -R r7rs
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
${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
test-chicken: clean build-chicken-libs
${SCHEME_RUNNER} chicken "${CHICKEN} test.scm"
${SCHEME_RUNNER} chicken "./test"
CYCLONE=cyclone -A .
test-cyclone: clean
docker build . --build-arg IMPLEMENTATION=cyclone -f Dockerfile --tag=r7rs-pffi-cyclone
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
build-cyclone-libs:
${SCHEME_RUNNER} cyclone "${CYCLONE} retropikzel/r7rs-pffi.sld"
GAMBIT_LIB=gsc . retropikzel/r7rs-pffi
GAMBIT_CC=gsc -exe . -nopreload
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
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
GUILE=guile --r7rs --fresh-auto-compile -L .
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
test-kawa:
#${SCHEME_RUNNER} kawa "${KAWA} test.scm"
${KAWA} test.scm
docker build . --build-arg IMPLEMENTATION=kawa -f Dockerfile --tag=r7rs-pffi-kawa
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:
${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
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:
${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:
cat README.md > docs/index.md
@ -80,16 +85,16 @@ clean:
@rm -rf retropikzel/r7rs-pffi/retropikzel.*
@rm -rf retropikzel/r7rs-pffi/compiled
@rm -rf retropikzel.*
@rm -rf test/*.c
@rm -rf test/*.o*
@rm -rf test/*.so
@rm -rf test/*.meta
find . -name "*.meta" -delete
@rm -rf test/pffi-define
@rm -rf test/*gambit*
@rm -rf test/*.link
@rm -rf *.c
@rm -rf *.o
@rm -rf *.so
@rm -rf *.a
find . -name "*.link" -delete
find . -name "*.c" -delete
find . -name "*.o" -delete
find . -name "*.o[1-9]" -delete
find . -name "*.so" -delete
find . -name "*.a" -delete
@rm -rf test
@rm -rf tmp
find . -name "core.1" -delete
find . -name "test@gambit*" -delete

85
README.md
View File

@ -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/.
[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)
For documentation see [retropikzel.neocities.org/r7rs-pffi](retropikzel.neocities.org/r7rs-pffi)
or run mkdocs serve or see or docs/ directory.
For status of what tests pass on which implementations see
[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
- Some things that are procedures on one implementation are macros on other,
but they must behave the same
# Non goals
## Non goals
- To have every possible FFI feature
- Compiling of C code at any point
- 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
that each implementation passes those tests. This will be done in tiered order starting from tier 1.
## Status
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/)
- [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)
### Usable
## Tier 1
Aiming to support these first
- [Chicken](https://www.call-cc.org/)
- [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)
- No callbacks implemented yet
- Needs at least java version 22
- Needs jvm flags:
- --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
- [Sagittarius](https://bitbucket.org/ktakashi/sagittarius-scheme/wiki/Home)
- [Racket](https://racket-lang.org/)
## Tier 2
Work in progress
- [Gambit](https://gambitscheme.org)
- Propably able to support everything but so annoying to deal with that it's currently in tier 2
- [STKlos](https://stklos.net/)
- No callback support
- [Cyclone](https://justinethier.github.io/cyclone/)
- No callback support
## Tier 3
In queue
### Design/exploration
- [LIPS](https://lips.js.org/)
- Will work on nodejs by using some Javascript FFI
@ -85,11 +76,6 @@ In queue
- [Biwascheme](https://www.biwascheme.org/)
- Will work on nodejs by using some Javascript FFI
- 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)
- FFI requires C code
- [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
- [Gauche](https://practical-scheme.net/gauche/)
- FFI requires C code
## Tier 5
Support maybe possible/dreaming about.
- [s7](https://scheme.fail://ccrma.stanford.edu/software/snd/snd/s7.html)
- FFI requires C code
- [Gerbil](https://cons.io/)
- 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)
- [Other gambit targets](https://gambitscheme.org/)
- 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
- [s48-r7rs](https://codeberg.org/prescheme/s48-r7rs)
- [prescheme](https://codeberg.org/prescheme/prescheme)
## Tier 6
Other.
### Will/can not be supported
- [Loko](https://scheme.fail/)
- Desires no C interop, I can respect that

BIN
curl.dll
View File

Binary file not shown.

12
docs/reference.md
View File

@ -229,15 +229,3 @@ Returns:
- object
- 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

22
retropikzel/r7rs-pffi.sld
View File

@ -5,6 +5,7 @@
(import (scheme base)
(scheme write)
(scheme file)
(scheme char)
(scheme process-context)
(chicken foreign)
(chicken locative)
@ -14,6 +15,7 @@
(cyclone
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(cyclone foreign)
@ -21,11 +23,13 @@
(gambit
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(guile
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(rnrs bytevectors)
@ -34,11 +38,13 @@
(kawa
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)))
(racket
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(only (racket base) system-type)
@ -49,6 +55,7 @@
(sagittarius
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(sagittarius ffi)
@ -56,6 +63,7 @@
(stklos
(import (scheme base)
(scheme write)
(scheme char)
(scheme file)
(scheme process-context)
(stklos)))
@ -74,19 +82,19 @@
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref
pffi-os-name)
pffi-pointer-get)
(begin
(cond-expand
(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"))
(guile (include "r7rs-pffi/guile.scm"))
(kawa (include "r7rs-pffi/kawa.scm"))
(racket (include "r7rs-pffi/racket.scm"))
(sagittarius (include "r7rs-pffi/sagittarius.scm"))
(stklos (include "r7rs-pffi/stklos.scm"))
(stklos (include "retropikzel/r7rs-pffi/stklos.scm"))
(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")))))

59
retropikzel/r7rs-pffi/chicken.scm
View File

@ -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
(lambda (type)
(cond ((equal? type 'int8) 'byte)
@ -25,8 +31,7 @@
(define pffi-pointer?
(lambda (object)
(or (string? object)
(pointer? object))))
(pointer? object)))
(define-syntax pffi-define
(er-macro-transformer
@ -149,49 +154,28 @@
(pffi-define puts #f 'puts 'int (list 'pointer))
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
(define pffi-string->pointer
#;(define pffi-string->pointer
(lambda (string-content)
(let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate (+ size 1))))
(memset pointer 0 size)
(display "STRING-LENGTH: ")
(display size)
(display " / ")
(display pointer)
(display " === ")
(memset pointer 0 (+ size 1))
(strncpy-ps pointer (location string-content) size)
;(move-memory! string-content pointer size 0)
;(pffi-pointer-set! pointer 'char size #\null)
(puts pointer)
(display " ::: ")
(write string-content)
(display " OTHER: ")
(display (strlen pointer))
(newline)
;(pointer-s8-set! pointer size (foreign-value "\0" char))
pointer)))
(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 strlen #f 'strlen 'int (list 'pointer))
(define pffi-pointer->string
(lambda (pointer)
(cond ((pffi-pointer? pointer)
(let* ((size (strlen pointer))
(string-content (make-string size)))
(display "STRLEN: ")
(display size)
(display " / ")
(display pointer)
;(move-memory! pointer string-content size)
(strncpy-pp (location string-content) pointer size)
(display " ::: ")
(write string-content)
(display " === ")
(puts pointer)
(newline)
string-content))
(error "pffi-pointer->string -- Argument not pointer " pointer))))
(foreign-lambda* c-string
((c-pointer p))
"C_return((char*)p);"))
(define-syntax pffi-shared-object-load
(er-macro-transformer
@ -226,7 +210,7 @@
((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) (char->integer value)))
((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
@ -248,7 +232,7 @@
((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
((equal? type 'char) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'char) (integer->char (pointer-s8-ref (pointer+ pointer offset))))
((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
@ -259,6 +243,3 @@
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset)))))))
(define pffi-pointer-deref
(lambda (pointer)
pointer))

293
retropikzel/r7rs-pffi/cyclone.scm
View File

@ -24,7 +24,7 @@
(define pffi-pointer?
(lambda (object)
(error "Not defined")))
(opaque? object)))
(define-syntax pffi-define
(er-macro-transformer
@ -65,6 +65,10 @@
`(c-define ,scheme-name
,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
(lambda (type)
(cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
@ -88,22 +92,24 @@
((equal? type 'pointer) (c-value "sizeof(void*)" int))
(else (error "pffi-size-of -- No such pffi type" type)))))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define-c pffi-pointer-allocate
"(void *data, int argc, closure _, object k, object size)"
"make_c_opaque(opq, malloc(obj_obj2int(size)));
return_closcall1(data, k, &opq);")
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
(make-opaque)))
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")
))
(define-c pffi-string->pointer
"(void *data, int argc, closure _, object k, object s)"
"make_c_opaque(opq, string_str(s));
return_closcall1(data, k, &opq);")
(define pffi-pointer->string
(lambda (pointer)
pointer))
(define-c pffi-pointer->string
"(void *data, int argc, closure _, object k, object p)"
"make_string(s, opaque_ptr(p));
return_closcall1(data, k, &s);")
(define-syntax pffi-shared-object-load
(er-macro-transformer
@ -114,27 +120,262 @@
`(include-c-header ,(string-append "<" header ">")))
(cdr (car (cdr expr))))))))
(define pffi-pointer-free
(lambda (pointer)
(error "Not defined")))
(define-c pffi-pointer-free
"(void *data, int argc, closure _, object k, object pointer)"
"free(opaque_ptr(pointer));
return_closcall1(data, k, make_boolean(boolean_t));")
(define pffi-pointer-null?
(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!
(lambda (pointer type offset value)
(let ((p pointer))
(error "Not defined"))))
(cond
((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
(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
(lambda (pointer)
(error "Not defined")))
(define pffi-define-callback
(lambda (scheme-name return-type argument-types procedure)
(error "pffi-define-callback not yet implemented on Cyclone")))
(define pffi-pointer-cast->struct
(lambda (struct-name pointer)
pointer))

70
retropikzel/r7rs-pffi/gambit.scm
View File

@ -1,38 +1,82 @@
(c-declare "#include <stdint.h>")
(define pffi-type->native-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?
(lambda (object)
(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)
(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
(lambda (type)
(error "Not defined")))
(cond ((equal? type 'int8) 1)
(else (error "pffi-size-of -- No such pffi type" type)))))
(define pffi-pointer-allocate
(lambda (size)
(error "Not defined")))
(define-syntax pffi-pointer-allocate
(syntax-rules
((pffi-pointer-allocate size)
(c-declare (string-append "malloc(" (number->string size) ")")))))
(define pffi-pointer-null
(lambda ()
(error "Not defined")))
(define-syntax pffi-pointer-null
(syntax-rules
((pffi-pointer-null)
(c-declare "NULL"))))
(define pffi-string->pointer
(lambda (string-content)
(error "Not defined")))
string-content))
(define pffi-pointer->string
(lambda (pointer)
pointer))
(define pffi-shared-object-load
(lambda (headers)
(error "Not defined")))
(define-syntax pffi-shared-object-load
(syntax-rules ()
((pffi-shared-object-load headers)
(c-declare (apply string-append
(map (lambda (header)
(string-append "#include <" header ">"))))))))
(define pffi-pointer-free
(lambda (pointer)

78
retropikzel/r7rs-pffi/guile.scm
View File

@ -79,50 +79,50 @@
(define pffi-pointer-set!
(lambda (pointer type offset value)
(let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-set! p offset value))
((equal? native-type uint8) (bytevector-u8-set! p offset value))
((equal? native-type int16) (bytevector-s16-set! p offset value (native-endianness)))
((equal? native-type uint16) (bytevector-u16-set! p offset value (native-endianness)))
((equal? native-type int32) (bytevector-s32-set! p offset value (native-endianness)))
((equal? native-type uint32) (bytevector-u32-set! p offset value (native-endianness)))
((equal? native-type int64) (bytevector-s64-set! p offset value (native-endianness)))
((equal? native-type uint64) (bytevector-u64-set! p offset value (native-endianness)))
((equal? native-type short) (bytevector-s8-set! p offset value))
((equal? native-type unsigned-short) (bytevector-u8-set! p offset value))
((equal? native-type int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type)))
((equal? native-type long) (bytevector-s64-set! p offset value (native-endianness)))
((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? native-type float) (bytevector-ieee-single-set! p offset value (native-endianness)))
((equal? native-type double) (bytevector-ieee-double-set! p offset value (native-endianness)))
(let ((p (pointer->bytevector pointer (+ offset 100))))
(cond ((equal? type 'int8) (bytevector-s8-set! p offset value))
((equal? type 'uint8) (bytevector-u8-set! p offset value))
((equal? type 'int16) (bytevector-s16-set! p offset value (native-endianness)))
((equal? type 'uint16) (bytevector-u16-set! p offset value (native-endianness)))
((equal? type 'int32) (bytevector-s32-set! p offset value (native-endianness)))
((equal? type 'uint32) (bytevector-u32-set! p offset value (native-endianness)))
((equal? type 'int64) (bytevector-s64-set! p offset value (native-endianness)))
((equal? type 'uint64) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
((equal? type 'short) (bytevector-s8-set! p offset value))
((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
((equal? type 'int) (bytevector-sint-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? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-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 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (pffi-size-of type)))))))
(define pffi-pointer-get
(lambda (pointer type offset)
(let ((p (pointer->bytevector pointer (+ offset 100)))
(native-type (pffi-type->native-type type)))
(cond ((equal? native-type int8) (bytevector-s8-ref p offset))
((equal? native-type uint8) (bytevector-u8-ref p offset))
((equal? native-type int16) (bytevector-s16-ref p offset (native-endianness)))
((equal? native-type uint16) (bytevector-u16-ref p offset (native-endianness)))
((equal? native-type int32) (bytevector-s32-ref p offset (native-endianness)))
((equal? native-type uint32) (bytevector-u32-ref p offset (native-endianness)))
((equal? native-type int64) (bytevector-s64-ref p offset (native-endianness)))
((equal? native-type uint64) (bytevector-u64-ref p offset (native-endianness)))
((equal? native-type short) (bytevector-s8-ref p offset))
((equal? native-type unsigned-short) (bytevector-u8-ref p offset))
((equal? native-type int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))
((equal? native-type unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type)))
((equal? native-type long) (bytevector-s64-ref p offset (native-endianness)))
((equal? native-type unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
((equal? native-type float) (bytevector-ieee-single-ref p offset (native-endianness)))
((equal? native-type double) (bytevector-ieee-double-ref p offset (native-endianness)))
(let ((p (pointer->bytevector pointer (+ offset 100))))
(cond ((equal? type 'int8) (bytevector-s8-ref p offset))
((equal? type 'uint8) (bytevector-u8-ref p offset))
((equal? type 'int16) (bytevector-s16-ref p offset (native-endianness)))
((equal? type 'uint16) (bytevector-u16-ref p offset (native-endianness)))
((equal? type 'int32) (bytevector-s32-ref p offset (native-endianness)))
((equal? type 'uint32) (bytevector-u32-ref p offset (native-endianness)))
((equal? type 'int64) (bytevector-s64-ref p offset (native-endianness)))
((equal? type 'uint64) (bytevector-u64-ref p offset (native-endianness)))
((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
((equal? type 'short) (bytevector-s8-ref p offset))
((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
((equal? type 'int) (bytevector-sint-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? type 'long) (bytevector-s64-ref p offset (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-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 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))))))))
(define pffi-pointer-deref
(lambda (pointer)
(dereference-pointer pointer)))
(define pffi-pointer-cast->struct
(lambda (struct-name pointer)
pointer))

22
retropikzel/r7rs-pffi/kawa.scm
View File

@ -1,4 +1,3 @@
(define arena (invoke-static java.lang.foreign.Arena 'global))
(define method-handle-lookup (invoke-static java.lang.invoke.MethodHandles 'lookup))
(define native-linker (invoke-static java.lang.foreign.Linker 'nativeLinker))
@ -9,10 +8,16 @@
(java.lang.Byte value))
((equal? type 'short)
(java.lang.Short value))
((equal? type 'unsigned-short)
(java.lang.Short value))
((equal? type 'int)
(java.lang.Integer value))
((equal? type 'unsigned-int)
(java.lang.Integer value))
((equal? type 'long)
(java.lang.Long value))
((equal? type 'unsigned-long)
(java.lang.Long value))
((equal? type 'float)
(java.lang.Float value))
((equal? type 'double)
@ -176,14 +181,17 @@
(define pffi-pointer-get
(lambda (pointer type offset)
(invoke (invoke pointer
'reinterpret
(static-field java.lang.Integer 'MAX_VALUE))
'get
(invoke (pffi-type->native-type type) 'withByteAlignment 1)
offset)))
(let ((r (invoke (invoke pointer 'reinterpret
(static-field java.lang.Integer 'MAX_VALUE))
'get
(invoke (pffi-type->native-type type) 'withByteAlignment 1)
offset)))
r)))
(define pffi-pointer-deref
(lambda (pointer)
(invoke pointer 'get (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1) 0)))
(define pffi-pointer-cast->struct
(lambda (struct-name pointer)
pointer))

153
retropikzel/r7rs-pffi/main.scm
View File

@ -1,31 +1,6 @@
(define pffi-os-name
(cond-expand
(windows "windows")
(racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
(else "unix")))
(define-syntax pffi-init
(syntax-rules ()
((pffi-init)
(cond-expand
(chicken (import (chicken foreign)))
(else #t)))))
(define library-version "v0-3-0")
(define slash (cond-expand (windows (string #\\)) (else "/")))
(define platform-file-extension
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
(windows ".dll")
(else ".so")))
(define platform-lib-prefix
(cond-expand
(racket (if (equal? (system-type 'os) 'windows) "" "lib"))
(windows "")
(else "lib")))
(cond-expand
(chicken #t)
(else (define pffi-init (lambda () #t))))
(define pffi-types
'(int8
@ -67,59 +42,6 @@
(for-each splitter str-l)
res)))
(define auto-load-paths
(if (string=? pffi-os-name "windows")
(append
(if (get-environment-variable "SYSTEM")
(list (get-environment-variable "SYSTEM"))
(list))
(if (get-environment-variable "WINDIR")
(list (get-environment-variable "WINDIR"))
(list))
(if (get-environment-variable "WINEDLLDIR0")
(list (get-environment-variable "WINEDLLDIR0"))
(list))
(if (get-environment-variable "SystemRoot")
(list (string-append
(get-environment-variable "SystemRoot")
slash
"system32"))
(list))
(list ".")
(if (get-environment-variable "PATH")
(string-split (get-environment-variable "PATH") #\;)
(list))
(if (get-environment-variable "PWD")
(list (get-environment-variable "PWD"))
(list)))
(append
; Guix
(list (if (get-environment-variable "GUIX_ENVIRONMENT")
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
"")
"/run/current-system/profile/lib")
; Debian
(if (get-environment-variable "LD_LIBRARY_PATH")
(string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
(list))
(list
;;; x86-64
; Debian
"/lib/x86_64-linux-gnu"
"/usr/lib/x86_64-linux-gnu"
"/usr/local/lib"
; Fedora/Alpine
"/usr/lib"
"/usr/lib64"
;;; aarch64
; Debian
"/lib/aarch64-linux-gnu"
"/usr/lib/aarch64-linux-gnu"
"/usr/local/lib"
; Fedora/Alpine
"/usr/lib"
"/usr/lib64"
))))
(define auto-load-versions (list ""))
@ -131,8 +53,75 @@
(chicken (pffi-shared-object-load headers))
(gambit (pffi-shared-object-load headers))
(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))
(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))
(for-each
(lambda (path)

198
retropikzel/r7rs-pffi/racket.scm
View File

@ -1,120 +1,106 @@
(define-library
(retropikzel r7rs-pffi version racket)
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(compatibility mlist)
(only (racket base) system-type)
(ffi unsafe)
(ffi vector))
(export pffi-shared-object-load
pffi-define
pffi-define-callback
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
pffi-string->pointer
pffi-pointer->string
pffi-pointer-free
pffi-pointer?
pffi-pointer-null?
pffi-pointer-set!
pffi-pointer-get
pffi-pointer-deref)
(begin
(define pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8)
((equal? type 'int16) _int16)
((equal? type 'uint16) _uint16)
((equal? type 'int32) _int32)
((equal? type 'uint32) _uint32)
((equal? type 'int64) _int64)
((equal? type 'uint64) _uint64)
((equal? type 'char) _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-type->native-type
(lambda (type)
(cond ((equal? type 'int8) _int8)
((equal? type 'uint8) _uint8)
((equal? type 'int16) _int16)
((equal? type 'uint16) _uint16)
((equal? type 'int32) _int32)
((equal? type 'uint32) _uint32)
((equal? type 'int64) _int64)
((equal? type 'uint64) _uint64)
((equal? type 'char) _int8)
((equal? type 'unsigned-char) _uint8)
((equal? type 'short) _short)
((equal? type 'unsigned-short) _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?
(lambda (object)
(cpointer? object)))
(define pffi-pointer?
(lambda (object)
(cpointer? object)))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(get-ffi-obj c-name
shared-object
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))))))
(define-syntax pffi-define
(syntax-rules ()
((pffi-define scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(get-ffi-obj c-name
shared-object
(_cprocedure (mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))))))
(define-syntax pffi-define-callback
(syntax-rules ()
((pffi-define-callback scheme-name return-type argument-types procedure)
(define scheme-name (function-ptr procedure
(_cprocedure
(mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))))))
(define-syntax pffi-define-callback
(syntax-rules ()
((pffi-define-callback scheme-name return-type argument-types procedure)
(define scheme-name (function-ptr procedure
(_cprocedure
(mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type)))))))
(define pffi-size-of
(lambda (type)
(ctype-sizeof (pffi-type->native-type type))))
(define pffi-size-of
(lambda (type)
(ctype-sizeof (pffi-type->native-type type))))
(define pffi-pointer-allocate
(lambda (size)
(malloc 'raw size)))
(define pffi-pointer-allocate
(lambda (size)
(malloc 'raw size)))
(define pffi-pointer-null
(lambda ()
#f )) ; #f is the null pointer on racket
(define pffi-pointer-null
(lambda ()
#f )) ; #f is the null pointer on racket
(define pffi-string->pointer
(lambda (string-content)
(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
(lambda (string-content)
(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-pointer->string
(lambda (pointer)
(when (pffi-pointer-null? pointer)
(error "Can not make string from null pointer" pointer))
(string-copy (cast pointer _pointer _string))))
(define pffi-pointer->string
(lambda (pointer)
(when (pffi-pointer-null? pointer)
(error "Can not make string from null pointer" pointer))
(string-copy (cast pointer _pointer _string))))
(define pffi-shared-object-load
(lambda (header path)
(ffi-lib path)))
(define pffi-shared-object-load
(lambda (header path)
(ffi-lib path)))
(define pffi-pointer-free
(lambda (pointer)
(free pointer)))
(define pffi-pointer-free
(lambda (pointer)
(free pointer)))
(define pffi-pointer-null?
(lambda (pointer)
(not pointer))) ; #f is the null pointer on racket
(define pffi-pointer-null?
(lambda (pointer)
(not pointer))) ; #f is the null pointer on racket
(define pffi-pointer-set!
(lambda (pointer type offset value)
(ptr-set! pointer
(pffi-type->native-type type)
'abs
offset
(if (equal? type 'char)
(char->integer value)
value))))
(define pffi-pointer-set!
(lambda (pointer type offset value)
(ptr-set! pointer (pffi-type->native-type type) 'abs offset value)))
(define pffi-pointer-get
(lambda (pointer type offset)
(let ((r (ptr-ref pointer
(pffi-type->native-type type)
'abs
offset)))
(if (equal? type 'char)
(integer->char r)
r))))
(define pffi-pointer-get
(lambda (pointer type offset)
(ptr-ref pointer (pffi-type->native-type type) 'abs offset)))
(define pffi-pointer-deref
(lambda (pointer)
pointer))))
(define pffi-pointer-cast->struct
(lambda (struct-name pointer)
pointer))

31
retropikzel/r7rs-pffi/sagittarius.scm
View File

@ -19,6 +19,7 @@
((equal? type 'float) 'float)
((equal? type 'double) 'double)
((equal? type 'pointer) 'void*)
((equal? type 'string) 'string)
((equal? type 'void) 'void)
((equal? type 'callback) 'callback)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
@ -74,17 +75,25 @@
(define pffi-pointer-null
(lambda ()
null-pointer))
(empty-pointer)))
(define pffi-string->pointer
(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
(lambda (pointer)
(if (string? pointer)
pointer
(pointer->string pointer))))
(pointer->string pointer)))
(define pffi-shared-object-load
(lambda (header path)
@ -109,7 +118,7 @@
((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset value))
((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
((equal? type 'short) (pointer-set-c-short! pointer offset value))
((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
((equal? type 'int) (pointer-set-c-int! pointer offset value))
@ -118,7 +127,7 @@
((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
((equal? type 'float) (pointer-set-c-float! pointer offset value))
((equal? type 'double) (pointer-set-c-double! pointer offset value))
((equal? type 'void*) (pointer-set-c-pointer! pointer offset value))
((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
(define pffi-pointer-get
@ -131,7 +140,7 @@
((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
((equal? type 'char) (pointer-ref-c-char pointer offset))
((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset)))
((equal? type 'short) (pointer-ref-c-short pointer offset))
((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
((equal? type 'int) (pointer-ref-c-int pointer offset))
@ -143,6 +152,6 @@
((equal? type 'void) (pointer-ref-c-pointer pointer offset))
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define pffi-pointer-deref
(lambda (pointer)
(deref pointer 0)))
(define pffi-pointer-cast->struct
(lambda (struct-name pointer)
pointer))

50
retropikzel/r7rs-pffi/stklos.scm
View File

@ -37,14 +37,36 @@
(pffi-type->native-type return-type)
shared-object)))))
(define pffi-define-callback
(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
(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
(lambda (size)
@ -52,7 +74,9 @@
(define pffi-pointer-null
(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
(lambda (string-content)
@ -60,7 +84,9 @@
(define pffi-pointer->string
(lambda (pointer)
pointer))
(if (string? pointer)
pointer
(cpointer->string pointer))))
(define pffi-shared-object-load
(lambda (header path)
@ -72,11 +98,21 @@
(define pffi-pointer-null?
(lambda (pointer)
(cpointer-null? pointer)))
(and (cpointer? pointer)
(cpointer-null? pointer))))
(define pffi-pointer-set!
(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
(lambda (pointer type offset)

33
scheme_runner
View File

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

BIN
test
View File

Binary file not shown.

179
test.scm
View File

@ -1,6 +1,6 @@
(import (scheme base)
(scheme write)
(scheme load)
(scheme char)
(scheme process-context)
(retropikzel r7rs-pffi))
@ -47,6 +47,12 @@
(write value)
(newline)))))
;; pffi-init
(print-header 'pffi-init)
(pffi-init)
;; pffi-size-of
(print-header 'pffi-size-of)
@ -162,55 +168,16 @@
(assert equal? (number? size-pointer) #t)
(assert = size-pointer 8)
;; pffi-init
(print-header 'pffi-init)
(pffi-init)
;; pffi-shared-object-auto-load
(print-header 'pffi-shared-object-auto-load)
(define libc-stdlib
(if (string=? pffi-os-name "windows")
(pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))
(pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6"))))
(cond-expand
(windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list "")))
(else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6")))))
;; 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)
;; 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)
(debug libc-stdlib)
;; pffi-pointer-null
@ -220,14 +187,24 @@
(debug null-pointer)
(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))
(debug pointer-to-be-freed)
(pffi-pointer-free pointer-to-be-freed)
(debug pointer-to-be-freed)
(define is-null-pointer (pffi-pointer-null))
(debug is-null-pointer)
(assert equal? (pffi-pointer-null? is-null-pointer) #t)
(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?
@ -239,22 +216,18 @@
(assert equal? (pffi-pointer? 100) #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))
(debug is-null-pointer)
(define is-not-null-pointer (pffi-pointer-allocate 100))
(debug is-not-null-pointer)
(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)
(define pointer-to-be-freed (pffi-pointer-allocate 100))
(debug pointer-to-be-freed)
(pffi-pointer-free pointer-to-be-freed)
(debug pointer-to-be-freed)
;; 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 offset 50)
@ -285,6 +258,10 @@
(test-type '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)
(debug (pffi-pointer-get set-pointer 'float offset))
(assert = (pffi-pointer-get set-pointer 'float offset) 1.5)
@ -292,9 +269,66 @@
(debug (pffi-pointer-get set-pointer 'double offset))
(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"))
(debug pointer-to-be-set)
(debug (pffi-pointer->string pointer-to-be-set))
(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set)
(debug (pffi-pointer-get set-pointer 'pointer offset))
(assert equal?
(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))
(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
(print-header 'pffi-define)
(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
(assert = (atoi (pffi-string->pointer "100")) 100)
@ -375,3 +391,4 @@
(newline)
(exit 0)
|#