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

Backup

This commit is contained in:
retropikzel 2026-01-02 20:13:05 +02:00
parent aa6044f1b9
commit 2b9ef4a4df
3 changed files with 17 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Dockerfile
View File

@ -22,7 +22,8 @@ RUN git clone https://codeberg.org/foreign-c/foreign-c.git --depth=2
ARG SCHEME=chibi
ARG IMAGE=${SCHEME}:head
FROM schemers/${IMAGE}
RUN apt-get update && apt-get install -y make gcc libffi-dev libcurl4 gauche
RUN apt-get update && apt-get install -y make gcc libffi-dev libcurl4 gauche \
netcat-traditional ca-certificates curl
RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
COPY --from=build /build /build
ARG SCHEME=chibi
@ -46,4 +47,4 @@ RUN cp -r /build/foreign-c-libraries/retropikzel retropikzel/
RUN cp -r /build/foreign-c/foreign .
COPY Makefile .
COPY srfi srfi/
COPY foreign foreign/

6
Makefile
View File

@ -45,7 +45,7 @@ test-r7rs-docker:
test-r6rs: tmpdir
cd ${TMPDIR} && echo "(import (rnrs) (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} && 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
cd ${TMPDIR} && ./test-r6rs
@ -57,6 +57,4 @@ tmpdir:
rm -rf ${TMPDIR}
mkdir -p ${TMPDIR}
cp -r srfi ${TMPDIR}/
clean:
git clean -X -f
cp -r foreign ${TMPDIR}/

24
srfi/106.scm
View File

@ -72,8 +72,8 @@
(define SO-REUSEPORT 15)
(define AI-PASSIVE 1)
(define +sockaddr-size+ 16)
(define +ai-family-size+ 2)
(define *sockaddr-size* 16)
(define *ai-family-size* 2)
(define socket-merge-flags (lambda flags (apply + flags)))
(define (socket-purge-flags base-flag . flags) (apply - (cons base-flag flags)))
@ -134,11 +134,11 @@
(let* ((pointer (make-c-bytevector 128 0))
(pointer-address (c-bytevector->address pointer))
(node-pointer (address->c-bytevector
(+ pointer-address +ai-family-size+))))
(+ pointer-address *ai-family-size*))))
(c-bytevector-set! pointer 'u16 0 *af-unix*)
(c-strcpy node-pointer (string->c-utf8 node))
pointer))
(sockaddr-size (+ +ai-family-size+ (bytevector-length (string->utf8 node)))))
(sockaddr-size (+ *ai-family-size* (bytevector-length (string->utf8 node)))))
(when (< socket-file-descriptor 0)
(c-perror (string->c-utf8 "make-client-socket (socket) error"))
(raise-continuable "make-client-socket (socket) error"))
@ -214,7 +214,7 @@
(let* ((pointer (make-c-bytevector 128 0))
(pointer-address (c-bytevector->address pointer))
(node-pointer (address->c-bytevector
(+ pointer-address +ai-family-size+))))
(+ pointer-address *ai-family-size*))))
(c-bytevector-set! pointer 'u16 0 *af-inet*)
(c-bytevector-set! pointer
'u16
@ -226,7 +226,7 @@
(option (let ((pointer (make-c-bytevector (c-type-size 'int))))
(c-bytevector-set! pointer 'int 0 1)
pointer))
(sockaddr-size (+ +ai-family-size+ (bytevector-length (string->utf8 node)))))
(sockaddr-size (+ *ai-family-size* (bytevector-length (string->utf8 node)))))
(when (< socket-file-descriptor 0)
(c-perror (string->c-utf8 "make-server-socket (socket) error"))
(raise-continuable "make-server-socket (socket) error"))
@ -236,7 +236,7 @@
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0)
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error"))
(raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error"))
(when (< (c-bind socket-file-descriptor sockaddr +sockaddr-size+) 0)
(when (< (c-bind socket-file-descriptor sockaddr *sockaddr-size*) 0)
(c-perror (string->c-utf8 "socket-accept (bind) error"))
(raise-continuable "socket-accept (bind) error"))
(when (< (c-listen socket-file-descriptor 0) 0)
@ -337,19 +337,19 @@
((symbol=? 'name 'inet6) *af-inet6*)
((symbol=? 'name 'unspec) *af-unspec*)
((symbol=? 'name 'unix) *af-unix*)
(else (error "address-family: Unrecognized name" name))))))
(else (error "address-family: Unrecognized name" 'name))))))
(define-syntax address-info
(syntax-rules ()
((_ names ...)
(apply socket-merge-flags
(map (lambda (name)
(cond ((symbol=? name 'canoname) *ai-canoname*)
(cond ((symbol=? name 'canonname) *ai-canonname*)
((symbol=? name 'numerichost) *ai-numerichost*)
((symbol=? name 'v4mapped) *ai-v4mapped*)
((symbol=? name 'all) *ai-all*)
((symbol=? name 'addrconfig) *ai-addrconfig*)
(else (error "address-info: Unrecognized name" name))))
(else (error "address-info: Unrecognized name" 'name))))
'(names ...))))))
(define-syntax socket-domain
@ -357,7 +357,7 @@
((_ name)
(cond ((symbol=? 'name 'stream) *sock-stream*)
((symbol=? 'name 'datagram) *af-unix*)
(else (error "socket-domain: Unrecognized name" name))))))
(else (error "socket-domain: Unrecognized name" 'name))))))
(define-syntax ip-protocol
(syntax-rules ()
@ -365,7 +365,7 @@
(cond ((symbol=? 'name 'ip) *ipproto-ip*)
((symbol=? 'name 'tcp) *ipproto-tcp*)
((symbol=? 'name 'udp) *ipproto-udp*)
(else (error "ip-protocol: Unrecognized name" name))))))
(else (error "ip-protocol: Unrecognized name" 'name))))))
(define-syntax shutdown-method
(syntax-rules ()