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

Improve SRFI-106 tests. Update to using latest (foreign c)

This commit is contained in:
retropikzel 2026-01-09 15:07:05 +02:00
parent 2b9ef4a4df
commit 2d7b225804
4 changed files with 51 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Dockerfile
View File

@ -41,6 +41,7 @@ WORKDIR /build/foreign-c
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)" || true
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)" || true
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(retropikzel shell)" || true
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(retropikzel debug)" || true
RUN make SCHEME=${SCHEME} build install
WORKDIR /workdir
RUN cp -r /build/foreign-c-libraries/retropikzel retropikzel/

5
Makefile
View File

@ -33,7 +33,7 @@ uninstall:
test-r7rs: tmpdir
@if [ "${SCHEME}" = "chibi" ]; then rm -rf ${TMPDIR}/srfi/98.*; fi
cd ${TMPDIR} && echo "(import (scheme base) (scheme write) (scheme file) (scheme process-context) (foreign c) (srfi ${SRFI}) (srfi 64))" > test-r7rs.scm
cd ${TMPDIR} && echo "(import (scheme base) (scheme write) (scheme file) (scheme process-context) (retropikzel debug) (foreign c) (srfi ${SRFI}) (srfi 64))" > test-r7rs.scm
cd ${TMPDIR} && cat srfi/${SRFI}/test.scm >> test-r7rs.scm
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test-r7rs.scm
cd ${TMPDIR} && printf "\n" | ./test-r7rs
@ -43,7 +43,7 @@ test-r7rs-docker:
docker run -t foreign-c-srfi-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SRFI=${SRFI} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs"
test-r6rs: tmpdir
cd ${TMPDIR} && echo "(import (rnrs) (foreign c) (srfi :${SRFI}) (srfi :64))" > test-r6rs.sps
cd ${TMPDIR} && echo "(import (rnrs) (retropikzel debug) (foreign c) (srfi :${SRFI}) (srfi :64))" > test-r6rs.sps
cd ${TMPDIR} && cat srfi/${SRFI}/test.scm >> test-r6rs.sps
cd ${TMPDIR} && akku install chez-srfi akku-r7rs #"(foreign c)" "(retropikzel shell)"
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps
@ -57,4 +57,3 @@ tmpdir:
rm -rf ${TMPDIR}
mkdir -p ${TMPDIR}
cp -r srfi ${TMPDIR}/
cp -r foreign ${TMPDIR}/

8
srfi/106.scm
View File

@ -132,8 +132,8 @@
(let* ((socket-file-descriptor (c-socket ai-family ai-socktype 0))
(sockaddr
(let* ((pointer (make-c-bytevector 128 0))
(pointer-address (c-bytevector->address pointer))
(node-pointer (address->c-bytevector
(pointer-address (c-bytevector->integer pointer))
(node-pointer (integer->c-bytevector
(+ pointer-address *ai-family-size*))))
(c-bytevector-set! pointer 'u16 0 *af-unix*)
(c-strcpy node-pointer (string->c-utf8 node))
@ -212,8 +212,8 @@
(node "127.0.0.1")
(sockaddr
(let* ((pointer (make-c-bytevector 128 0))
(pointer-address (c-bytevector->address pointer))
(node-pointer (address->c-bytevector
(pointer-address (c-bytevector->integer pointer))
(node-pointer (integer->c-bytevector
(+ pointer-address *ai-family-size*))))
(c-bytevector-set! pointer 'u16 0 *af-inet*)
(c-bytevector-set! pointer

91
srfi/106/test.scm
View File

@ -1,78 +1,75 @@
(display "HERE address-family: ")
(write (address-family inet))
(newline)
(display "HERE address-info: ")
(write (address-info v4mapped addrconfig))
(newline)
(display "HERE socket-domain:")
(write (socket-domain stream))
(newline)
(display "HERE ip-protocol: ")
(write (ip-protocol ip))
(newline)
(define sock1-port "3005")
(define sock2-port "3006")
(define-c-library libc `("stdlib.h") libc-name '((additional-versions ("0" "6"))))
(define-c-procedure c-system libc 'system 'int '(pointer))
(c-system (string->c-utf8 "echo \"lol\" | nc -l 3001 &"))
(define sock1 (make-client-socket "127.0.0.1" "3001"))
(display "HERE sock1: ")
(write sock1)
(display "Testing TCP socket")
(newline)
(display "HERE sock1 recv: ")
(write (utf8->string (socket-recv sock1 3)))
(newline)
(debug (address-family inet))
(debug (address-info v4mapped addrconfig))
(debug (socket-domain stream))
(debug (ip-protocol ip))
(c-system (string->c-utf8 (string-append "echo \"lol\" | nc -l " sock1-port "&")))
(define sock1 (make-client-socket "127.0.0.1" sock1-port))
(debug sock1)
(debug (utf8->string (socket-recv sock1 3)))
(socket-send sock1 (string->utf8 "Hello from sock1\n"))
(socket-close sock1)
(define sock2-port "3002")
(define sock2 (make-server-socket sock2-port))
(display "HERE sock2: ")
(write sock2)
(newline)
(debug sock2)
(display (string-append "run: echo \"lol\" | nc 127.0.0.1 " sock2-port))
(newline)
(define client-sock1 (socket-accept sock2))
(display "HERE client-sock1: ")
(write client-sock1)
(newline)
(debug client-sock1)
(socket-send client-sock1 (string->utf8 "Hello from client-sock1\n"))
(display "HERE client-sock1 recv: ")
(write (utf8->string (socket-recv client-sock1 3)))
(debug (utf8->string (socket-recv client-sock1 3)))
(display "Testing UNIX socket")
(newline)
(debug (address-family unix))
(debug (address-info v4mapped addrconfig))
(debug (socket-domain stream))
(debug (ip-protocol ip))
(define sock-path "/tmp/demo.sock")
(c-system (string->c-utf8 (string-append "echo \"lol\" | nc -l -U " sock-path " &")))
(define usock1 (make-client-socket sock-path "3000" *af-unix*))
(debug usock1)
(debug (utf8->string (socket-recv usock1 3)))
(socket-send usock1 (string->utf8 "Hello from usock1\n"))
(socket-close usock1)
#|
(c-system (string->c-utf8 "echo \"lol\" | nc -l -U /tmp/demo.sock &"))
(define usock2-port "")
(define usock2 (make-server-socket usock2-port *af-unix*))
(debug usock2)
(define sock2 (make-client-socket "/tmp/demo.sock" "3000" *af-unix*))
(display "HERE sock2: ")
(write (utf8->string (socket-recv sock2 3)))
(display (string-append "run: echo \"lol\" | nc " sock-path " " usock2-port))
(newline)
(socket-send sock2 (string->utf8 "Hello from sock2\n"))
(socket-close sock2)
|#
(define client-usock1 (socket-accept usock2))
(debug client-usock1)
(socket-send client-sock1 (string->utf8 "Hello from client-usock1\n"))
(debug (utf8->string (socket-recv client-usock1 3)))