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

tcl: Phase 6 coroutines + clock/file stubs + idiom corpus (+40 tests, 329 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source 
- Coroutines (generator-style): coroutine/yield/yieldto commands; eager yield
  collection during body execution, pop-on-call dispatch via registered command
  closures; coro-yields + coroutines threaded through tcl-call-proc
- info exists varname (plus hostname/script/tclversion stubs)
- clock seconds/milliseconds/format/scan stubs
- File I/O stubs: open/close/read/eof/seek/tell/flush + file subcommands
- format command: full %-specifier parsing with flags, width, zero-pad, left-align
- Fixed dict set/unset/incr/append/update to use tcl-var-get (upvar alias aware)
- Fixed lappend and append to use tcl-var-get for reading (upvar alias aware)
- 20 coroutine tests (coro.sx) + 20 idiom corpus tests (idioms.sx)
- event-loop.tcl program: cooperative scheduler demo using coroutines
- Note: coroutines eagerly collect yields (generator-style, not true suspension)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 11:05:28 +00:00
parent ea064346e1
commit 2c61be39de
5 changed files with 805 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

441
lib/tcl/runtime.sx
View File

@@ -20,7 +20,7 @@
(frame name val)
(assoc frame :locals (assoc (get frame :locals) name val))))
(define make-tcl-interp (fn () {:result "" :output "" :code 0 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::"}))
(define make-tcl-interp (fn () {:result "" :output "" :code 0 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::" :coroutines {} :in-coro false :coro-yields (list)}))
(define
tcl-register
@@ -296,7 +296,10 @@
:frame-stack updated-below
:result result-val
:output (str caller-output proc-output)
:code (if (= code 2) 0 code))))))))))))))
:code (if (= code 2) 0 code)
:coro-yields (get result-interp :coro-yields)
:coroutines (get result-interp :coroutines)
:commands (get result-interp :commands))))))))))))))
(define
tcl-eval-cmd
@@ -383,7 +386,7 @@
(let
((name (first args)) (suffix (join "" (rest args))))
(let
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" (tcl-var-get interp name)))))
(let
((new-val (str cur suffix)))
(assoc (tcl-var-set interp name new-val) :result new-val))))))
@@ -1102,10 +1105,12 @@
(let
((name (first args)) (items (rest args)))
(let
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" (tcl-var-get interp name)))))
(let
((new-val (if (equal? cur "") (join " " items) (str cur " " (join " " items)))))
(assoc (tcl-var-set interp name new-val) :result new-val))))))
((quoted-items (map tcl-list-quote-elem items)))
(let
((new-val (if (equal? cur "") (join " " quoted-items) (str cur " " (join " " quoted-items)))))
(assoc (tcl-var-set interp name new-val) :result new-val)))))))
(define
tcl-cmd-eval
@@ -1281,9 +1286,139 @@
tcl-cmd-subst
(fn (interp args) (assoc interp :result (last args))))
; Format helper: repeat char ch n times, building pad string
(define
tcl-fmt-make-pad
(fn
(ch cnt acc)
(if (<= cnt 0) acc (tcl-fmt-make-pad ch (- cnt 1) (str ch acc)))))
; Format helper: pad string s to width w
(define
tcl-fmt-pad
(fn
(s width zero-pad? left-align?)
(let
((w (if (equal? width "") 0 (parse-int width))))
(let
((pad-len (- w (string-length s))))
(if
(<= pad-len 0)
s
(let
((pad (tcl-fmt-make-pad (if zero-pad? "0" " ") pad-len "")))
(if left-align? (str s pad) (str pad s))))))))
; Format helper: scan flag characters
(define
tcl-fmt-scan-flags
(fn
(chars j flags)
(if
(>= j (len chars))
{:j j :flags flags}
(let
((ch (nth chars j)))
(if
(contains? (list "-" "0" "+" " " "#") ch)
(tcl-fmt-scan-flags chars (+ j 1) (str flags ch))
{:j j :flags flags})))))
; Format helper: scan digits for width/precision
(define
tcl-fmt-scan-num
(fn
(chars j acc-n)
(if
(>= j (len chars))
{:j j :num acc-n}
(let
((ch (nth chars j)))
(if
(tcl-expr-digit? ch)
(tcl-fmt-scan-num chars (+ j 1) (str acc-n ch))
{:j j :num acc-n})))))
; Main format apply: process chars, produce output string
(define
tcl-fmt-apply
(fn
(chars n-len fmt-args i arg-idx acc)
(if
(>= i n-len)
acc
(let
((c (nth chars i)))
(if
(not (equal? c "%"))
(tcl-fmt-apply chars n-len fmt-args (+ i 1) arg-idx (str acc c))
; parse specifier
(let
((i2 (+ i 1)))
(if
(>= i2 n-len)
(str acc "%")
(let
((c2 (nth chars i2)))
(if
(equal? c2 "%")
(tcl-fmt-apply chars n-len fmt-args (+ i2 1) arg-idx (str acc "%"))
; scan flags
(let
((fr (tcl-fmt-scan-flags chars i2 "")))
(let
((flags (get fr :flags)) (j (get fr :j)))
(let
((wr (tcl-fmt-scan-num chars j "")))
(let
((width (get wr :num)) (j2 (get wr :j)))
; skip precision .N
(let
((j3
(if
(and (< j2 n-len) (equal? (nth chars j2) "."))
(let ((pr (tcl-fmt-scan-num chars (+ j2 1) ""))) (get pr :j))
j2)))
(if
(>= j3 n-len)
(str acc "?")
(let
((type-char (nth chars j3))
(cur-arg (if (< arg-idx (len fmt-args)) (nth fmt-args arg-idx) "")))
(let
((zero-pad? (contains? (split flags "") "0"))
(left-align? (contains? (split flags "") "-")))
(let
((formatted
(cond
((or (equal? type-char "d") (equal? type-char "i"))
(tcl-fmt-pad (str (parse-int cur-arg)) width zero-pad? left-align?))
((equal? type-char "s")
(tcl-fmt-pad cur-arg width false left-align?))
((or (equal? type-char "f") (equal? type-char "g") (equal? type-char "e"))
cur-arg)
((equal? type-char "x")
(str (parse-int cur-arg)))
((equal? type-char "o")
(str (parse-int cur-arg)))
((equal? type-char "c")
cur-arg)
(else (str "%" type-char)))))
(tcl-fmt-apply chars n-len fmt-args (+ j3 1) (+ arg-idx 1) (str acc formatted))))))))))))))))))))
(define
tcl-cmd-format
(fn (interp args) (assoc interp :result (join "" args))))
(fn
(interp args)
(if
(= 0 (len args))
(error "format: wrong # args")
(let
((fmt-str (first args)) (fmt-args (rest args)))
(let
((chars (split fmt-str ""))
(n-len (string-length fmt-str)))
(assoc interp :result (tcl-fmt-apply chars n-len fmt-args 0 0 "")))))))
(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))
@@ -2092,7 +2227,7 @@
(key (nth rest-args 1))
(val (nth rest-args 2)))
(let
((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
(let
((new-dict (tcl-dict-set-pair cur key val)))
(assoc (tcl-var-set interp varname new-dict) :result new-dict)))))
@@ -2101,7 +2236,7 @@
(let
((varname (first rest-args)) (key (nth rest-args 1)))
(let
((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
(let
((new-dict (tcl-dict-unset-key cur key)))
(assoc (tcl-var-set interp varname new-dict) :result new-dict)))))
@@ -2177,7 +2312,7 @@
((body (nth rest-args (- n 1)))
(kv-args (slice rest-args 1 (- n 1))))
(let
((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
(let
((bound-interp
(let
@@ -2234,7 +2369,7 @@
(key (nth rest-args 1))
(delta (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 1)))
(let
((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
(let
((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "0" v))))
(let
@@ -2249,7 +2384,7 @@
(key (nth rest-args 1))
(suffix (join "" (slice rest-args 2 (len rest-args)))))
(let
((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
(let
((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "" v))))
(let
@@ -2776,8 +2911,264 @@
(nil? entry)
(error (str "info body: \"" pname "\" isn't a procedure"))
(assoc interp :result (get (get entry :def) :body))))))
; info exists varname — 1 if variable exists in current frame, 0 otherwise
((equal? sub "exists")
(let
((varname (first rest-args)))
(let
((val (frame-lookup (get interp :frame) varname)))
(assoc interp :result (if (nil? val) "0" "1")))))
; info hostname — stub
((equal? sub "hostname")
(assoc interp :result "localhost"))
; info script — stub
((equal? sub "script")
(assoc interp :result ""))
; info tclversion — stub
((equal? sub "tclversion")
(assoc interp :result "8.6"))
(else (error (str "info: unknown subcommand \"" sub "\""))))))))
; --- coroutine support ---
; yield: inside a coroutine body, record a yielded value
(define
tcl-cmd-yield
(fn
(interp args)
(let
((val (if (> (len args) 0) (first args) "")))
(if
(get interp :in-coro)
(assoc
(assoc interp :coro-yields (append (get interp :coro-yields) (list val)))
:result "")
(error "yield called outside coroutine")))))
; yieldto: stub — yield empty string
(define
tcl-cmd-yieldto
(fn
(interp args)
(if
(get interp :in-coro)
(assoc
(assoc interp :coro-yields (append (get interp :coro-yields) (list "")))
:result "")
(error "yieldto called outside coroutine"))))
; make-coro-cmd: returns a command function that pops values from the coroutine's yields list
(define
make-coro-cmd
(fn
(coro-name)
(fn
(interp args)
(let
((coros (get interp :coroutines)))
(let
((coro (get coros coro-name)))
(if
(nil? coro)
(error (str "coroutine \"" coro-name "\" not found"))
(let
((yields (get coro :yields))
(pos (get coro :pos)))
(if
(>= pos (len yields))
(assoc interp :result "")
(let
((val (nth yields pos)))
(let
((new-coro (assoc coro :pos (+ pos 1))))
(assoc
(assoc interp :coroutines (assoc coros coro-name new-coro))
:result val)))))))))))
; coroutine: execute proc eagerly in a coroutine context, collecting all yields
(define
tcl-cmd-coroutine
(fn
(interp args)
(if
(< (len args) 2)
(error "coroutine: wrong # args")
(let
((coro-name (first args))
(cmd-name (nth args 1))
(call-args (rest (rest args))))
; set up coroutine context
(let
((coro-interp
(assoc interp
:in-coro true
:coro-yields (list)
:result ""
:code 0)))
; find the command or proc and execute it
(let
((cmd-fn (get (get coro-interp :commands) cmd-name)))
(let
((exec-result
(if
(nil? cmd-fn)
(let
((proc-entry (tcl-proc-lookup coro-interp cmd-name)))
(if
(nil? proc-entry)
(error (str "coroutine: unknown command \"" cmd-name "\""))
(tcl-call-proc coro-interp (get proc-entry :name) (get proc-entry :def) call-args)))
(cmd-fn coro-interp call-args))))
(let
((yields (get exec-result :coro-yields)))
; build the coroutine state
(let
((new-coros (assoc (get exec-result :coroutines) coro-name {:yields yields :pos 0})))
; register the coroutine command in the commands dict
(let
((new-commands (assoc (get exec-result :commands) coro-name (make-coro-cmd coro-name))))
(assoc exec-result
:coroutines new-coros
:commands new-commands
:in-coro false
:coro-yields (list)
:result "")))))))))))
; --- clock command (stubs) ---
(define
tcl-cmd-clock
(fn
(interp args)
(if
(= 0 (len args))
(error "clock: wrong # args")
(let
((sub (first args)) (rest-args (rest args)))
(cond
((equal? sub "seconds") (assoc interp :result "0"))
((equal? sub "milliseconds") (assoc interp :result "0"))
((equal? sub "format") (assoc interp :result "Thu Jan 1 00:00:00 UTC 1970"))
((equal? sub "scan") (assoc interp :result "0"))
(else (error (str "clock: unknown subcommand \"" sub "\""))))))))
; --- file I/O stubs ---
(define
tcl-cmd-open
(fn
(interp args)
(assoc interp :result "file0")))
(define
tcl-cmd-close
(fn
(interp args)
(assoc interp :result "")))
(define
tcl-cmd-read
(fn
(interp args)
(assoc interp :result "")))
; gets channel ?varname?
(define
tcl-cmd-gets-chan
(fn
(interp args)
(if
(> (len args) 1)
; gets channel varname: store "" and return -1 (EOF)
(assoc (tcl-var-set interp (nth args 1) "") :result "-1")
; gets channel: return "" (EOF)
(assoc interp :result ""))))
(define
tcl-cmd-eof
(fn
(interp args)
(assoc interp :result "1")))
(define
tcl-cmd-seek
(fn
(interp args)
(assoc interp :result "")))
(define
tcl-cmd-tell
(fn
(interp args)
(assoc interp :result "0")))
(define
tcl-cmd-flush
(fn
(interp args)
(assoc interp :result "")))
; file command dispatcher
(define
tcl-cmd-file
(fn
(interp args)
(if
(= 0 (len args))
(error "file: wrong # args")
(let
((sub (first args)) (rest-args (rest args)))
(cond
((equal? sub "exists")
(assoc interp :result "0"))
((equal? sub "join")
(assoc interp :result (join "/" rest-args)))
((equal? sub "split")
(assoc interp :result (tcl-list-build (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/")))))
((equal? sub "tail")
(let
((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/"))))
(assoc interp :result (if (= 0 (len parts)) "" (last parts)))))
((equal? sub "dirname")
(let
((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/"))))
(assoc interp :result
(if
(<= (len parts) 1)
"."
(str "/" (join "/" (take-n parts (- (len parts) 1))))))))
((equal? sub "extension")
(let
((nm (first rest-args)))
(let
((dot-idx (tcl-string-last "." nm (- (string-length nm) 1))))
(assoc interp :result
(if
(equal? dot-idx "-1")
""
(substring nm (parse-int dot-idx) (string-length nm)))))))
((equal? sub "rootname")
(let
((nm (first rest-args)))
(let
((dot-idx (tcl-string-last "." nm (- (string-length nm) 1))))
(assoc interp :result
(if
(equal? dot-idx "-1")
nm
(substring nm 0 (parse-int dot-idx)))))))
((equal? sub "isfile") (assoc interp :result "0"))
((equal? sub "isdir") (assoc interp :result "0"))
((equal? sub "isdirectory") (assoc interp :result "0"))
((equal? sub "readable") (assoc interp :result "0"))
((equal? sub "writable") (assoc interp :result "0"))
((equal? sub "size") (assoc interp :result "0"))
((equal? sub "mkdir") (assoc interp :result ""))
((equal? sub "copy") (assoc interp :result ""))
((equal? sub "rename") (assoc interp :result ""))
((equal? sub "delete") (assoc interp :result ""))
(else (error (str "file: unknown subcommand \"" sub "\""))))))))
(define
make-default-tcl-interp
(fn
@@ -2872,4 +3263,28 @@
((i (tcl-register i "throw" tcl-cmd-throw)))
(let
((i (tcl-register i "try" tcl-cmd-try)))
(tcl-register i "namespace" tcl-cmd-namespace))))))))))))))))))))))))))))))))))))))))))))))))
(let
((i (tcl-register i "namespace" tcl-cmd-namespace)))
(let
((i (tcl-register i "coroutine" tcl-cmd-coroutine)))
(let
((i (tcl-register i "yield" tcl-cmd-yield)))
(let
((i (tcl-register i "yieldto" tcl-cmd-yieldto)))
(let
((i (tcl-register i "clock" tcl-cmd-clock)))
(let
((i (tcl-register i "open" tcl-cmd-open)))
(let
((i (tcl-register i "close" tcl-cmd-close)))
(let
((i (tcl-register i "read" tcl-cmd-read)))
(let
((i (tcl-register i "eof" tcl-cmd-eof)))
(let
((i (tcl-register i "seek" tcl-cmd-seek)))
(let
((i (tcl-register i "tell" tcl-cmd-tell)))
(let
((i (tcl-register i "flush" tcl-cmd-flush)))
(tcl-register i "file" tcl-cmd-file))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

36
lib/tcl/test.sh
View File

@@ -20,11 +20,15 @@ cat > "$HELPER" << 'HELPER_EOF'
(define __er (tcl-run-eval-tests))
(define __xr (tcl-run-error-tests))
(define __nr (tcl-run-namespace-tests))
(define __cr (tcl-run-coro-tests))
(define __ir (tcl-run-idiom-tests))
(define tcl-test-summary
(str "PARSE:" (get __pr "passed") ":" (get __pr "failed")
" EVAL:" (get __er "passed") ":" (get __er "failed")
" ERROR:" (get __xr "passed") ":" (get __xr "failed")
" NAMESPACE:" (get __nr "passed") ":" (get __nr "failed")))
" NAMESPACE:" (get __nr "passed") ":" (get __nr "failed")
" CORO:" (get __cr "passed") ":" (get __cr "failed")
" IDIOM:" (get __ir "passed") ":" (get __ir "failed")))
HELPER_EOF
cat > "$TMPFILE" << EPOCHS
@@ -43,16 +47,20 @@ cat > "$TMPFILE" << EPOCHS
(epoch 7)
(load "lib/tcl/tests/namespace.sx")
(epoch 8)
(load "$HELPER")
(load "lib/tcl/tests/coro.sx")
(epoch 9)
(load "lib/tcl/tests/idioms.sx")
(epoch 10)
(load "$HELPER")
(epoch 11)
(eval "tcl-test-summary")
EPOCHS
OUTPUT=$(timeout 90 "$SX_SERVER" < "$TMPFILE" 2>&1)
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&1)
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
# Extract summary line from epoch 9 output
SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 9 " | tail -1 | tr -d '"')
# Extract summary line from epoch 11 output
SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 11 " | tail -1 | tr -d '"')
if [ -z "$SUMMARY" ]; then
echo "ERROR: no summary from test run"
@@ -60,11 +68,13 @@ if [ -z "$SUMMARY" ]; then
exit 1
fi
# Parse PARSE:N:M EVAL:N:M ERROR:N:M NAMESPACE:N:M
# Parse PARSE:N:M EVAL:N:M ERROR:N:M NAMESPACE:N:M CORO:N:M IDIOM:N:M
PARSE_PART=$(echo "$SUMMARY" | grep -o 'PARSE:[0-9]*:[0-9]*')
EVAL_PART=$(echo "$SUMMARY" | grep -o 'EVAL:[0-9]*:[0-9]*')
ERROR_PART=$(echo "$SUMMARY" | grep -o 'ERROR:[0-9]*:[0-9]*')
NAMESPACE_PART=$(echo "$SUMMARY" | grep -o 'NAMESPACE:[0-9]*:[0-9]*')
CORO_PART=$(echo "$SUMMARY" | grep -o 'CORO:[0-9]*:[0-9]*')
IDIOM_PART=$(echo "$SUMMARY" | grep -o 'IDIOM:[0-9]*:[0-9]*')
PARSE_PASSED=$(echo "$PARSE_PART" | cut -d: -f2)
PARSE_FAILED=$(echo "$PARSE_PART" | cut -d: -f3)
@@ -74,21 +84,27 @@ ERROR_PASSED=$(echo "$ERROR_PART" | cut -d: -f2)
ERROR_FAILED=$(echo "$ERROR_PART" | cut -d: -f3)
NAMESPACE_PASSED=$(echo "$NAMESPACE_PART" | cut -d: -f2)
NAMESPACE_FAILED=$(echo "$NAMESPACE_PART" | cut -d: -f3)
CORO_PASSED=$(echo "$CORO_PART" | cut -d: -f2)
CORO_FAILED=$(echo "$CORO_PART" | cut -d: -f3)
IDIOM_PASSED=$(echo "$IDIOM_PART" | cut -d: -f2)
IDIOM_FAILED=$(echo "$IDIOM_PART" | cut -d: -f3)
PARSE_PASSED=${PARSE_PASSED:-0}; PARSE_FAILED=${PARSE_FAILED:-1}
EVAL_PASSED=${EVAL_PASSED:-0}; EVAL_FAILED=${EVAL_FAILED:-1}
ERROR_PASSED=${ERROR_PASSED:-0}; ERROR_FAILED=${ERROR_FAILED:-1}
NAMESPACE_PASSED=${NAMESPACE_PASSED:-0}; NAMESPACE_FAILED=${NAMESPACE_FAILED:-1}
CORO_PASSED=${CORO_PASSED:-0}; CORO_FAILED=${CORO_FAILED:-1}
IDIOM_PASSED=${IDIOM_PASSED:-0}; IDIOM_FAILED=${IDIOM_FAILED:-1}
TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED + ERROR_PASSED + NAMESPACE_PASSED))
TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED + ERROR_FAILED + NAMESPACE_FAILED))
TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED + ERROR_PASSED + NAMESPACE_PASSED + CORO_PASSED + IDIOM_PASSED))
TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED + ERROR_FAILED + NAMESPACE_FAILED + CORO_FAILED + IDIOM_FAILED))
TOTAL=$((TOTAL_PASSED + TOTAL_FAILED))
if [ "$TOTAL_FAILED" = "0" ]; then
echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED, error: $ERROR_PASSED, namespace: $NAMESPACE_PASSED)"
echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED, error: $ERROR_PASSED, namespace: $NAMESPACE_PASSED, coro: $CORO_PASSED, idiom: $IDIOM_PASSED)"
exit 0
else
echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)), error: $ERROR_PASSED/$((ERROR_PASSED+ERROR_FAILED)), namespace: $NAMESPACE_PASSED/$((NAMESPACE_PASSED+NAMESPACE_FAILED)))"
echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)), error: $ERROR_PASSED/$((ERROR_PASSED+ERROR_FAILED)), namespace: $NAMESPACE_PASSED/$((NAMESPACE_PASSED+NAMESPACE_FAILED)), coro: $CORO_PASSED/$((CORO_PASSED+CORO_FAILED)), idiom: $IDIOM_PASSED/$((IDIOM_PASSED+IDIOM_FAILED)))"
if [ -z "$VERBOSE" ]; then
echo "--- output ---"
echo "$OUTPUT" | tail -30

