tcl: Phase 2 eval engine — tcl-eval-script + set/puts/incr/append (+20 tests, 87 total)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-26 14:02:52 +00:00
parent 35aa998fcc
commit 82da16e4bb
4 changed files with 360 additions and 20 deletions
--- a/lib/tcl/runtime.sx
+++ b/lib/tcl/runtime.sx
@@ -0,0 +1,209 @@
+; Tcl-on-SX runtime evaluator
+; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}
+
+(define make-frame (fn (level parent) {:level level :locals {} :parent parent}))
+
+(define
+  frame-lookup
+  (fn
+    (frame name)
+    (if
+      (nil? frame)
+      nil
+      (let
+        ((val (get (get frame :locals) name)))
+        (if (nil? val) (frame-lookup (get frame :parent) name) val)))))
+
+(define
+  frame-set-top
+  (fn
+    (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
+  tcl-register
+  (fn
+    (interp name f)
+    (assoc interp :commands (assoc (get interp :commands) name f))))
+
+(define
+  tcl-var-get
+  (fn
+    (interp name)
+    (let
+      ((val (frame-lookup (get interp :frame) name)))
+      (if
+        (nil? val)
+        (error (str "can't read \"" name "\": no such variable"))
+        val))))
+
+(define
+  tcl-var-set
+  (fn
+    (interp name val)
+    (assoc interp :frame (frame-set-top (get interp :frame) name val))))
+
+(define
+  tcl-eval-parts
+  (fn
+    (parts interp)
+    (reduce
+      (fn
+        (acc part)
+        (let
+          ((type (get part :type)) (cur-interp (get acc :interp)))
+          (cond
+            ((equal? type "text") {:values (append (get acc :values) (list (get part :value))) :interp cur-interp})
+            ((equal? type "var") {:values (append (get acc :values) (list (tcl-var-get cur-interp (get part :name)))) :interp cur-interp})
+            ((equal? type "var-arr")
+              (let
+                ((key-acc (tcl-eval-parts (get part :key) cur-interp)))
+                (let
+                  ((key (join "" (get key-acc :values)))
+                    (next-interp (get key-acc :interp)))
+                  {:values (append (get acc :values) (list (tcl-var-get next-interp (str (get part :name) "(" key ")")))) :interp next-interp})))
+            ((equal? type "cmd")
+              (let
+                ((new-interp (tcl-eval-string cur-interp (get part :src))))
+                {:values (append (get acc :values) (list (get new-interp :result))) :interp new-interp}))
+            (else (error (str "tcl: unknown part type: " type))))))
+      {:values (quote ()) :interp interp}
+      parts)))
+
+(define
+  tcl-eval-word
+  (fn
+    (word interp)
+    (let
+      ((type (get word :type)))
+      (cond
+        ((equal? type "braced") {:interp interp :value (get word :value)})
+        ((equal? type "compound")
+          (let
+            ((result (tcl-eval-parts (get word :parts) interp)))
+            {:interp (get result :interp) :value (join "" (get result :values))}))
+        ((equal? type "expand") (tcl-eval-word (get word :word) interp))
+        (else (error (str "tcl: unknown word type: " type)))))))
+
+(define
+  tcl-list-split
+  (fn (s) (filter (fn (x) (not (equal? x ""))) (split (str s) " "))))
+
+(define
+  tcl-eval-words
+  (fn
+    (words interp)
+    (reduce
+      (fn
+        (acc w)
+        (let
+          ((cur-interp (get acc :interp)))
+          (if
+            (equal? (get w :type) "expand")
+            (let
+              ((wr (tcl-eval-word (get w :word) cur-interp)))
+              {:values (append (get acc :values) (tcl-list-split (get wr :value))) :interp (get wr :interp)})
+            (let ((wr (tcl-eval-word w cur-interp))) {:values (append (get acc :values) (list (get wr :value))) :interp (get wr :interp)}))))
+      {:values (quote ()) :interp interp}
+      words)))
+
+(define
+  tcl-eval-cmd
+  (fn
+    (interp cmd)
+    (let
+      ((wr (tcl-eval-words (get cmd :words) interp)))
+      (let
+        ((words (get wr :values)) (cur-interp (get wr :interp)))
+        (if
+          (= 0 (len words))
+          cur-interp
+          (let
+            ((cmd-name (first words)) (cmd-args (rest words)))
+            (let
+              ((cmd-fn (get (get cur-interp :commands) cmd-name)))
+              (if
+                (nil? cmd-fn)
+                (error (str "unknown command: \"" cmd-name "\""))
+                (cmd-fn cur-interp cmd-args)))))))))
+
+(define
+  tcl-eval-script
+  (fn
+    (interp cmds)
+    (if
+      (= 0 (len cmds))
+      interp
+      (tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds)))))
+
+(define
+  tcl-eval-string
+  (fn (interp src) (tcl-eval-script interp (tcl-parse src))))
+
+(define
+  tcl-cmd-set
+  (fn
+    (interp args)
+    (if
+      (= (len args) 1)
+      (assoc interp :result (tcl-var-get interp (first args)))
+      (let
+        ((val (nth args 1)))
+        (assoc (tcl-var-set interp (first args) val) :result val)))))
+
+(define
+  tcl-cmd-puts
+  (fn
+    (interp args)
+    (let
+      ((text (last args))
+        (no-nl
+          (and
+            (> (len args) 1)
+            (equal? (first args) "-nonewline"))))
+      (let
+        ((line (if no-nl text (str text "\n"))))
+        (assoc interp :output (str (get interp :output) line))))))
+
+(define
+  tcl-cmd-incr
+  (fn
+    (interp args)
+    (let
+      ((name (first args))
+        (delta
+          (if
+            (> (len args) 1)
+            (parse-int (nth args 1))
+            1)))
+      (let
+        ((new-val (str (+ (parse-int (tcl-var-get interp name)) delta))))
+        (assoc (tcl-var-set interp name new-val) :result new-val)))))
+
+(define
+  tcl-cmd-append
+  (fn
+    (interp args)
+    (let
+      ((name (first args)) (suffix (join "" (rest args))))
+      (let
+        ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
+        (let
+          ((new-val (str cur suffix)))
+          (assoc (tcl-var-set interp name new-val) :result new-val))))))
+
+(define
+  make-default-tcl-interp
+  (fn
+    ()
+    (let
+      ((i (make-tcl-interp)))
+      (let
+        ((i (tcl-register i "set" tcl-cmd-set)))
+        (let
+          ((i (tcl-register i "puts" tcl-cmd-puts)))
+          (let
+            ((i (tcl-register i "incr" tcl-cmd-incr)))
+            (tcl-register i "append" tcl-cmd-append)))))))
--- a/lib/tcl/test.sh
+++ b/lib/tcl/test.sh
@@ -11,9 +11,19 @@ if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found"; exit 1; fi

 VERBOSE="${1:-}"
 TMPFILE=$(mktemp)
-trap "rm -f $TMPFILE" EXIT
+HELPER=$(mktemp --suffix=.sx)
+trap "rm -f $TMPFILE $HELPER" EXIT

-cat > "$TMPFILE" << 'EPOCHS'
+# Helper file: run both test suites and format a parseable summary string
+cat > "$HELPER" << 'HELPER_EOF'
+(define __pr (tcl-run-parse-tests))
+(define __er (tcl-run-eval-tests))
+(define tcl-test-summary
+  (str "PARSE:" (get __pr "passed") ":" (get __pr "failed")
+       " EVAL:" (get __er "passed") ":" (get __er "failed")))
+HELPER_EOF
+
+cat > "$TMPFILE" << EPOCHS
 (epoch 1)
 (load "lib/tcl/tokenizer.sx")
 (epoch 2)
@@ -21,33 +31,51 @@ cat > "$TMPFILE" << 'EPOCHS'
 (epoch 3)
 (load "lib/tcl/tests/parse.sx")
 (epoch 4)
-(eval "(tcl-run-parse-tests)")
+(load "lib/tcl/runtime.sx")
+(epoch 5)
+(load "lib/tcl/tests/eval.sx")
+(epoch 6)
+(load "$HELPER")
+(epoch 7)
+(eval "tcl-test-summary")
 EPOCHS

 OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>&1)
 [ "$VERBOSE" = "-v" ] && echo "$OUTPUT"

