diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx new file mode 100644 index 00000000..ec656dec --- /dev/null +++ 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))))))) diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index a8899c93..e0f1eee6 100755 --- 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 diff --git a/lib/tcl/tests/eval.sx b/lib/tcl/tests/eval.sx new file mode 100644 index 00000000..6ffd3531 --- /dev/null +++ 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))) diff --git a/plans/tcl-on-sx.md b/plans/tcl-on-sx.md index 78805dc3..c94096ca 100644 --- a/plans/tcl-on-sx.md +++ b/plans/tcl-on-sx.md @@ -67,7 +67,7 @@ Core mapping: - [x] Unit tests in `lib/tcl/tests/parse.sx` ### Phase 2 — sequential eval + core commands -- [ ] `tcl-eval-script`: walk command list, dispatch each first-word into command table +- [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` - [ ] `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` @@ -120,6 +120,7 @@ Core mapping: _Newest first._ +- 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