coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

phase 22 tcl: string-buffer/channel/regexp/format/coroutine in lib/tcl/runtime.sx (37 forms), 56/56 tests

Browse Source
This commit is contained in:
giles
2026-05-01 23:24:56 +00:00
parent bcde5e126a
commit 3e07727d6b
3 changed files with 487 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

279
lib/tcl/runtime.sx Normal file
View File

@@ -0,0 +1,279 @@
;; lib/tcl/runtime.sx — Tcl primitives on SX
;;
;; Provides Tcl-idiomatic wrappers over SX built-ins.
;; Primitives used:
;; make-regexp/regexp-match/regexp-match-all/... (Phase 19)
;; make-set/set-add!/set-member?/set-remove!/set->list (Phase 18)
;; call/cc (core evaluator)
;; quotient/remainder (Phase 15 / builtin)
;; string->list/list->string/char->integer (Phase 13)
;; ---------------------------------------------------------------------------
;; 1. String buffer — Tcl append / string accumulation
;; ---------------------------------------------------------------------------
(define
(tcl-sb-new)
(let
((sb (dict)))
(dict-set! sb "_tcl_sb" true)
(dict-set! sb "_buf" "")
sb))
(define (tcl-sb? v) (and (dict? v) (dict-has? v "_tcl_sb")))
(define
(tcl-sb-append! sb s)
(dict-set! sb "_buf" (str (get sb "_buf") s))
sb)
(define (tcl-sb-value sb) (get sb "_buf"))
(define (tcl-sb-clear! sb) (dict-set! sb "_buf" "") sb)
(define (tcl-sb-length sb) (len (get sb "_buf")))
;; ---------------------------------------------------------------------------
;; 2. String port (channel) — Tcl channel abstraction
;; Read channel: created from a string, supports gets/read.
;; Write channel: accumulates puts output, queryable via tcl-chan-string.
;; ---------------------------------------------------------------------------
(define
(tcl-chan-in-new str)
(let
((c (dict)))
(dict-set! c "_tcl_chan" true)
(dict-set! c "_mode" "read")
(dict-set! c "_chars" (string->list str))
(dict-set! c "_pos" 0)
c))
(define
(tcl-chan-out-new)
(let
((c (dict)))
(dict-set! c "_tcl_chan" true)
(dict-set! c "_mode" "write")
(dict-set! c "_buf" "")
c))
(define (tcl-chan? v) (and (dict? v) (dict-has? v "_tcl_chan")))
(define
(tcl-chan-eof? c)
(and
(= (get c "_mode") "read")
(>= (get c "_pos") (len (get c "_chars")))))
(define
(tcl-chan-read-char c)
(if
(tcl-chan-eof? c)
nil
(let
((ch (nth (get c "_chars") (get c "_pos"))))
(dict-set! c "_pos" (+ (get c "_pos") 1))
ch)))
;; gets — read one line (up to newline or EOF), return without trailing newline
(define
(tcl-chan-gets c)
(letrec
((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (cond ((= ch nil) (list->string (reverse acc))) ((= (char->integer ch) 10) (list->string (reverse acc))) (else (go (cons ch acc))))))))
(go (list))))
;; read — read all remaining chars
(define
(tcl-chan-read c)
(letrec
((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (if (= ch nil) (list->string (reverse acc)) (go (cons ch acc)))))))
(go (list))))
;; puts — write string to write channel (no newline)
(define
(tcl-chan-puts! c s)
(when
(= (get c "_mode") "write")
(dict-set! c "_buf" (str (get c "_buf") s)))
c)
;; puts-line — write string + newline (Tcl default puts behaviour)
(define (tcl-chan-puts-line! c s) (tcl-chan-puts! c (str s "\n")))
;; string — get accumulated content of write channel
(define (tcl-chan-string c) (get c "_buf"))
;; tell — current read position
(define (tcl-chan-tell c) (get c "_pos"))
;; ---------------------------------------------------------------------------
;; 3. Regexp — Tcl regexp / regsub wrappers
;; ---------------------------------------------------------------------------
(define (tcl-re-new pattern) (make-regexp pattern ""))
(define (tcl-re-new-flags pattern flags) (make-regexp pattern flags))
(define (tcl-re? v) (regexp? v))
(define (tcl-re-match? rx str) (not (= (regexp-match rx str) nil)))
(define (tcl-re-match rx str) (regexp-match rx str))
(define (tcl-re-match-all rx str) (regexp-match-all rx str))
(define (tcl-re-sub rx str replacement) (regexp-replace rx str replacement))
(define
(tcl-re-sub-all rx str replacement)
(regexp-replace-all rx str replacement))
(define (tcl-re-split rx str) (regexp-split rx str))
;; ---------------------------------------------------------------------------
;; 4. Format — Tcl format command (%s %d %f %x %o %%)
;; tcl-format takes a format string and a list of arguments.
;; Example: (tcl-format "%s is %d" (list "Alice" 30)) → "Alice is 30"
;; ---------------------------------------------------------------------------
;; Digit characters for base conversion
(define tcl-hex-chars (string->list "0123456789abcdef"))
(define
(tcl-digits-for-base n base digit-chars)
(let
((abs-n (if (< n 0) (- 0 n) n)))
(letrec
((go (fn (n acc) (if (= n 0) (if (= (len acc) 0) "0" (list->string acc)) (go (quotient n base) (cons (nth digit-chars (remainder n base)) acc))))))
(let
((unsigned (go abs-n (list))))
(if (< n 0) (str "-" unsigned) unsigned)))))
(define
(tcl-format-hex n)
(tcl-digits-for-base (truncate n) 16 tcl-hex-chars))
(define
(tcl-format-oct n)
(tcl-digits-for-base (truncate n) 8 (string->list "01234567")))
(define
(tcl-format fmt args)
(letrec
((chars (string->list fmt))
(go
(fn
(cs arg-list result)
(if
(= (len cs) 0)
result
(let
((c-int (char->integer (first cs))))
(if
(= c-int 37)
(if
(= (len (rest cs)) 0)
result
(let
((spec-int (char->integer (first (rest cs)))))
(cond
((= spec-int 37)
(go (rest (rest cs)) arg-list (str result "%")))
((= spec-int 115)
(go
(rest (rest cs))
(rest arg-list)
(str result (str (first arg-list)))))
((= spec-int 100)
(go
(rest (rest cs))
(rest arg-list)
(str result (str (truncate (first arg-list))))))
((= spec-int 102)
(go
(rest (rest cs))
(rest arg-list)
(str result (str (+ 0 (first arg-list))))))
((= spec-int 120)
(go
(rest (rest cs))
(rest arg-list)
(str result (tcl-format-hex (first arg-list)))))
((= spec-int 111)
(go
(rest (rest cs))
(rest arg-list)
(str result (tcl-format-oct (first arg-list)))))
(else
(go
(rest (rest cs))
arg-list
(str
result
"%"
(list->string (list (first (rest cs))))))))))
(go
(rest cs)
arg-list
(str result (list->string (list (first cs)))))))))))
(go chars args "")))
;; ---------------------------------------------------------------------------
;; 5. Coroutine — Tcl-style coroutine using call/cc
;; tcl-co-yield works reliably when called from top-level fns.
;; Avoid calling tcl-co-yield from letrec-bound lambdas (JIT limitation).
;; ---------------------------------------------------------------------------
(define tcl-current-co nil)
(define
(tcl-co-new body)
(let
((co (dict)))
(dict-set! co "_tcl_co" true)
(dict-set! co "_state" "new")
(dict-set! co "_cont" nil)
(dict-set! co "_resumer" nil)
(dict-set! co "_parent" nil)
(dict-set!
co
"_body"
(fn
()
(let
((result (body)))
(dict-set! co "_state" "dead")
(set! tcl-current-co (get co "_parent"))
((get co "_resumer") result))))
co))
(define (tcl-co? v) (and (dict? v) (dict-has? v "_tcl_co")))
(define (tcl-co-alive? co) (not (= (get co "_state") "dead")))
(define
(tcl-co-yield val)
(call/cc
(fn
(resume-k)
(let
((cur tcl-current-co))
(dict-set! cur "_cont" resume-k)
(dict-set! cur "_state" "suspended")
(set! tcl-current-co (get cur "_parent"))
((get cur "_resumer") val)))))
(define
(tcl-co-resume co)
(call/cc
(fn
(return-k)
(dict-set! co "_parent" tcl-current-co)
(dict-set! co "_resumer" return-k)
(set! tcl-current-co co)
(dict-set! co "_state" "running")
(if
(= (get co "_cont") nil)
((get co "_body"))
((get co "_cont") nil)))))

