diff --git a/Dockerfile b/Dockerfile index 632b8de..6f730cd 100644 --- a/Dockerfile +++ b/Dockerfile @@ -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 diff --git a/Jenkinsfile b/Jenkinsfile index 42b8168..b9964cd 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -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' } } } diff --git a/Makefile b/Makefile index 16f549e..4fa067d 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README.md b/README.md index 95188ea..688fd45 100644 --- a/README.md +++ b/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/. -[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 diff --git a/curl.dll b/curl.dll deleted file mode 100755 index 094e776..0000000 Binary files a/curl.dll and /dev/null differ diff --git a/docs/reference.md b/docs/reference.md index 8954114..1b6d6cc 100644 --- a/docs/reference.md +++ b/docs/reference.md @@ -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 diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index a16f4cc..5e9843d 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -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"))))) diff --git a/retropikzel/r7rs-pffi/chicken.scm b/retropikzel/r7rs-pffi/chicken.scm index ddeca9e..42f9332 100644 --- a/retropikzel/r7rs-pffi/chicken.scm +++ b/retropikzel/r7rs-pffi/chicken.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 (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)) diff --git a/retropikzel/r7rs-pffi/cyclone.scm b/retropikzel/r7rs-pffi/cyclone.scm index 84ed081..d24b485 100644 --- a/retropikzel/r7rs-pffi/cyclone.scm +++ b/retropikzel/r7rs-pffi/cyclone.scm @@ -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)) diff --git a/retropikzel/r7rs-pffi/gambit.scm b/retropikzel/r7rs-pffi/gambit.scm index 337f795..7dba5bf 100644 --- a/retropikzel/r7rs-pffi/gambit.scm +++ b/retropikzel/r7rs-pffi/gambit.scm @@ -1,38 +1,82 @@ + +(c-declare "#include ") + (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) diff --git a/retropikzel/r7rs-pffi/guile.scm b/retropikzel/r7rs-pffi/guile.scm index b287e2d..2a7a9e2 100644 --- a/retropikzel/r7rs-pffi/guile.scm +++ b/retropikzel/r7rs-pffi/guile.scm @@ -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)) diff --git a/retropikzel/r7rs-pffi/kawa.scm b/retropikzel/r7rs-pffi/kawa.scm index d91d6f3..ea81f88 100644 --- a/retropikzel/r7rs-pffi/kawa.scm +++ b/retropikzel/r7rs-pffi/kawa.scm @@ -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)) diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index 056b6fd..30498b7 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -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) diff --git a/retropikzel/r7rs-pffi/racket.scm b/retropikzel/r7rs-pffi/racket.scm index 4a22788..6a868ca 100644 --- a/retropikzel/r7rs-pffi/racket.scm +++ b/retropikzel/r7rs-pffi/racket.scm @@ -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)) diff --git a/retropikzel/r7rs-pffi/sagittarius.scm b/retropikzel/r7rs-pffi/sagittarius.scm index 9fdb604..71b3ef0 100644 --- a/retropikzel/r7rs-pffi/sagittarius.scm +++ b/retropikzel/r7rs-pffi/sagittarius.scm @@ -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)) diff --git a/retropikzel/r7rs-pffi/stklos.scm b/retropikzel/r7rs-pffi/stklos.scm index fc2a270..2e04e8e 100644 --- a/retropikzel/r7rs-pffi/stklos.scm +++ b/retropikzel/r7rs-pffi/stklos.scm @@ -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) diff --git a/scheme_runner b/scheme_runner deleted file mode 100755 index 1b3b665..0000000 --- a/scheme_runner +++ /dev/null @@ -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 diff --git a/test b/test index 63420f8..094f7f8 100755 Binary files a/test and b/test differ diff --git a/test.scm b/test.scm index 55e560d..1ecd9ba 100644 --- a/test.scm +++ b/test.scm @@ -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) +|#