diff --git a/.gitignore b/.gitignore index 33b5b42..f74fe51 100644 --- a/.gitignore +++ b/.gitignore @@ -40,3 +40,4 @@ dockerfiles/build core testfile.test tests/compliance +tests/retropikzel diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..f6c79fd --- /dev/null +++ b/Dockerfile @@ -0,0 +1,12 @@ +ARG COMPILE_R7RS=chibi +FROM debian:bookworm AS build +RUN apt-get update && apt-get install -y build-essential wget make cmake libgc-dev zlib1g-dev libffi-dev libssl-dev +RUN wget https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.12.tar.gz && tar -xf sagittarius-0.9.12.tar.gz +RUN cd sagittarius-0.9.12 && mkdir build && cd build && cmake -DCMAKE_INSTALL_PREFIX=/usr/local-other .. && make && make install + +FROM schemers/${COMPILE_R7RS} +RUN apt-get update && apt-get install -y \ + git make libffi8 libgc1 libssl3 libuv1 build-essential libffi-dev +COPY --from=build /usr/local-other/ /usr/local-other/ +ENV PATH=${PATH}:/usr/local-other/bin +RUN git clone https://git.sr.ht/~retropikzel/compile-r7rs && cd compile-r7rs && make && make install diff --git a/Jenkinsfile b/Jenkinsfile index 619a4db..4420c5b 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -1,21 +1,16 @@ pipeline { - agent { - dockerfile { - filename 'dockerfiles/jenkins' - dir '.' - args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock' - } - } + agent any options { - buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10')) + disableConcurrentBuilds() + buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10')) } stages { - stage('Build test libraries') { + stage('Chibi') { steps { catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { - sh 'make libtest.so libtest.a' + sh 'make COMPILE_R7RS=chibi test-compile-r7rs-docker' } } } diff --git a/Makefile b/Makefile index 4539e7a..b1a0c79 100644 --- a/Makefile +++ b/Makefile @@ -4,8 +4,6 @@ DOCKER=docker run -it -v ${PWD}:/workdir DOCKER_INIT=cd /workdir && make clean && VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}') -all: chibi gauche tests/libtest.so libtest.o libtest.a - # apt-get install pandoc weasyprint docs: mkdir -p documentation @@ -19,44 +17,120 @@ docs: README.md chibi: - make -C retropikzel/pffi chibi-pffi.so + make -C retropikzel/pffi chibi + +chicken: + make -C retropikzel/pffi chicken + +cyclone: + make -C retropikzel/pffi cyclone + +gambit: + make -C retropikzel/pffi gambit gauche: - make -C retropikzel/pffi gauche-pffi.so + make -C retropikzel/pffi gauche -jenkinsfile: - gosh -r7 -I ./snow build.scm +gerbil: + make -C retropikzel/pffi gerbil -libtest.o: src/libtest.c - ${CC} -o libtest.o -fPIC -c src/libtest.c -I./include +guile: + make -C retropikzel/pffi guile -tests/libtest.so: src/libtest.c - ${CC} -o tests/libtest.so -shared -fPIC src/libtest.c -I./include +kawa: + make -C retropikzel/pffi kawa -libtest.a: libtest.o src/libtest.c - ar rcs libtest.a libtest.o +larceny: + make -C retropikzel/pffi larceny -test-interpreter-compliance: tests/libtest.so - SCHEME=${SCHEME} script-r7rs -I . -I .. tests/compliance.scm +mosh: + make -C retropikzel/pffi mosh -test-interpreter-compliance-docker: - docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} - docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . -I .. tests/compliance.scm" +racket: + make -C retropikzel/pffi racket -test-compile-library: tests/libtest.so libtest.a libtest.o - SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld +sagittarius: + make -C retropikzel/pffi sagittarius -test-compiler-compliance-compile: test-compile-library - SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest -L." compile-r7rs -I . tests/compliance.scm - ./tests/compliance +skint: + make -C retropikzel/pffi skint -test-compiler-compliance: test-compiler-compliance-compile - ./tests/compliance +stklos: + make -C retropikzel/pffi stklos -test-compiler-compliance-docker: tests/libtest.so libtest.a - docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} - docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld" - docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . compliance.scm && ./test" +tr7: + make -C retropikzel/pffi tr7 + +ypsilon: + make -C retropikzel/pffi tr7 + +test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so + make ${COMPILE_R7RS} + cp -r retropikzel tmp/test/ + cp tests/compliance.scm tmp/test/ + cp include/libtest.h tmp/test/ + cd tmp/test && COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." compile-r7rs -I . -o compliance compliance.scm + cd tmp/test && LD_LIBRARY_PATH=. ./compliance + +test-compile-r7rs-docker: + docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=r7rs-pffi-test-${COMPILE_R7RS} . + docker run -v "${PWD}":/workdir -w /workdir -t r7rs-pffi-test-${COMPILE_R7RS} sh -c "make COMPILE_R7RS=${COMPILE_R7RS} test-compile-r7rs" + +#chicken-objects: + #cd chicken/src && gcc -Os -fomit-frame-pointer -DHAVE_CHICKEN_CONFIG_H -c *.c -I../include + +#test-chicken-c: libtest.o + #csc -R r7rs -X r7rs -t -J -I ./retropikzel retropikzel/pffi.sld -o retropikzel.pffi.c + #csc -R r7rs -X r7rs -t tests/compliance.scm -o tests/compliance.c + #gcc -Os -fomit-frame-pointer -DHAVE_CHICKEN_CONFIG_H -o tests/compliance chicken/src/*.o tests/compliance.c -ltest -L. -I./include -I./chicken/include + +#test-chicken: libtest.o + #csc -R r7rs -X r7rs -c -J -I ./retropikzel retropikzel/pffi.sld -o retropikzel.pffi.o + #csc -v -R r7rs -X r7rs -static tests/compliance.scm -o tests/compliance -C -ltest -I./include + #csc -R r7rs -X r7rs -J -t -I ./retropikzel retropikzel/pffi.sld + #csc -R r7rs -X r7rs -uses retropikzel.pffi -static tests/compliance.scm -L -ltest -L. -I./include -L./retropikzel + #csc -R r7rs -X r7rs -t -I ./retropikzel retropikzel/pffi.sld -o retropikzel/pffi.c + #cp retropikzel/pffi.sld retropikzel.pffi.scm + #csc -J -t -I ./retropikzel retropikzel/pffi.sld -o retropikzel/pffi.c + #csc -R r7rs -X r7rs -t -I retropikzel retropikzel/pffi.sld tests/compliance.scm -optimize-level 3 -o tests/compliance.c + #csc -t tests/compliance.scm -o tests/compliance.c #-L -ltest -I./include -L. -L./tests + #./tests/compliance + +#jenkinsfile: + #gosh -r7 -I ./snow build.scm + +tmp/test/libtest.o: src/libtest.c + mkdir -p tmp/test + ${CC} -o tmp/test/libtest.o -fPIC -c src/libtest.c -I./include + +tmp/test/libtest.so: src/libtest.c + mkdir -p tmp/test + ${CC} -o tmp/test/libtest.so -shared -fPIC src/libtest.c -I./include + +tmp/test/libtest.a: tmp/test/libtest.o src/libtest.c + ar rcs tmp/test/libtest.a tmp/test/libtest.o + +#test-interpreter-compliance: tests/libtest.so + #SCHEME=${SCHEME} script-r7rs -I . -I .. tests/compliance.scm + +#test-interpreter-compliance-docker: + #docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} + #docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} script-r7rs -I . -I .. tests/compliance.scm" + +#test-compile-library: tests/libtest.so libtest.a libtest.o + #SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld + +#test-compiler-compliance-compile: test-compile-library + #SCHEME=${SCHEME} CFLAGS="-I./include -L." LDFLAGS="-ltest -L." compile-r7rs -I . tests/compliance.scm + #./tests/compliance + +#test-compiler-compliance: test-compiler-compliance-compile + #./tests/compliance + +#test-compiler-compliance-docker: tests/libtest.so libtest.a + #docker build -f dockerfiles/test . --build-arg SCHEME=${SCHEME} --tag=pffi-${SCHEME} + #docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs-library retropikzel/pffi.sld" + #docker run -v ${PWD}:/workdir pffi-${SCHEME} bash -c "cd /workdir && SCHEME=${SCHEME} compile-r7rs -I . compliance.scm && ./test" clean: @rm -rf retropikzel/pffi/*.o* @@ -79,7 +153,9 @@ clean: find . -name "core.1" -delete find . -name "*@gambit*" -delete rm -rf retropikzel/pffi.c - rm -rf tests/compliance.c + rm -rf tests/compliance.c* rm -rf tests/compliance.o rm -rf tests/compliance.so rm -rf tests/compliance + rm -rf tests/retropikzel.*.import.scm + rm -rf tmp diff --git a/README.md b/README.md index 1cb6015..e4ba2ae 100644 --- a/README.md +++ b/README.md @@ -30,17 +30,21 @@ conforming to some specification. - [Primitives](#feature-implementation-table-primitives) - [Built upon](#feature-implementation-table-built-upon) - [Documentation](#documentation) - - [Installation](#installation) - - [Compiling the library](#compiling-the-library) - - [Chibi](#compiling-the-library-chibi) - - [Gauche](#compiling-the-library-gauche) - [Dependencies](#dependencies) - [Chibi](#dependencies-chibi) + - [Chicken](#dependencies-chicken) - [Gauche](#dependencies-gauche) - [Racket](#dependencies-racket) - [Kawa](#dependencies-kawa) + - [Installation](#installation) + - [Project local](#installation-project-local) + - [Linux](#installation-project-local-linux) + - [Windows](#installation-project-local-windows) + - [System global](#installation-system-global) - [Reference](#reference) - [Types](#types) + - [Environment variables](#environment-variables) + - [PFFI\_LOAD\_PATH](#environment-variables-pffi-load-path) - [Procedures and macros](#procedures-and-macros) - [pffi-init](#pffi-init) - [pffi-size-of](#pffi-size-of) @@ -194,31 +198,7 @@ and work, they should work too. ## Documentation -### Installation - - -Download the latest release from -[https://git.sr.ht/~retropikzel/r7rs-pffi/refs](https://git.sr.ht/~retropikzel/r7rs-pffi/refs). - -Unpack it somewhere and copy the directory called "retropikzel" to your projects -library directory. For the rest of this documentation it is assumed to be ./snow. - -#### Compiling the libary - -Some implementations need extra step of compiling the library. Change directory -to ./snow/retropikzel/pffi and run command corresponding to your implementation. - -##### Chibi - - - make -C ./snow/retropikzel/pffi chibi-pffi.so - -##### Gauche - - - make -C ./snow/retropikzel/pffi gauche-pffi.so - -#### Dependencies +### Dependencies Some implementations have extra dependencies/requirements beyond just the @@ -233,6 +213,13 @@ Debian/Ubuntu/Mint install with: apt install libffi-dev +#### Chicken + + +Chicken needs r7rs egg installed. Install it with: + + chicken-install r7rs + #### Gauche @@ -259,6 +246,37 @@ Kawa Needs at least Java version 22 and jvm flags: - \--add-exports java.base/jdk.internal.foreign=ALL-UNNAMED - \--enable-native-access=ALL-UNNAMED +### Installation + + +Since the project is under active development is best to clone it from git, + +### Project local + + +#### Linux + +Assuming you have a project and your libraries live in directory called snow +in it: + + git clone https://git.sr.ht/~retropikzel/r7rs-pffi + mkdir -p snow + cp -r r7rs-pffi/retropikzel snow/ + cd snow/retropikzel/pffi + make + +#### Windows + + +There is no build scripts yet for Windows, that said many implementations work +without compiling anything. If you run this and it says "There is notching to +build for SCHEME" then you should be good to go. + +### System global + + +Still work in progress. + ## Reference @@ -289,6 +307,22 @@ Types are given as symbols, for example 'int8 or 'pointer. - callback - Callback function +### Types + + +### Environment variables + + +Setting environment variables like this on Windows works for this library: + + set "PFFI_LOAD_PATH=C:\Program Files (x86)/foo/bar" + +#### PFFI\_LOAD\_PATH + + +To add more paths to where pffi looks for libraries set PFFI\_LOAD\_PATH to +paths separated by ; on windows, and : on other operating systems. + ### Procedures and macros diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 77e8c15..9f8752d 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -59,7 +59,8 @@ (scheme process-context) (rnrs bytevectors) (system foreign) - (system foreign-library))) + (system foreign-library) + (only (guile) include-from-path))) (kawa (import (scheme base) (scheme write) @@ -133,8 +134,7 @@ (scheme process-context) (ypsilon c-ffi) (ypsilon c-types) - (only (core) define-macro syntax-case))) - (else (error "Unsupported implementation"))) + (only (core) define-macro syntax-case)))) (export pffi-init pffi-size-of pffi-type? @@ -167,7 +167,8 @@ pffi-define-callback) (cond-expand (chibi (include "pffi/chibi.scm")) - (chicken (include-relative "pffi/chicken.scm")) + (chicken-5 (include "pffi/chicken.scm")) + (chicken-6 (include-relative "pffi/chicken.scm")) (cyclone (include "pffi/cyclone.scm")) (gambit (include "pffi/gambit.scm")) (gauche (include "pffi/gauche.scm")) @@ -183,7 +184,12 @@ (tr7 (include "pffi/tr7.scm")) (ypsilon (include "pffi/ypsilon.scm"))) ;(include "pffi/shared/union.scm") - (include "pffi/shared/main.scm") - (include "pffi/shared/pointer.scm") - (include "pffi/shared/array.scm") - (include "pffi/shared/struct.scm")) + (cond-expand + (chicken-6 (include-relative "pffi/shared/main.scm") + (include-relative "pffi/shared/pointer.scm") + (include-relative "pffi/shared/array.scm") + (include-relative "pffi/shared/struct.scm")) + (else (include "pffi/shared/main.scm") + (include "pffi/shared/pointer.scm") + (include "pffi/shared/array.scm") + (include "pffi/shared/struct.scm")))) diff --git a/retropikzel/pffi/Makefile b/retropikzel/pffi/Makefile index 1cb9662..c9f6bde 100644 --- a/retropikzel/pffi/Makefile +++ b/retropikzel/pffi/Makefile @@ -1,13 +1,55 @@ CC=gcc -chibi-pffi.so: chibi/pffi.stub - chibi-ffi chibi/pffi.stub - ${CC} -g3 -o chibi-pffi.so chibi/pffi.c -fPIC -lffi -shared +chibi: chibi-src/pffi.stub + chibi-ffi chibi-src/pffi.stub + ${CC} -g3 -o chibi-pffi.so chibi-src/pffi.c -fPIC -lffi -shared -gauche-pffi.so: +chicken: + @echo "Nothing to build for Chicken" + +cyclone: + @echo "Nothing to build for Cyclone" + +gambit: + @echo "Nothing to build for Gambit" + +gauche: gauche-src/gauche-pffi.c gauche-src/gauchelib.scm gauche-package compile \ - --srcdir=gauche \ + --srcdir=gauche-src \ --cc=${CC} \ --cflags="-I./include" \ --libs=-lffi \ gauche-pffi gauche-pffi.c gauchelib.scm + +gerbil: + @echo "Nothing to build for Gerbil" + +guile: + @echo "Nothing to build for Guile" + +kawa: + @echo "Nothing to build for Kawa" + +larceny: + @echo "Nothing to build for Larceny" + +mosh: + @echo "Nothing to build for Mosh" + +racket: + @echo "Nothing to build for Racket" + +sagittarius: + @echo "Nothing to build for Sagittarius" + +skint: + @echo "Nothing to build for Skint" + +stklos: + @echo "Nothing to build for Stklos" + +tr7: + @echo "Nothing to build for tr7" + +ypsilon: + @echo "Nothing to build for Ypsilon" diff --git a/retropikzel/pffi/chibi/pffi.stub b/retropikzel/pffi/chibi-src/pffi.stub similarity index 100% rename from retropikzel/pffi/chibi/pffi.stub rename to retropikzel/pffi/chibi-src/pffi.stub diff --git a/retropikzel/pffi/gauche/gauchelib.scm b/retropikzel/pffi/gauche-src/gauchelib.scm similarity index 100% rename from retropikzel/pffi/gauche/gauchelib.scm rename to retropikzel/pffi/gauche-src/gauchelib.scm diff --git a/retropikzel/pffi/guile.scm b/retropikzel/pffi/guile.scm index 68eb76c..e6927c4 100644 --- a/retropikzel/pffi/guile.scm +++ b/retropikzel/pffi/guile.scm @@ -53,7 +53,7 @@ (native-type (sizeof native-type)) (else #f))))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (bytevector->pointer (make-bytevector size 0)))) @@ -74,10 +74,10 @@ (pointer->string pointer))) (define pffi-shared-object-load - (lambda (header path . options) + (lambda (path options) (load-foreign-library path))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) #t)) @@ -132,6 +132,6 @@ ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))) ((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))))))) -(define pffi-struct-dereference +#;(define pffi-struct-dereference (lambda (struct) (dereference-pointer (pffi-struct-pointer struct)))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index aae7e79..986ce39 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -121,61 +121,67 @@ (list))) (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 + (cond-expand + (windows + (append + (if (get-environment-variable "PFFI_LOAD_PATH") + (string-split (get-environment-variable "PFFI_LOAD_PATH") #\;) + (list)) + (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 + (if (get-environment-variable "PFFI_LOAD_PATH") + (string-split (get-environment-variable "PFFI_LOAD_PATH") #\:) + (list)) + ; Guix + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") + "") + "/run/current-system/profile/lib") ; 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" - ; NetBSD - "/usr/pkg/lib"))))) + (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" + ; NetBSD + "/usr/pkg/lib"))))) (auto-load-versions (list "")) (paths (append auto-load-paths additional-paths)) (versions (append additional-versions auto-load-versions)) diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm index 5e490e7..069fa83 100644 --- a/retropikzel/pffi/shared/pointer.scm +++ b/retropikzel/pffi/shared/pointer.scm @@ -12,7 +12,7 @@ (chibi #t) ; FIXME (else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int)))) -(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int)) +;(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int)) (pffi-define pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int)) (cond-expand diff --git a/retropikzel/pffi/shared/struct.scm b/retropikzel/pffi/shared/struct.scm index 22a433f..01938a5 100644 --- a/retropikzel/pffi/shared/struct.scm +++ b/retropikzel/pffi/shared/struct.scm @@ -52,7 +52,7 @@ (define round-to-next-modulo-of (lambda (to-round roundee) - (if (= (floor-remainder to-round roundee) 0) + (if (= (modulo to-round roundee) 0) to-round (round-to-next-modulo-of (+ to-round 1) roundee)))) @@ -67,7 +67,7 @@ (when (> (size-of-type type) largest-member-size) (set! largest-member-size (size-of-type type))) (if (or (= size 0) - (= (floor-remainder size type-alignment) 0)) + (= (modulo size type-alignment) 0)) (begin (set! size (+ size type-alignment)) (list name type (- size type-alignment))) diff --git a/tests/compliance.scm b/tests/compliance.scm index 459fc10..68a1a8d 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -922,25 +922,25 @@ ;; pffi-struct-dereference 1 -(print-header "pffi-struct-dereference 1") -(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color))) -(pffi-define-struct make-struct-color 'color '((int8 . r) +;(print-header "pffi-struct-dereference 1") +;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color))) +#;(pffi-define-struct make-struct-color 'color '((int8 . r) (int8 . g) (int8 . b) (int8 . a))) -(define struct-color (make-struct-color)) -(debug (pffi-struct-set! struct-color 'r 100)) -(debug (pffi-struct-set! struct-color 'g 101)) -(debug (pffi-struct-set! struct-color 'b 102)) -(debug (pffi-struct-set! struct-color 'a 103)) -(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0) +;(define struct-color (make-struct-color)) +;(debug (pffi-struct-set! struct-color 'r 100)) +;(debug (pffi-struct-set! struct-color 'g 101)) +;(debug (pffi-struct-set! struct-color 'b 102)) +;(debug (pffi-struct-set! struct-color 'a 103)) +;(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0) (exit 0) -(print-header "pffi-struct-dereference 2") +;(print-header "pffi-struct-dereference 2") -(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test))) -(pffi-define-struct make-struct-test-dereference2 +;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test))) +#;(pffi-define-struct make-struct-test-dereference2 'test '((int8 . a) (char . b) @@ -956,36 +956,36 @@ (int . l) (double . m) (float . n))) -(define struct-test3 (make-struct-test-dereference2)) -(debug (pffi-struct-set! struct-test3 'a 1)) -(debug (pffi-struct-set! struct-test3 'b #\b)) -(debug (pffi-struct-set! struct-test3 'c 3.0)) -(debug (pffi-struct-set! struct-test3 'd #\d)) -(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) -(debug (pffi-struct-set! struct-test3 'f 6.0)) -(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) -(debug (pffi-struct-set! struct-test3 'h 8)) -(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) -(debug (pffi-struct-set! struct-test3 'j 10)) -(debug (pffi-struct-set! struct-test3 'k 11)) -(debug (pffi-struct-set! struct-test3 'l 12)) -(debug (pffi-struct-set! struct-test3 'm 13.0)) -(debug (pffi-struct-set! struct-test3 'n 14.0)) -(debug (pffi-struct-get struct-test3 'a)) -(debug (pffi-struct-get struct-test3 'b)) -(debug (pffi-struct-get struct-test3 'c)) -(debug (pffi-struct-get struct-test3 'd)) -(debug (pffi-struct-get struct-test3 'e)) -(debug (pffi-struct-get struct-test3 'f)) -(debug (pffi-struct-get struct-test3 'g)) -(debug (pffi-struct-get struct-test3 'h)) -(debug (pffi-struct-get struct-test3 'i)) -(debug (pffi-struct-get struct-test3 'j)) -(debug (pffi-struct-get struct-test3 'k)) -(debug (pffi-struct-get struct-test3 'l)) -(debug (pffi-struct-get struct-test3 'm)) -(debug (pffi-struct-get struct-test3 'n)) -(c-test-check-by-value (pffi-struct-dereference struct-test3)) +;(define struct-test3 (make-struct-test-dereference2)) +;(debug (pffi-struct-set! struct-test3 'a 1)) +;(debug (pffi-struct-set! struct-test3 'b #\b)) +;(debug (pffi-struct-set! struct-test3 'c 3.0)) +;(debug (pffi-struct-set! struct-test3 'd #\d)) +;(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'f 6.0)) +;(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) +;(debug (pffi-struct-set! struct-test3 'h 8)) +;(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'j 10)) +;(debug (pffi-struct-set! struct-test3 'k 11)) +;(debug (pffi-struct-set! struct-test3 'l 12)) +;(debug (pffi-struct-set! struct-test3 'm 13.0)) +;(debug (pffi-struct-set! struct-test3 'n 14.0)) +;(debug (pffi-struct-get struct-test3 'a)) +;(debug (pffi-struct-get struct-test3 'b)) +;(debug (pffi-struct-get struct-test3 'c)) +;(debug (pffi-struct-get struct-test3 'd)) +;(debug (pffi-struct-get struct-test3 'e)) +;(debug (pffi-struct-get struct-test3 'f)) +;(debug (pffi-struct-get struct-test3 'g)) +;(debug (pffi-struct-get struct-test3 'h)) +;(debug (pffi-struct-get struct-test3 'i)) +;(debug (pffi-struct-get struct-test3 'j)) +;(debug (pffi-struct-get struct-test3 'k)) +;(debug (pffi-struct-get struct-test3 'l)) +;(debug (pffi-struct-get struct-test3 'm)) +;(debug (pffi-struct-get struct-test3 'n)) +;(c-test-check-by-value (pffi-struct-dereference struct-test3)) ;; pffi-define-callback