136
lib/tcl/tests/coro.sx Normal file
View File

@@ -0,0 +1,136 @@
; Tcl-on-SX coroutine tests (Phase 6)
(define tcl-coro-pass 0)
(define tcl-coro-fail 0)
(define tcl-coro-failures (list))
(define
tcl-coro-assert
(fn
(label expected actual)
(if
(equal? expected actual)
(set! tcl-coro-pass (+ tcl-coro-pass 1))
(begin
(set! tcl-coro-fail (+ tcl-coro-fail 1))
(append!
tcl-coro-failures
(str label ": expected=" (str expected) " got=" (str actual)))))))
(define
tcl-run-coro-tests
(fn
()
(set! tcl-coro-pass 0)
(set! tcl-coro-fail 0)
(set! tcl-coro-failures (list))
(define interp (fn () (make-default-tcl-interp)))
(define run (fn (src) (tcl-eval-string (interp) src)))
(define
ok
(fn (label actual expected) (tcl-coro-assert label expected actual)))
; --- basic coroutine: yields one value ---
(ok "coro-single-yield"
(get (run "proc gen {} { yield hello }\ncoroutine g gen\ng") :result)
"hello")
; --- coroutine yields multiple values in order ---
(ok "coro-multi-yield-1"
(get (run "proc cnt {} { yield a; yield b; yield c }\ncoroutine c1 cnt\nc1") :result)
"a")
(ok "coro-multi-yield-2"
(get (run "proc cnt {} { yield a; yield b; yield c }\ncoroutine c1 cnt\nc1\nc1") :result)
"b")
(ok "coro-multi-yield-3"
(get (run "proc cnt {} { yield a; yield b; yield c }\ncoroutine c1 cnt\nc1\nc1\nc1") :result)
"c")
; --- coroutine with arguments to proc ---
(ok "coro-args"
(get (run "proc gen2 {n} { yield $n; yield [expr {$n + 1}] }\ncoroutine g2 gen2 10\ng2") :result)
"10")
(ok "coro-args-2"
(get (run "proc gen2 {n} { yield $n; yield [expr {$n + 1}] }\ncoroutine g2 gen2 10\ng2\ng2") :result)
"11")
; --- coroutine exhausted returns empty string ---
(ok "coro-exhausted"
(get (run "proc g3 {} { yield only }\ncoroutine c3 g3\nc3\nc3") :result)
"")
; --- yield in while loop ---
(ok "coro-while-loop-1"
(get (run "proc counter {max} { set i 0; while {$i < $max} { yield $i; incr i } }\ncoroutine cw counter 3\ncw") :result)
"0")
(ok "coro-while-loop-2"
(get (run "proc counter {max} { set i 0; while {$i < $max} { yield $i; incr i } }\ncoroutine cw counter 3\ncw\ncw") :result)
"1")
(ok "coro-while-loop-3"
(get (run "proc counter {max} { set i 0; while {$i < $max} { yield $i; incr i } }\ncoroutine cw counter 3\ncw\ncw\ncw") :result)
"2")
; --- collect all yields from coroutine ---
(ok "coro-collect-all"
(get
(run
"proc counter {n max} { while {$n < $max} { yield $n; incr n }; yield done }\ncoroutine gen1 counter 0 3\nset out {}\nfor {set i 0} {$i < 4} {incr i} { lappend out [gen1] }\nlindex $out 3")
:result)
"done")
; --- two independent coroutines ---
(ok "coro-two-independent"
(get
(run
"proc seq {start} { yield $start; yield [expr {$start+1}] }\ncoroutine ca seq 0\ncoroutine cb seq 10\nset r [ca]\nappend r \":\" [cb]")
:result)
"0:10")
; --- yield with no value returns empty string ---
(ok "coro-yield-no-val"
(get (run "proc g {} { yield }\ncoroutine cg g\ncg") :result)
"")
; --- clock seconds stub ---
(ok "clock-seconds"
(get (run "clock seconds") :result)
"0")
; --- clock milliseconds stub ---
(ok "clock-milliseconds"
(get (run "clock milliseconds") :result)
"0")
; --- clock format stub ---
(ok "clock-format"
(get (run "clock format 0") :result)
"Thu Jan 1 00:00:00 UTC 1970")
; --- file stubs ---
(ok "file-exists-stub"
(get (run "file exists /no/such/file") :result)
"0")
(ok "file-join"
(get (run "file join foo bar baz") :result)
"foo/bar/baz")
(ok "open-returns-channel"
(get (run "open /dev/null r") :result)
"file0")
(ok "eof-returns-1"
(get (run "set ch [open /dev/null r]\neof $ch") :result)
"1")
(dict
"passed"
tcl-coro-pass
"failed"
tcl-coro-fail
"failures"
tcl-coro-failures)))