-# Result follows an (ok-len 3 N) line
-RESULT=$(echo "$OUTPUT" | grep -A1 "^(ok-len 4 " | tail -1)
-if [ -z "$RESULT" ]; then
-  RESULT=$(echo "$OUTPUT" | grep "^(ok 4 " | sed 's/^(ok 3 //' | sed 's/)$//')
-fi
-if [ -z "$RESULT" ]; then
-  echo "ERROR: no result from epoch 4"
-  echo "$OUTPUT" | tail -10
+# Extract summary line from epoch 7 output
+SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 7 " | tail -1 | tr -d '"')
+
+if [ -z "$SUMMARY" ]; then
+  echo "ERROR: no summary from test run"
+  echo "$OUTPUT" | tail -20
  exit 1
 fi

-PASSED=$(echo "$RESULT" | grep -o ':passed [0-9]*' | grep -o '[0-9]*$')
-FAILED=$(echo "$RESULT" | grep -o ':failed [0-9]*' | grep -o '[0-9]*$')
-PASSED=${PASSED:-0}; FAILED=${FAILED:-1}
-TOTAL=$((PASSED + FAILED))
+# Parse PARSE:N:M EVAL:N:M
+PARSE_PART=$(echo "$SUMMARY" | grep -o 'PARSE:[0-9]*:[0-9]*')
+EVAL_PART=$(echo "$SUMMARY"  | grep -o 'EVAL:[0-9]*:[0-9]*')

