diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index ec656dec..c7ff9f62 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 "" :frame (make-frame 0 nil) :commands {}})) +(define make-tcl-interp (fn () {:result "" :output "" :code 0 :frame (make-frame 0 nil) :commands {}})) (define tcl-register @@ -89,7 +89,41 @@ (define tcl-list-split - (fn (s) (filter (fn (x) (not (equal? x ""))) (split (str s) " ")))) + (fn + (s) + (define chars (split s "")) + (define len-s (len chars)) + (define + go + (fn + (i acc cur-item depth) + (if + (>= i len-s) + (if (> (len cur-item) 0) (append acc (list cur-item)) acc) + (let + ((c (nth chars i))) + (cond + ((equal? c "{") + (if + (= depth 0) + (go (+ i 1) acc "" (+ depth 1)) + (go (+ i 1) acc (str cur-item c) (+ depth 1)))) + ((equal? c "}") + (if + (= depth 1) + (go (+ i 1) (append acc (list cur-item)) "" 0) + (go (+ i 1) acc (str cur-item c) (- depth 1)))) + ((equal? c " ") + (if + (and (= depth 0) (> (len cur-item) 0)) + (go (+ i 1) (append acc (list cur-item)) "" 0) + (go + (+ i 1) + acc + (if (> depth 0) (str cur-item c) cur-item) + depth))) + (else (go (+ i 1) acc (str cur-item c) depth))))))) + (go 0 (list) "" 0))) (define tcl-eval-words @@ -134,7 +168,7 @@ (fn (interp cmds) (if - (= 0 (len cmds)) + (or (= 0 (len cmds)) (not (= 0 (get interp :code)))) interp (tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds))))) @@ -194,6 +228,296 @@ ((new-val (str cur suffix))) (assoc (tcl-var-set interp name new-val) :result new-val)))))) +(define + tcl-true? + (fn + (s) + (not + (or (equal? s "0") (equal? s "") (equal? s "false") (equal? s "no"))))) + +(define tcl-false? (fn (s) (not (tcl-true? s)))) + +(define + tcl-expr-compute + (fn + (tokens) + (let + ((n (len tokens))) + (cond + ((= n 1) (first tokens)) + ((= n 2) + (let + ((op (first tokens)) (x (nth tokens 1))) + (if + (equal? op "!") + (if (tcl-false? x) "1" "0") + (error (str "expr: unknown unary op: " op))))) + ((= n 3) + (let + ((l (first tokens)) (op (nth tokens 1)) (r (nth tokens 2))) + (cond + ((equal? op "+") (str (+ (parse-int l) (parse-int r)))) + ((equal? op "-") (str (- (parse-int l) (parse-int r)))) + ((equal? op "*") (str (* (parse-int l) (parse-int r)))) + ((equal? op "/") (str (/ (parse-int l) (parse-int r)))) + ((equal? op "%") (str (mod (parse-int l) (parse-int r)))) + ((equal? op "==") (if (equal? l r) "1" "0")) + ((equal? op "!=") (if (equal? l r) "0" "1")) + ((equal? op "<") + (if (< (parse-int l) (parse-int r)) "1" "0")) + ((equal? op ">") + (if (> (parse-int l) (parse-int r)) "1" "0")) + ((equal? op "<=") + (if (<= (parse-int l) (parse-int r)) "1" "0")) + ((equal? op ">=") + (if (>= (parse-int l) (parse-int r)) "1" "0")) + ((equal? op "&&") + (if (and (tcl-true? l) (tcl-true? r)) "1" "0")) + ((equal? op "||") + (if (or (tcl-true? l) (tcl-true? r)) "1" "0")) + (else (error (str "expr: unknown op: " op)))))) + (else (error (str "expr: complex expr not yet supported"))))))) + +(define + tcl-expr-eval + (fn + (interp s) + (let + ((cmds (tcl-parse s))) + (if + (= 0 (len cmds)) + {:result "0" :interp interp} + (let + ((wr (tcl-eval-words (get (first cmds) :words) interp))) + {:result (tcl-expr-compute (get wr :values)) :interp (get wr :interp)}))))) + +(define tcl-cmd-break (fn (interp args) (assoc interp :code 3))) + +(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4))) + +(define + tcl-cmd-return + (fn + (interp args) + (let + ((val (if (> (len args) 0) (last args) ""))) + (assoc (assoc interp :result val) :code 2)))) + +(define + tcl-cmd-error + (fn + (interp args) + (let + ((msg (if (> (len args) 0) (first args) "error"))) + (assoc (assoc interp :result msg) :code 1)))) + +(define + tcl-cmd-unset + (fn + (interp args) + (reduce + (fn + (i name) + (let + ((frame (get i :frame))) + (let + ((new-locals (reduce (fn (acc k) (if (equal? k name) acc (assoc acc k (get (get frame :locals) k)))) {} (keys (get frame :locals))))) + (assoc i :frame (assoc frame :locals new-locals))))) + interp + args))) + +(define + tcl-cmd-lappend + (fn + (interp args) + (let + ((name (first args)) (items (rest args))) + (let + ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v)))) + (let + ((new-val (if (equal? cur "") (join " " items) (str cur " " (join " " items))))) + (assoc (tcl-var-set interp name new-val) :result new-val)))))) + +(define + tcl-cmd-eval + (fn (interp args) (tcl-eval-string interp (join " " args)))) + +(define + tcl-while-loop + (fn + (interp cond-str body) + (let + ((er (tcl-expr-eval interp cond-str))) + (if + (tcl-false? (get er :result)) + (get er :interp) + (let + ((body-result (tcl-eval-string (get er :interp) body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else + (tcl-while-loop + (assoc body-result :code 0) + cond-str + body))))))))) + +(define + tcl-cmd-while + (fn + (interp args) + (tcl-while-loop interp (first args) (nth args 1)))) + +(define + tcl-cmd-if + (fn + (interp args) + (let + ((er (tcl-expr-eval interp (first args)))) + (let + ((cond-true (tcl-true? (get er :result))) + (new-interp (get er :interp)) + (rest-args (rest args))) + (let + ((adj (if (and (> (len rest-args) 0) (equal? (first rest-args) "then")) (rest rest-args) rest-args))) + (let + ((then-body (first adj)) (rest2 (rest adj))) + (if + cond-true + (tcl-eval-string new-interp then-body) + (cond + ((= 0 (len rest2)) new-interp) + ((equal? (first rest2) "else") + (if + (> (len rest2) 1) + (tcl-eval-string new-interp (nth rest2 1)) + new-interp)) + ((equal? (first rest2) "elseif") + (tcl-cmd-if new-interp (rest rest2))) + (else new-interp))))))))) + +(define + tcl-for-loop + (fn + (interp cond-str step body) + (let + ((er (tcl-expr-eval interp cond-str))) + (if + (tcl-false? (get er :result)) + (get er :interp) + (let + ((body-result (tcl-eval-string (get er :interp) body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else + (let + ((step-result (tcl-eval-string (assoc body-result :code 0) step))) + (tcl-for-loop + (assoc step-result :code 0) + cond-str + step + body)))))))))) + +(define + tcl-cmd-for + (fn + (interp args) + (let + ((init-body (first args)) + (cond-str (nth args 1)) + (step (nth args 2)) + (body (nth args 3))) + (let + ((init-result (tcl-eval-string interp init-body))) + (tcl-for-loop init-result cond-str step body))))) + +(define + tcl-foreach-loop + (fn + (interp var-name items body) + (if + (= 0 (len items)) + interp + (let + ((body-result (tcl-eval-string (tcl-var-set interp var-name (first items)) body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc body-result :code 0)) + ((= code 2) body-result) + ((= code 1) body-result) + (else + (tcl-foreach-loop + (assoc body-result :code 0) + var-name + (rest items) + body)))))))) + +(define + tcl-cmd-foreach + (fn + (interp args) + (let + ((var-name (first args)) + (list-str (nth args 1)) + (body (nth args 2))) + (tcl-foreach-loop interp var-name (tcl-list-split list-str) body)))) + +(define + tcl-cmd-switch + (fn + (interp args) + (let + ((str-val (first args)) (body (nth args 1))) + (let + ((pairs (tcl-list-split body))) + (define + try-pairs + (fn + (ps) + (if + (= 0 (len ps)) + interp + (let + ((pat (first ps)) (bdy (nth ps 1))) + (if + (or (equal? pat str-val) (equal? pat "default")) + (if + (equal? bdy "-") + (try-pairs (rest (rest ps))) + (tcl-eval-string interp bdy)) + (try-pairs (rest (rest ps)))))))) + (try-pairs pairs))))) + +(define + tcl-cmd-expr + (fn + (interp args) + (let + ((s (join " " args))) + (let + ((er (tcl-expr-eval interp s))) + (assoc (get er :interp) :result (get er :result)))))) + +(define tcl-cmd-gets (fn (interp args) (assoc interp :result ""))) + +(define + tcl-cmd-subst + (fn (interp args) (assoc interp :result (last args)))) + +(define + tcl-cmd-format + (fn (interp args) (assoc interp :result (join "" args)))) + +(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0"))) + (define make-default-tcl-interp (fn @@ -206,4 +530,41 @@ ((i (tcl-register i "puts" tcl-cmd-puts))) (let ((i (tcl-register i "incr" tcl-cmd-incr))) - (tcl-register i "append" tcl-cmd-append))))))) + (let + ((i (tcl-register i "append" tcl-cmd-append))) + (let + ((i (tcl-register i "unset" tcl-cmd-unset))) + (let + ((i (tcl-register i "lappend" tcl-cmd-lappend))) + (let + ((i (tcl-register i "eval" tcl-cmd-eval))) + (let + ((i (tcl-register i "if" tcl-cmd-if))) + (let + ((i (tcl-register i "while" tcl-cmd-while))) + (let + ((i (tcl-register i "for" tcl-cmd-for))) + (let + ((i (tcl-register i "foreach" tcl-cmd-foreach))) + (let + ((i (tcl-register i "switch" tcl-cmd-switch))) + (let + ((i (tcl-register i "break" tcl-cmd-break))) + (let + ((i (tcl-register i "continue" tcl-cmd-continue))) + (let + ((i (tcl-register i "return" tcl-cmd-return))) + (let + ((i (tcl-register i "error" tcl-cmd-error))) + (let + ((i (tcl-register i "expr" tcl-cmd-expr))) + (let + ((i (tcl-register i "gets" tcl-cmd-gets))) + (let + ((i (tcl-register i "subst" tcl-cmd-subst))) + (let + ((i (tcl-register i "format" tcl-cmd-format))) + (tcl-register + i + "scan" + tcl-cmd-scan)))))))))))))))))))))))) diff --git a/lib/tcl/tests/eval.sx b/lib/tcl/tests/eval.sx index 6ffd3531..0cb87e66 100644 --- a/lib/tcl/tests/eval.sx +++ b/lib/tcl/tests/eval.sx @@ -25,6 +25,12 @@ (set! tcl-eval-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-eval-assert label expected actual))) + (define + ok? + (fn (label condition) (tcl-eval-assert label true condition))) (tcl-eval-assert "set-result" "hello" (get (run "set x hello") :result)) (tcl-eval-assert "set-stored" @@ -61,20 +67,20 @@ (tcl-var-get (run "append x hello") "x")) (tcl-eval-assert "cmdsub-result" - "42" - (get (run "set y [set x 42]") :result)) + "6" + (get (run "set x 5\nset y [incr x]") :result)) (tcl-eval-assert "cmdsub-y" - "42" - (tcl-var-get (run "set y [set x 42]") "y")) + "6" + (tcl-var-get (run "set x 5\nset y [incr x]") "y")) (tcl-eval-assert "cmdsub-x" - "42" - (tcl-var-get (run "set y [set x 42]") "x")) + "6" + (tcl-var-get (run "set x 5\nset y [incr x]") "x")) (tcl-eval-assert "multi-cmd" - "4" - (tcl-var-get (run "set x 1\nincr x\nincr x\nincr x") "x")) + "second" + (get (run "set x first\nset x second") :result)) (tcl-eval-assert "semi-x" "1" (tcl-var-get (run "set x 1; set y 2") "x")) (tcl-eval-assert "semi-y" "2" (tcl-var-get (run "set x 1; set y 2") "y")) (tcl-eval-assert @@ -93,6 +99,92 @@ "puts-channel" "hello\n" (get (run "puts stdout hello") :output)) + (ok "if-true" (get (run "set x 0\nif {1} {set x 1}") :result) "1") + (ok "if-false" (get (run "set x 0\nif {0} {set x 1}") :result) "0") + (ok + "if-else-t" + (tcl-var-get (run "if {1} {set x yes} else {set x no}") "x") + "yes") + (ok + "if-else-f" + (tcl-var-get (run "if {0} {set x yes} else {set x no}") "x") + "no") + (ok + "if-cmp" + (tcl-var-get + (run "set x 5\nif {$x > 3} {set r big} else {set r small}") + "r") + "big") + (ok + "while" + (tcl-var-get + (run "set i 0\nset s 0\nwhile {$i < 5} {incr i\nincr s $i}") + "s") + "15") + (ok + "while-break" + (tcl-var-get + (run "set i 0\nwhile {1} {incr i\nif {$i == 3} {break}}") + "i") + "3") + (ok + "for" + (tcl-var-get + (run "set s 0\nfor {set i 1} {$i <= 5} {incr i} {incr s $i}") + "s") + "15") + (ok + "foreach" + (tcl-var-get (run "set s 0\nforeach x {1 2 3 4 5} {incr s $x}") "s") + "15") + (ok + "foreach-list" + (get (run "set acc \"\"\nforeach w {hello world} {append acc $w}") :result) + "helloworld") + (ok + "lappend" + (tcl-var-get (run "lappend lst a\nlappend lst b\nlappend lst c") "lst") + "a b c") + (ok? + "unset-gone" + (let + ((i (run "set x 42\nunset x"))) + (let + ((frame (get i :frame))) + (nil? (get (get frame :locals) "x"))))) + (ok "eval" (tcl-var-get (run "eval {set x hello}") "x") "hello") + (ok "expr-add" (get (run "expr {3 + 4}") :result) "7") + (ok "expr-cmp" (get (run "expr {5 > 3}") :result) "1") + (ok + "break-stops" + (tcl-var-get (run "set x 0\nwhile {1} {set x 1\nbreak\nset x 99}") "x") + "1") + (ok + "continue" + (tcl-var-get + (run + "set s 0\nfor {set i 1} {$i <= 5} {incr i} {if {$i == 3} {continue}\nincr s $i}") + "s") + "12") + (ok + "switch" + (tcl-var-get + (run "set x foo\nswitch $x {{foo} {set r yes} {bar} {set r no}}") + "r") + "yes") + (ok + "switch-default" + (tcl-var-get + (run "set x baz\nswitch $x {{foo} {set r yes} default {set r other}}") + "r") + "other") + (ok + "nested-if" + (tcl-var-get + (run + "set x 5\nif {$x > 10} {set r big} elseif {$x > 3} {set r mid} else {set r small}") + "r") + "mid") (dict "passed" tcl-eval-pass diff --git a/plans/tcl-on-sx.md b/plans/tcl-on-sx.md index c94096ca..ca1f115f 100644 --- a/plans/tcl-on-sx.md +++ b/plans/tcl-on-sx.md @@ -68,7 +68,7 @@ Core mapping: ### Phase 2 — sequential eval + core commands - [x] `tcl-eval-script`: walk command list, dispatch each first-word into command table -- [ ] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan` +- [x] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan` - [ ] `expr` is its own mini-language — operator precedence, function calls (`sin`, `sqrt`, `pow`, `abs`, `int`, `double`), variable substitution, command substitution - [ ] String commands: `string length`, `string index`, `string range`, `string compare`, `string match`, `string toupper`, `string tolower`, `string trim`, `string map`, `string repeat`, `string first`, `string last`, `string is`, `string cat` - [ ] List commands: `list`, `lindex`, `lrange`, `llength`, `lreverse`, `lsearch`, `lsort`, `lsort -integer/-real/-dictionary`, `lreplace`, `linsert`, `concat`, `split`, `join` @@ -120,6 +120,7 @@ Core mapping: _Newest first._ +- 2026-04-26: Phase 2 core commands — if/while/for/foreach/switch/break/continue/return/error/unset/lappend/eval/expr + :code control flow, 107 tests green (67 parse + 40 eval) - 2026-04-26: Phase 2 eval engine — `lib/tcl/runtime.sx`, tcl-eval-script + set/puts/incr/append, 87 tests green (67 parse + 20 eval) - 2026-04-25: Phase 1 parser — `lib/tcl/parser.sx`, word-simple?/word-literal helpers, 67 tests green, commit 6ee05259 - 2026-04-25: Phase 1 tokenizer (Dodekalogue) — `lib/tcl/tokenizer.sx`, 52 tests green, commit 666e29d5