diff --git a/Dockerfile b/Dockerfile index f9bf119..83fd397 100644 --- a/Dockerfile +++ b/Dockerfile @@ -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/ diff --git a/Makefile b/Makefile index 51435b7..e4a54f2 100644 --- a/Makefile +++ b/Makefile @@ -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}/ diff --git a/srfi/106.scm b/srfi/106.scm index 3335eae..4d78bfe 100644 --- a/srfi/106.scm +++ b/srfi/106.scm @@ -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 diff --git a/srfi/106/test.scm b/srfi/106/test.scm index 095ab30..8957c4d 100644 --- a/srfi/106/test.scm +++ b/srfi/106/test.scm @@ -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)))