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

Fix segfault on chibi scheme when passing null pointers

This commit is contained in:
retropikzel 2025-07-08 08:28:41 +03:00
parent 6631c08bd9
commit 4c89153790
4 changed files with 21 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
Makefile
View File

@ -3,7 +3,7 @@ CC=gcc
DOCKER=docker run -it -v ${PWD}:/workdir
DOCKER_INIT=cd /workdir && make clean &&
VERSION=$(shell awk '/version:/{ print $$2 }' README.md )
TESTNAME=primitives
TEST=primitives
SCHEME=chibi
all: package
@ -31,9 +31,9 @@ test-java: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
cp tests/*.scm tmp/test/
cp tests/c-include/libtest.h tmp/test/
cd tmp/test \
&& ${JAVA_HOME}/bin/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:./snow/*.sld:./snow/retropikzel/*.sld ${TESTNAME}.scm
&& ${JAVA_HOME}/bin/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:./snow/*.sld:./snow/retropikzel/*.sld ${TEST}.scm
test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
test: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
make ${SCHEME}
cp -r foreign tmp/test/
cp tests/*.scm tmp/test/
@ -42,8 +42,8 @@ test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." \
COMPILE_R7RS_KAWA="-J--add-exports=java.base/jdk.internal.foreign.abi=ALL-UNNAMED -J--add-exports=java.base/jdk.internal.foreign.layout=ALL-UNNAMED -J--add-exports=java.base/jdk.internal.foreign=ALL-UNNAMED -J--enable-native-access=ALL-UNNAMED -J--enable-preview" \
COMPILE_R7RS=${SCHEME} \
compile-r7rs -I . -o ${TESTNAME} ${TESTNAME}.scm
cd tmp/test && ./${TESTNAME}
compile-r7rs -I . -o ${TEST} ${TEST}.scm
cd tmp/test && ./${TEST}
test-compile-r7rs-snow: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a
cp tests/*.scm tmp/test/
@ -57,14 +57,14 @@ test-compile-r7rs-wine:
cp tests/*.scm tmp/test/
cp tests/c-include/libtest.h tmp/test/
cd tmp/test && \
wine "${HOME}/.wine/drive_c/Program Files (x86)/compile-r7rs/compile-r7rs.bat" -I . -o ${TESTNAME} ${TESTNAME}.scm
wine "${HOME}/.wine/drive_c/Program Files (x86)/compile-r7rs/compile-r7rs.bat" -I . -o ${TEST} ${TEST}.scm
cd tmp/test && \
LD_LIBRARY_PATH=. \
wine ./${TESTNAME}.bat
wine ./${TEST}.bat
test-compile-r7rs-docker:
docker build --build-arg COMPILE_R7RS=${SCHEME} --tag=r7rs-pffi-test-${SCHEME} -f dockerfiles/Dockerfile.test .
docker run -it -v "${PWD}:/workdir" -w /workdir -t r7rs-pffi-test-${SCHEME} sh -c "make COMPILE_R7RS=${SCHEME} TESTNAME=${TESTNAME} test-compile-r7rs"
docker run -it -v "${PWD}:/workdir" -w /workdir -t r7rs-pffi-test-${SCHEME} sh -c "make COMPILE_R7RS=${SCHEME} TEST=${TEST} test-compile-r7rs"
tmp/test/libtest.o: tests/c-src/libtest.c
mkdir -p tmp/test

6
foreign/c/primitives/chibi.scm
View File

@ -69,6 +69,12 @@
(let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror)))
(lambda arguments
(display "NAME: ")
(display c-name)
(newline)
(display "ARGS: ")
(write arguments)
(newline)
(let* ((return-pointer
(internal-ffi-call (length argument-types)
(type->libffi-type-number return-type)

5
foreign/c/primitives/chibi/foreign-c.stub
View File

@ -109,7 +109,9 @@
double vals18[nargs];
void* vals20[nargs];
printf(\"nargs: %i\\n\", nargs);
for(int i = 0; i < nargs; i++) {
printf(\"i: %i\\n\", i);
void* arg = NULL;
switch(atypes[i]) {
case 1:
@ -202,10 +204,11 @@
case 19:
c_atypes[i] = &ffi_type_void;
arg = NULL;
c_avalues[i] = NULL;
break;
case 20:
c_atypes[i] = &ffi_type_pointer;
if(avalues[i] != NULL) {
if(sexp_cpointerp(avalues[i])) {
vals20[i] = sexp_cpointer_value(avalues[i]);
} else {
vals20[i] = NULL;

8
tests/pointers.scm
View File

@ -72,11 +72,6 @@
(newline)))))
(define-c-library libc '("stdlib.h" "stdio.h" "time.h") libc-name '((additional-versions ("6"))))
(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
(define-c-procedure c-fclose libc 'fclose 'int '(pointer))
(define-c-procedure c-time libc 'time 'int '(pointer))
(define-c-procedure c-srand libc 'srand 'void '(int))
(define-c-procedure c-rand libc 'rand 'int '())
(print-header "pointers 1")
@ -88,7 +83,10 @@
(debug n)
(assert equal? (c-bytevector? n) #t)
(define-c-procedure c-time libc 'time 'int '(pointer))
(define-c-procedure c-srand libc 'srand 'void '(int))
(c-srand (c-time (make-c-null)))
(define-c-procedure c-rand libc 'rand 'int '())
(define random-integer (c-rand))
(assert equal? (number? random-integer) #t)