diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 651bd02d..7c7fe08c 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -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)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index 76ddc517..b9c74216 100755 --- a/lib/tcl/test.sh +++ b/lib/tcl/test.sh @@ -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 diff --git a/lib/tcl/tests/coro.sx b/lib/tcl/tests/coro.sx new file mode 100644 index 00000000..541ee625 --- /dev/null +++ b/lib/tcl/tests/coro.sx @@ -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))) diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx new file mode 100644 index 00000000..1a6fac71 --- /dev/null +++ b/lib/tcl/tests/idioms.sx @@ -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))) diff --git a/lib/tcl/tests/programs/event-loop.tcl b/lib/tcl/tests/programs/event-loop.tcl new file mode 100644 index 00000000..713ef384 --- /dev/null +++ b/lib/tcl/tests/programs/event-loop.tcl @@ -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