Update translator with enhanced bracket/import handling; include tcp.sls changes
ober
415b8bfadef9cf64b20fe755ca7053e95e2d6a14
--- a/lib/jerboa/translator.sls +++ b/lib/jerboa/translator.sls @@ -156,15 +156,19 @@ ;; translate-brackets: [x y z] → (list x y z) when NOT in binding position. ;; ;; Strategy: scan the string maintaining a context stack. Each open-paren - ;; pushes the keyword that started the form (or 'other). When we see `[`, - ;; if the innermost paren context is a binding-form, the bracket is in - ;; binding position — keep as-is. Otherwise convert to (list ...). + ;; pushes a context tag: 'binding (opened by a let/lambda/do etc. keyword), + ;; 'binding-list (the first ( directly inside a 'binding context — this is + ;; the clause list), or 'other. Brackets inside 'binding or 'binding-list + ;; contexts are treated as binders and left as-is; all others become (list ..). ;; - ;; This correctly handles multi-clause let: (let ([x 1] [y 2]) ...) - ;; because both brackets share the same parent paren context "let". + ;; This correctly handles multi-clause let: (let ([x 1] [y 2]) ...) and + ;; lambda formal lists: (lambda [x y] body). ;; - ;; This is necessarily heuristic at the string level. For perfectly correct - ;; output, use translate-file which processes s-expressions directly. + ;; Known limitation (inherent to string-level heuristics): + ;; - Brackets in a let *body* that follow the binding list may be misclassified + ;; when the outer form is still in 'binding context. + ;; - Brackets nested inside binding-clause values are not converted. + ;; For fully correct output use translate-file which processes s-expressions. (define (translate-brackets str) (define binding-forms '("let" "let*" "letrec" "letrec*" "letrec-values" @@ -192,8 +196,21 @@ (define (binding-form? token) (member token binding-forms)) - ;; pctx-stack: list of 'binding | 'other pushed per open-paren - ;; bracket-stack: list of 'binder | 'list pushed per open-bracket + ;; Context stack entry meanings: + ;; 'binding — opened by (let ...) / (lambda ...) etc.; the NEXT + ;; positional ( or [ is the binding-list + ;; 'binding-list — the ( or [ directly containing binding clauses; + ;; brackets inside here are binders + ;; 'other — all other paren contexts; brackets inside are lists + ;; + ;; Transition rules: + ;; see ( and parent ctx is 'binding → push 'binding-list, parent stays + ;; see ( and parent ctx is 'binding-list → push 'other (individual clause) + ;; see ( with binding keyword inside → push 'binding + ;; see ( otherwise → push 'other + ;; + ;; pctx: list of context tags (top = current innermost) + ;; bstk: list of 'binder|'list per open bracket (let ([len (string-length str)]) (let loop ([i 0] [acc '()] [pctx '()] [bstk '()]) (cond @@ -201,12 +218,19 @@ (apply string-append (reverse acc))] [(in-string-at? str i) (loop (+ i 1) (cons (string (string-ref str i)) acc) pctx bstk)] - ;; Open paren: push context + ;; Open paren: determine context to push [(char=? (string-ref str i) #\() - (let ([tok (token-after-open str i)]) - (loop (+ i 1) (cons "(" acc) - (cons (if (binding-form? tok) 'binding 'other) pctx) - bstk))] + (let* ([parent (if (null? pctx) 'other (car pctx))] + [tok (token-after-open str i)] + [ctx (cond + ;; Inside a binding-form's argument list: next ( is + ;; the binding-list + [(eq? parent 'binding) 'binding-list] + ;; This paren opens a new binding form + [(binding-form? tok) 'binding] + ;; Otherwise + [else 'other])]) + (loop (+ i 1) (cons "(" acc) (cons ctx pctx) bstk))] ;; Close paren: pop context [(char=? (string-ref str i) #\)) (loop (+ i 1) (cons ")" acc) @@ -214,8 +238,11 @@ bstk)] ;; Open bracket [(char=? (string-ref str i) #\[) - (let ([in-binding? (and (not (null? pctx)) - (eq? (car pctx) 'binding))]) + (let* ([parent (if (null? pctx) 'other (car pctx))] + ;; Bracket directly inside binding-form (lambda [args]) + ;; or inside binding-list (let ([x 1])) → binder + [in-binding? (or (eq? parent 'binding) + (eq? parent 'binding-list))]) (loop (+ i 1) (cons (if in-binding? "[" "(list ") acc) pctx --- a/lib/std/net/tcp.sls +++ b/lib/std/net/tcp.sls @@ -9,6 +9,11 @@ ;;; ;;; Ports are standard Chez Scheme binary ports transcoded to UTF-8. ;;; Use with-tcp-server for automatic cleanup. +;;; +;;; GC SAFETY: All blocking I/O uses non-blocking sockets with Chez-native +;;; sleep for retry delays. This ensures threads can participate in Chez's +;;; stop-the-world GC rendezvous (foreign calls like accept/read/poll block +;;; the thread from responding to GC signals). (library (std net tcp) (export @@ -41,10 +46,19 @@ (define c-inet-pton (foreign-procedure "inet_pton" (int string void*) int)) (define c-getsockname (foreign-procedure "getsockname" (int void* void*) int)) + ;; fcntl for non-blocking mode + (define c-fcntl (foreign-procedure "fcntl" (int int int) int)) + ;; errno access for EINTR retry (define c-errno-location (foreign-procedure "__errno_location" () void*)) (define (get-errno) (foreign-ref 'int (c-errno-location) 0)) (define EINTR 4) + (define EAGAIN 11) + + ;; fcntl constants + (define F_GETFL 3) + (define F_SETFL 4) + (define O_NONBLOCK #x800) ;; Constants (define AF_INET 2) @@ -53,6 +67,14 @@ (define SO_REUSEADDR 2) (define SOCKADDR_IN_SIZE 16) ;; sizeof(struct sockaddr_in) on Linux + ;; GC-safe retry delay: 10ms via Chez's sleep (not a foreign call). + ;; Chez's sleep uses condition variables that respond to GC signals. + (define *retry-delay* (make-time 'time-duration 10000000 0)) + + (define (set-nonblocking! fd) + (let ([flags (c-fcntl fd F_GETFL 0)]) + (c-fcntl fd F_SETFL (bitwise-ior flags O_NONBLOCK)))) + ;; ========== sockaddr_in helpers ========== (define (make-sockaddr-in address port) @@ -113,6 +135,8 @@ (when (< (c-listen fd backlog) 0) (c-close fd) (error 'tcp-listen "listen() failed")) + ;; Set non-blocking for GC-safe accept loop + (set-nonblocking! fd) ;; Get actual port (important when port=0) (let ([actual-port (let ([buf (foreign-alloc SOCKADDR_IN_SIZE)] @@ -130,13 +154,18 @@ (define (tcp-accept srv) ;; Accept a connection. Returns (values input-port output-port). - ;; Retries on EINTR (caused by GC stop-the-world interrupting accept()). - (let loop () - (let ([client-fd (c-accept (tcp-server-fd srv) 0 0)]) - (cond - [(>= client-fd 0) (fd->ports client-fd "tcp-client")] - [(= (get-errno) EINTR) (loop)] - [else (error 'tcp-accept "accept() failed")])))) + ;; Uses non-blocking accept + Chez sleep for GC safety. + ;; The listen socket is set non-blocking in tcp-listen. + (let ([fd (tcp-server-fd srv)]) + (let loop () + (let ([client-fd (c-accept fd 0 0)]) + (cond + [(>= client-fd 0) (fd->ports client-fd "tcp-client")] + [(let ([e (get-errno)]) (or (= e EINTR) (= e EAGAIN))) + ;; No connection pending — sleep via Chez (GC-safe), then retry + (sleep *retry-delay*) + (loop)] + [else (error 'tcp-accept "accept() failed")]))))) (define (tcp-close srv) (c-close (tcp-server-fd srv))) @@ -180,6 +209,9 @@ ;; IMPORTANT: Both ports share the same fd. A closed? flag prevents: ;; 1. Double-close: Chez calls close handler on both close-port AND GC finalization ;; 2. Read/write after close: returns EOF/0 instead of operating on reused fd + ;; + ;; Client sockets use non-blocking I/O with Chez-native sleep for GC safety. + (set-nonblocking! fd) (let ([closed? #f]) (let ([in (make-custom-binary-input-port (string-append name "-in") @@ -192,7 +224,12 @@ [(> n 0) (bytevector-copy! buf 0 bv start n) n] - [(and (< n 0) (= (get-errno) EINTR)) (retry)] + [(and (< n 0) + (let ([e (get-errno)]) + (or (= e EINTR) (= e EAGAIN)))) + ;; No data yet — sleep via Chez (GC-safe), then retry + (sleep *retry-delay*) + (retry)] [else 0])))))) #f ;; get-position #f ;; set-position! @@ -216,7 +253,12 @@ (- count written))]) (cond [(> n 0) (lp (+ written n))] - [(and (< n 0) (= (get-errno) EINTR)) (lp written)] + [(and (< n 0) + (let ([e (get-errno)]) + (or (= e EINTR) (= e EAGAIN)))) + ;; Socket buffer full — sleep briefly, retry + (sleep *retry-delay*) + (lp written)] [else written]))))))) #f ;; get-position #f ;; set-position!