-if [ "$FAILED" = "0" ]; then
-  echo "ok $PASSED/$TOTAL tcl-tokenize tests passed"
+PARSE_PASSED=$(echo "$PARSE_PART" | cut -d: -f2)
+PARSE_FAILED=$(echo "$PARSE_PART" | cut -d: -f3)
+EVAL_PASSED=$(echo "$EVAL_PART"   | cut -d: -f2)
+EVAL_FAILED=$(echo "$EVAL_PART"   | cut -d: -f3)
+
+PARSE_PASSED=${PARSE_PASSED:-0}; PARSE_FAILED=${PARSE_FAILED:-1}
+EVAL_PASSED=${EVAL_PASSED:-0};   EVAL_FAILED=${EVAL_FAILED:-1}
+
+TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED))
+TOTAL_FAILED=$((PARSE_FAILED + EVAL_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)"
  exit 0
 else
-  echo "FAIL $PASSED/$TOTAL passed, $FAILED failed"
-  echo "$RESULT"
+  echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)))"
+  if [ -z "$VERBOSE" ]; then
+    echo "--- output ---"
+    echo "$OUTPUT" | tail -20
+  fi
  exit 1
 fi
--- a/lib/tcl/tests/eval.sx
+++ b/lib/tcl/tests/eval.sx
@@ -0,0 +1,102 @@
+; Tcl-on-SX eval tests
+(define tcl-eval-pass 0)
+(define tcl-eval-fail 0)
+(define tcl-eval-failures (list))
+
+(define
+  tcl-eval-assert
+  (fn
+    (label expected actual)
+    (if
+      (equal? expected actual)
+      (set! tcl-eval-pass (+ tcl-eval-pass 1))
+      (begin
+        (set! tcl-eval-fail (+ tcl-eval-fail 1))
+        (append!
+          tcl-eval-failures
+          (str label ": expected=" (str expected) " got=" (str actual)))))))
+
+(define
+  tcl-run-eval-tests
+  (fn
+    ()
+    (set! tcl-eval-pass 0)
+    (set! tcl-eval-fail 0)
+    (set! tcl-eval-failures (list))
+    (define interp (fn () (make-default-tcl-interp)))
+    (define run (fn (src) (tcl-eval-string (interp) src)))
+    (tcl-eval-assert "set-result" "hello" (get (run "set x hello") :result))
+    (tcl-eval-assert
+      "set-stored"
+      "hello"
+      (tcl-var-get (run "set x hello") "x"))
+    (tcl-eval-assert
+      "var-sub"
+      "hello"
+      (tcl-var-get (run "set x hello\nset y $x") "y"))
+    (tcl-eval-assert
+      "puts"
+      "world\n"
+      (get (run "set x world\nputs $x") :output))
+    (tcl-eval-assert
+      "puts-nonewline"
+      "hi"
+      (get (run "puts -nonewline hi") :output))
+    (tcl-eval-assert "incr" "6" (tcl-var-get (run "set x 5\nincr x") "x"))
+    (tcl-eval-assert
+      "incr-delta"
+      "8"
+      (tcl-var-get (run "set x 5\nincr x 3") "x"))
+    (tcl-eval-assert
+      "incr-neg"
+      "7"
+      (tcl-var-get (run "set x 10\nincr x -3") "x"))
+    (tcl-eval-assert
+      "append"
+      "foobar"
+      (tcl-var-get (run "set x foo\nappend x bar") "x"))
+    (tcl-eval-assert
+      "append-new"
+      "hello"
+      (tcl-var-get (run "append x hello") "x"))
+    (tcl-eval-assert
+      "cmdsub-result"
+      "42"
+      (get (run "set y [set x 42]") :result))
+    (tcl-eval-assert
+      "cmdsub-y"
+      "42"
+      (tcl-var-get (run "set y [set x 42]") "y"))
+    (tcl-eval-assert
+      "cmdsub-x"
+      "42"
+      (tcl-var-get (run "set y [set x 42]") "x"))
+    (tcl-eval-assert
+      "multi-cmd"
+      "4"
+      (tcl-var-get (run "set x 1\nincr x\nincr x\nincr x") "x"))
+    (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
+      "braced-nosub"
+      "$x"
+      (tcl-var-get (run "set x 42\nset y {$x}") "y"))
+    (tcl-eval-assert
+      "concat-word"
+      "foobar"
+      (tcl-var-get (run "set x foo\nset y ${x}bar") "y"))
+    (tcl-eval-assert
+      "set-get"
+      "world"
+      (get (run "set x world\nset x") :result))
+    (tcl-eval-assert
+      "puts-channel"
+      "hello\n"
+      (get (run "puts stdout hello") :output))
+    (dict
+      "passed"
+      tcl-eval-pass
+      "failed"
+      tcl-eval-fail
+      "failures"
+      tcl-eval-failures)))