62
lib/tcl/test.sh Executable file
View File

@@ -0,0 +1,62 @@
#!/usr/bin/env bash
# lib/tcl/test.sh — smoke-test the Tcl runtime layer.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found."
exit 1
fi
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "lib/tcl/runtime.sx")
(epoch 2)
(load "lib/tcl/tests/runtime.sx")
(epoch 3)
(eval "(list tcl-test-pass tcl-test-fail)")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"
echo "$OUTPUT" | tail -20
exit 1
fi
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
TOTAL=$((P + F))
if [ "$F" -eq 0 ]; then
echo "ok $P/$TOTAL lib/tcl tests passed"
else
echo "FAIL $P/$TOTAL passed, $F failed"
TMPFILE2=$(mktemp)
cat > "$TMPFILE2" << 'EPOCHS2'
(epoch 1)
(load "lib/tcl/runtime.sx")
(epoch 2)
(load "lib/tcl/tests/runtime.sx")
(epoch 3)
(eval "(map (fn (f) (list (get f :name) (get f :got) (get f :expected))) tcl-test-fails)")
EPOCHS2
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>/dev/null | grep -E '^\(ok-len 3' -A1 | tail -1 || true)
echo " Details: $FAILS"
rm -f "$TMPFILE2"
fi
[ "$F" -eq 0 ]

