rose-ash/lib/tcl/tests/eval.sx

; 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)))
    (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"
      "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"
      "6"
      (get (run "set x 5\nset y [incr x]") :result))
    (tcl-eval-assert
      "cmdsub-y"
      "6"
      (tcl-var-get (run "set x 5\nset y [incr x]") "y"))
    (tcl-eval-assert
      "cmdsub-x"
      "6"
      (tcl-var-get (run "set x 5\nset y [incr x]") "x"))
    (tcl-eval-assert
      "multi-cmd"
      "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
      "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))
    (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
      "failed"
      tcl-eval-fail
      "failures"
      tcl-eval-failures)))