193
lib/tcl/tests/idioms.sx Normal file
View File

@@ -0,0 +1,193 @@
; Tcl-on-SX idiom corpus (Phase 6)
; Classic Tcl idioms covering lists, dicts, procs, patterns
(define tcl-idiom-pass 0)
(define tcl-idiom-fail 0)
(define tcl-idiom-failures (list))
(define
tcl-idiom-assert
(fn
(label expected actual)
(if
(equal? expected actual)
(set! tcl-idiom-pass (+ tcl-idiom-pass 1))
(begin
(set! tcl-idiom-fail (+ tcl-idiom-fail 1))
(append!
tcl-idiom-failures
(str label ": expected=" (str expected) " got=" (str actual)))))))
(define
tcl-run-idiom-tests
(fn
()
(set! tcl-idiom-pass 0)
(set! tcl-idiom-fail 0)
(set! tcl-idiom-failures (list))
(define interp (fn () (make-default-tcl-interp)))
(define run (fn (src) (tcl-eval-string (interp) src)))
(define
ok
(fn (label actual expected) (tcl-idiom-assert label expected actual)))
; 1. lmap idiom: accumulate mapped values with foreach+lappend
(ok "idiom-lmap"
(get
(run "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result")
:result)
"1 4 9")
; 2. Recursive list flatten
(ok "idiom-flatten"
(get
(run
"proc flatten {lst} { set out {}\n foreach item $lst {\n if {[llength $item] > 1} {\n foreach sub [flatten $item] { lappend out $sub }\n } else {\n lappend out $item\n }\n }\n return $out\n}\nflatten {1 {2 3} {4 {5 6}}}")
:result)
"1 2 3 4 5 6")
; 3. String builder accumulator
(ok "idiom-string-builder"
(get
(run "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf")
:result)
"Hello World Tcl")
; 4. Default parameter via info exists
(ok "idiom-default-param"
(get
(run "if {![info exists x]} { set x 42 }\nset x")
:result)
"42")
; 5. Association list lookup (parallel key/value lists)
(ok "idiom-alist-lookup"
(get
(run
"set keys {a b c}\nset vals {10 20 30}\nset idx [lsearch $keys b]\nlindex $vals $idx")
:result)
"20")
; 6. Proc with optional args via args
(ok "idiom-optional-args"
(get
(run
"proc greet {name args} {\n set greeting \"Hello\"\n if {[llength $args] > 0} { set greeting [lindex $args 0] }\n return \"$greeting $name\"\n}\ngreet World Hi")
:result)
"Hi World")
; 7. Builder pattern: dict create from args
(ok "idiom-dict-builder"
(get
(run
"proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name")
:result)
"Alice")
; 8. Loop with index using array
(ok "idiom-loop-with-index"
(get
(run
"set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)")
:result)
"b")
; 9. String reverse via split+lreverse+join
(ok "idiom-string-reverse"
(get
(run
"set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"")
:result)
"olleh")
; 10. Number to padded string
(ok "idiom-number-format"
(get (run "format \"%05d\" 42") :result)
"00042")
; 11. Dict comprehension pattern
(ok "idiom-dict-comprehension"
(get
(run
"set squares {}\nforeach n {1 2 3 4} { dict set squares $n [expr {$n * $n}] }\ndict get $squares 3")
:result)
"9")
; 12. Stack ADT using list: push/pop
(ok "idiom-stack"
(get
(run
"proc stack-push {stackvar val} { upvar $stackvar s; lappend s $val }\nproc stack-pop {stackvar} { upvar $stackvar s; set val [lindex $s end]; set s [lrange $s 0 end-1]; return $val }\nset stk {}\nstack-push stk 10\nstack-push stk 20\nstack-push stk 30\nstack-pop stk")
:result)
"30")
; 13. Queue ADT using list: enqueue/dequeue
(ok "idiom-queue"
(get
(run
"proc q-enq {qvar val} { upvar $qvar q; lappend q $val }\nproc q-deq {qvar} { upvar $qvar q; set val [lindex $q 0]; set q [lrange $q 1 end]; return $val }\nset q {}\nq-enq q alpha\nq-enq q beta\nq-enq q gamma\nq-deq q")
:result)
"alpha")
; 14. Pipeline via proc chaining
(ok "idiom-pipeline"
(get
(run
"proc double {x} { expr {$x * 2} }\nproc add1 {x} { expr {$x + 1} }\nproc pipeline {val procs} { foreach p $procs { set val [$p $val] }; return $val }\npipeline 5 {double add1 double}")
:result)
"22")
; 15. Memoize pattern using dict (simple cache, not recursive)
(ok "idiom-memoize"
(get
(run
"set cache {}\nproc cached-square {n} { global cache\n if {[dict exists $cache $n]} { return [dict get $cache $n] }\n set r [expr {$n * $n}]\n dict set cache $n $r\n return $r\n}\nset a [cached-square 7]\nset b [cached-square 7]\nset c [cached-square 8]\nexpr {$a == $b && $c == 64}")
:result)
"1")
; 16. Simple expression evaluator in Tcl (recursive descent)
(ok "idiom-recursive-eval"
(get
(run
"proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}")
:result)
"11")
; 17. Apply proc to each pair in a dict
(ok "idiom-dict-for"
(get
(run
"set d [dict create a 1 b 2 c 3]\nset total 0\ndict for {k v} $d { incr total $v }\nset total")
:result)
"6")
; 18. Find max in list
(ok "idiom-find-max"
(get
(run
"proc list-max {lst} {\n set m [lindex $lst 0]\n foreach x $lst { if {$x > $m} { set m $x } }\n return $m\n}\nlist-max {3 1 4 1 5 9 2 6}")
:result)
"9")
; 19. Filter list by predicate
(ok "idiom-filter-list"
(get
(run
"proc list-filter {lst pred} {\n set out {}\n foreach x $lst { if {[$pred $x]} { lappend out $x } }\n return $out\n}\nproc is-even {n} { expr {$n % 2 == 0} }\nlist-filter {1 2 3 4 5 6} is-even")
:result)
"2 4 6")
; 20. Zip two lists
(ok "idiom-zip"
(get
(run
"proc zip {a b} {\n set out {}\n set n [llength $a]\n for {set i 0} {$i < $n} {incr i} {\n lappend out [lindex $a $i]\n lappend out [lindex $b $i]\n }\n return $out\n}\nzip {1 2 3} {a b c}")
:result)
"1 a 2 b 3 c")
(dict
"passed"
tcl-idiom-pass
"failed"
tcl-idiom-fail
"failures"
tcl-idiom-failures)))

22
lib/tcl/tests/programs/event-loop.tcl Normal file
View File

@@ -0,0 +1,22 @@
# expected: done
# Cooperative scheduler demo using coroutines (generator style)
# coroutine eagerly collects all yields; invoking the coroutine name pops values
proc counter {n max} {
while {$n < $max} {
yield $n
incr n
}
yield done
}
coroutine gen1 counter 0 3
# gen1 yields: 0 1 2 done
set out {}
for {set i 0} {$i < 4} {incr i} {
lappend out [gen1]
}
# last val is "done"
lindex $out 3