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

; 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)))