146
lib/tcl/tests/runtime.sx Normal file
View File

@@ -0,0 +1,146 @@
;; lib/tcl/tests/runtime.sx — Tests for lib/tcl/runtime.sx
(define tcl-test-pass 0)
(define tcl-test-fail 0)
(define tcl-test-fails (list))
(define
(tcl-test name got expected)
(if
(= got expected)
(set! tcl-test-pass (+ tcl-test-pass 1))
(begin
(set! tcl-test-fail (+ tcl-test-fail 1))
(set! tcl-test-fails (append tcl-test-fails (list {:got got :expected expected :name name}))))))
;; ---------------------------------------------------------------------------
;; 1. String buffer
;; ---------------------------------------------------------------------------
(define sb1 (tcl-sb-new))
(tcl-test "sb? new" (tcl-sb? sb1) true)
(tcl-test "sb? non-sb" (tcl-sb? "hello") false)
(tcl-test "sb value empty" (tcl-sb-value sb1) "")
(tcl-test "sb length empty" (tcl-sb-length sb1) 0)
(tcl-sb-append! sb1 "hello")
(tcl-test "sb value after append" (tcl-sb-value sb1) "hello")
(tcl-sb-append! sb1 " ")
(tcl-sb-append! sb1 "world")
(tcl-test "sb value after multi-append" (tcl-sb-value sb1) "hello world")
(tcl-test "sb length" (tcl-sb-length sb1) 11)
(tcl-sb-clear! sb1)
(tcl-test "sb value after clear" (tcl-sb-value sb1) "")
(tcl-test "sb length after clear" (tcl-sb-length sb1) 0)
;; ---------------------------------------------------------------------------
;; 2. String port (channel)
;; ---------------------------------------------------------------------------
(define chin1 (tcl-chan-in-new "hello\nworld\nfoo"))
(tcl-test "chan? read" (tcl-chan? chin1) true)
(tcl-test "chan eof? no" (tcl-chan-eof? chin1) false)
(tcl-test "chan gets line1" (tcl-chan-gets chin1) "hello")
(tcl-test "chan gets line2" (tcl-chan-gets chin1) "world")
(tcl-test "chan gets line3" (tcl-chan-gets chin1) "foo")
(tcl-test "chan eof? yes" (tcl-chan-eof? chin1) true)
(tcl-test "chan gets at eof" (tcl-chan-gets chin1) "")
(define chin2 (tcl-chan-in-new "abcdef"))
(tcl-test "chan read all" (tcl-chan-read chin2) "abcdef")
(tcl-test "chan read empty" (tcl-chan-read chin2) "")
(define chout1 (tcl-chan-out-new))
(tcl-test "chan? write" (tcl-chan? chout1) true)
(tcl-chan-puts! chout1 "hello")
(tcl-chan-puts! chout1 " world")
(tcl-test "chan string" (tcl-chan-string chout1) "hello world")
(tcl-chan-puts-line! chout1 "!")
(tcl-test "chan string with newline" (tcl-chan-string chout1) "hello world!\n")
(define chout2 (tcl-chan-out-new))
(tcl-chan-puts-line! chout2 "line1")
(tcl-chan-puts-line! chout2 "line2")
(tcl-test "chan multi-line" (tcl-chan-string chout2) "line1\nline2\n")
;; ---------------------------------------------------------------------------
;; 3. Regexp
;; ---------------------------------------------------------------------------
(define rx1 (tcl-re-new "hel+o"))
(tcl-test "re? yes" (tcl-re? rx1) true)
(tcl-test "re? no" (tcl-re? "hello") false)
(tcl-test "re match? yes" (tcl-re-match? rx1 "say hello") true)
(tcl-test "re match? no" (tcl-re-match? rx1 "goodbye") false)
(define m1 (tcl-re-match rx1 "say hello world"))
(tcl-test "re match result" (get m1 "match") "hello")
(define rx2 (tcl-re-new "[0-9]+"))
(define all (tcl-re-match-all rx2 "a1b22c333"))
(tcl-test "re match-all count" (len all) 3)
(tcl-test "re match-all last" (get (nth all 2) "match") "333")
(tcl-test "re sub" (tcl-re-sub rx2 "a1b2" "N") "aNb2")
(tcl-test "re sub-all" (tcl-re-sub-all rx2 "a1b2" "N") "aNbN")
(define rx3 (tcl-re-new "[ ,]+"))
(tcl-test "re split" (tcl-re-split rx3 "a b,c") (list "a" "b" "c"))
;; ---------------------------------------------------------------------------
;; 4. Format
;; ---------------------------------------------------------------------------
(tcl-test "format %s" (tcl-format "hello %s" (list "world")) "hello world")
(tcl-test "format %d" (tcl-format "n=%d" (list 42)) "n=42")
(tcl-test "format %d truncates float" (tcl-format "n=%d" (list 3.9)) "n=3")
(tcl-test
"format %s %d"
(tcl-format "%s is %d" (list "age" 30))
"age is 30")
(tcl-test "format %%" (tcl-format "100%% done" (list)) "100% done")
(tcl-test "format %x" (tcl-format "%x" (list 255)) "ff")
(tcl-test "format %x 16" (tcl-format "0x%x" (list 16)) "0x10")
(tcl-test "format %o" (tcl-format "%o" (list 8)) "10")
(tcl-test "format %o 255" (tcl-format "%o" (list 255)) "377")
(tcl-test "format no spec" (tcl-format "plain text" (list)) "plain text")
(tcl-test
"format multiple"
(tcl-format "%s=%d (0x%x)" (list "val" 255 255))
"val=255 (0xff)")
;; ---------------------------------------------------------------------------
;; 5. Coroutine
;; tcl-co-yield works from top-level helper functions.
;; ---------------------------------------------------------------------------
(define
co1
(tcl-co-new
(fn () (tcl-co-yield 1) (tcl-co-yield 2) 3)))
(tcl-test "co? yes" (tcl-co? co1) true)
(tcl-test "co? no" (tcl-co? 42) false)
(tcl-test "co alive? before" (tcl-co-alive? co1) true)
(define cor1 (tcl-co-resume co1))
(tcl-test "co resume 1" cor1 1)
(tcl-test "co alive? mid" (tcl-co-alive? co1) true)
(define cor2 (tcl-co-resume co1))
(tcl-test "co resume 2" cor2 2)
(define cor3 (tcl-co-resume co1))
(tcl-test "co resume 3 completion" cor3 3)
(tcl-test "co alive? dead" (tcl-co-alive? co1) false)
;; Top-level helper for recursive yield (avoids JIT letrec limitation)
(define
(tcl-co-count-down i)
(when
(>= i 1)
(tcl-co-yield i)
(tcl-co-count-down (- i 1))))
(define co2 (tcl-co-new (fn () (tcl-co-count-down 3) "done")))
(tcl-test "co loop 3" (tcl-co-resume co2) 3)
(tcl-test "co loop 2" (tcl-co-resume co2) 2)
(tcl-test "co loop 1" (tcl-co-resume co2) 1)
(tcl-test "co loop done" (tcl-co-resume co2) "done")
(tcl-test "co loop dead" (tcl-co-alive? co2) false)