147 lines
5.5 KiB
Plaintext
147 lines
5.5 KiB
Plaintext
;; lib/tcl/tests/runtime.sx — Tests for lib/tcl/runtime.sx
|
|
|
|
(define tcl-test-pass 0)
|
|
(define tcl-test-fail 0)
|
|
(define tcl-test-fails (list))
|
|
|
|
(define
|
|
(tcl-test name got expected)
|
|
(if
|
|
(= got expected)
|
|
(set! tcl-test-pass (+ tcl-test-pass 1))
|
|
(begin
|
|
(set! tcl-test-fail (+ tcl-test-fail 1))
|
|
(set! tcl-test-fails (append tcl-test-fails (list {:got got :expected expected :name name}))))))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 1. String buffer
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define sb1 (tcl-sb-new))
|
|
(tcl-test "sb? new" (tcl-sb? sb1) true)
|
|
(tcl-test "sb? non-sb" (tcl-sb? "hello") false)
|
|
(tcl-test "sb value empty" (tcl-sb-value sb1) "")
|
|
(tcl-test "sb length empty" (tcl-sb-length sb1) 0)
|
|
(tcl-sb-append! sb1 "hello")
|
|
(tcl-test "sb value after append" (tcl-sb-value sb1) "hello")
|
|
(tcl-sb-append! sb1 " ")
|
|
(tcl-sb-append! sb1 "world")
|
|
(tcl-test "sb value after multi-append" (tcl-sb-value sb1) "hello world")
|
|
(tcl-test "sb length" (tcl-sb-length sb1) 11)
|
|
(tcl-sb-clear! sb1)
|
|
(tcl-test "sb value after clear" (tcl-sb-value sb1) "")
|
|
(tcl-test "sb length after clear" (tcl-sb-length sb1) 0)
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 2. String port (channel)
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define chin1 (tcl-chan-in-new "hello\nworld\nfoo"))
|
|
(tcl-test "chan? read" (tcl-chan? chin1) true)
|
|
(tcl-test "chan eof? no" (tcl-chan-eof? chin1) false)
|
|
(tcl-test "chan gets line1" (tcl-chan-gets chin1) "hello")
|
|
(tcl-test "chan gets line2" (tcl-chan-gets chin1) "world")
|
|
(tcl-test "chan gets line3" (tcl-chan-gets chin1) "foo")
|
|
(tcl-test "chan eof? yes" (tcl-chan-eof? chin1) true)
|
|
(tcl-test "chan gets at eof" (tcl-chan-gets chin1) "")
|
|
|
|
(define chin2 (tcl-chan-in-new "abcdef"))
|
|
(tcl-test "chan read all" (tcl-chan-read chin2) "abcdef")
|
|
(tcl-test "chan read empty" (tcl-chan-read chin2) "")
|
|
|
|
(define chout1 (tcl-chan-out-new))
|
|
(tcl-test "chan? write" (tcl-chan? chout1) true)
|
|
(tcl-chan-puts! chout1 "hello")
|
|
(tcl-chan-puts! chout1 " world")
|
|
(tcl-test "chan string" (tcl-chan-string chout1) "hello world")
|
|
(tcl-chan-puts-line! chout1 "!")
|
|
(tcl-test "chan string with newline" (tcl-chan-string chout1) "hello world!\n")
|
|
|
|
(define chout2 (tcl-chan-out-new))
|
|
(tcl-chan-puts-line! chout2 "line1")
|
|
(tcl-chan-puts-line! chout2 "line2")
|
|
(tcl-test "chan multi-line" (tcl-chan-string chout2) "line1\nline2\n")
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 3. Regexp
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define rx1 (tcl-re-new "hel+o"))
|
|
(tcl-test "re? yes" (tcl-re? rx1) true)
|
|
(tcl-test "re? no" (tcl-re? "hello") false)
|
|
(tcl-test "re match? yes" (tcl-re-match? rx1 "say hello") true)
|
|
(tcl-test "re match? no" (tcl-re-match? rx1 "goodbye") false)
|
|
|
|
(define m1 (tcl-re-match rx1 "say hello world"))
|
|
(tcl-test "re match result" (get m1 "match") "hello")
|
|
|
|
(define rx2 (tcl-re-new "[0-9]+"))
|
|
(define all (tcl-re-match-all rx2 "a1b22c333"))
|
|
(tcl-test "re match-all count" (len all) 3)
|
|
(tcl-test "re match-all last" (get (nth all 2) "match") "333")
|
|
|
|
(tcl-test "re sub" (tcl-re-sub rx2 "a1b2" "N") "aNb2")
|
|
(tcl-test "re sub-all" (tcl-re-sub-all rx2 "a1b2" "N") "aNbN")
|
|
|
|
(define rx3 (tcl-re-new "[ ,]+"))
|
|
(tcl-test "re split" (tcl-re-split rx3 "a b,c") (list "a" "b" "c"))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 4. Format
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(tcl-test "format %s" (tcl-format "hello %s" (list "world")) "hello world")
|
|
(tcl-test "format %d" (tcl-format "n=%d" (list 42)) "n=42")
|
|
(tcl-test "format %d truncates float" (tcl-format "n=%d" (list 3.9)) "n=3")
|
|
(tcl-test
|
|
"format %s %d"
|
|
(tcl-format "%s is %d" (list "age" 30))
|
|
"age is 30")
|
|
(tcl-test "format %%" (tcl-format "100%% done" (list)) "100% done")
|
|
(tcl-test "format %x" (tcl-format "%x" (list 255)) "ff")
|
|
(tcl-test "format %x 16" (tcl-format "0x%x" (list 16)) "0x10")
|
|
(tcl-test "format %o" (tcl-format "%o" (list 8)) "10")
|
|
(tcl-test "format %o 255" (tcl-format "%o" (list 255)) "377")
|
|
(tcl-test "format no spec" (tcl-format "plain text" (list)) "plain text")
|
|
(tcl-test
|
|
"format multiple"
|
|
(tcl-format "%s=%d (0x%x)" (list "val" 255 255))
|
|
"val=255 (0xff)")
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 5. Coroutine
|
|
;; tcl-co-yield works from top-level helper functions.
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define
|
|
co1
|
|
(tcl-co-new
|
|
(fn () (tcl-co-yield 1) (tcl-co-yield 2) 3)))
|
|
|
|
(tcl-test "co? yes" (tcl-co? co1) true)
|
|
(tcl-test "co? no" (tcl-co? 42) false)
|
|
(tcl-test "co alive? before" (tcl-co-alive? co1) true)
|
|
(define cor1 (tcl-co-resume co1))
|
|
(tcl-test "co resume 1" cor1 1)
|
|
(tcl-test "co alive? mid" (tcl-co-alive? co1) true)
|
|
(define cor2 (tcl-co-resume co1))
|
|
(tcl-test "co resume 2" cor2 2)
|
|
(define cor3 (tcl-co-resume co1))
|
|
(tcl-test "co resume 3 completion" cor3 3)
|
|
(tcl-test "co alive? dead" (tcl-co-alive? co1) false)
|
|
|
|
;; Top-level helper for recursive yield (avoids JIT letrec limitation)
|
|
(define
|
|
(tcl-co-count-down i)
|
|
(when
|
|
(>= i 1)
|
|
(tcl-co-yield i)
|
|
(tcl-co-count-down (- i 1))))
|
|
|
|
(define co2 (tcl-co-new (fn () (tcl-co-count-down 3) "done")))
|
|
(tcl-test "co loop 3" (tcl-co-resume co2) 3)
|
|
(tcl-test "co loop 2" (tcl-co-resume co2) 2)
|
|
(tcl-test "co loop 1" (tcl-co-resume co2) 1)
|
|
(tcl-test "co loop done" (tcl-co-resume co2) "done")
|
|
(tcl-test "co loop dead" (tcl-co-alive? co2) false)
|