136 lines
5.4 KiB
Plaintext
136 lines
5.4 KiB
Plaintext
(define tcl-parse-pass 0)
|
|
(define tcl-parse-fail 0)
|
|
(define tcl-parse-failures (list))
|
|
|
|
(define tcl-assert
|
|
(fn (label expected actual)
|
|
(if (= expected actual)
|
|
(set! tcl-parse-pass (+ tcl-parse-pass 1))
|
|
(begin
|
|
(set! tcl-parse-fail (+ tcl-parse-fail 1))
|
|
(append! tcl-parse-failures
|
|
(str label ": expected=" (str expected) " got=" (str actual)))))))
|
|
|
|
(define tcl-first-cmd
|
|
(fn (src) (nth (tcl-tokenize src) 0)))
|
|
|
|
(define tcl-cmd-words
|
|
(fn (src) (get (tcl-first-cmd src) :words)))
|
|
|
|
(define tcl-word
|
|
(fn (src wi) (nth (tcl-cmd-words src) wi)))
|
|
|
|
(define tcl-parts
|
|
(fn (src wi) (get (tcl-word src wi) :parts)))
|
|
|
|
(define tcl-part
|
|
(fn (src wi pi) (nth (tcl-parts src wi) pi)))
|
|
|
|
(define tcl-run-parse-tests
|
|
(fn ()
|
|
(set! tcl-parse-pass 0)
|
|
(set! tcl-parse-fail 0)
|
|
(set! tcl-parse-failures (list))
|
|
|
|
; empty / whitespace-only
|
|
(tcl-assert "empty" 0 (len (tcl-tokenize "")))
|
|
(tcl-assert "ws-only" 0 (len (tcl-tokenize " ")))
|
|
(tcl-assert "nl-only" 0 (len (tcl-tokenize "\n\n")))
|
|
|
|
; single command word count
|
|
(tcl-assert "1word" 1 (len (tcl-cmd-words "set")))
|
|
(tcl-assert "3words" 3 (len (tcl-cmd-words "set x 1")))
|
|
(tcl-assert "4words" 4 (len (tcl-cmd-words "set a b c")))
|
|
|
|
; word type — bare word is compound
|
|
(tcl-assert "bare-type" "compound" (get (tcl-word "set x 1" 0) :type))
|
|
(tcl-assert "bare-quoted" false (get (tcl-word "set x 1" 0) :quoted))
|
|
(tcl-assert "bare-part-type" "text" (get (tcl-part "set x 1" 0 0) :type))
|
|
(tcl-assert "bare-part-val" "set" (get (tcl-part "set x 1" 0 0) :value))
|
|
(tcl-assert "bare-part2-val" "x" (get (tcl-part "set x 1" 1 0) :value))
|
|
(tcl-assert "bare-part3-val" "1" (get (tcl-part "set x 1" 2 0) :value))
|
|
|
|
; multiple commands
|
|
(tcl-assert "semi-sep" 2 (len (tcl-tokenize "set x 1; set y 2")))
|
|
(tcl-assert "nl-sep" 2 (len (tcl-tokenize "set x 1\nset y 2")))
|
|
(tcl-assert "multi-nl" 3 (len (tcl-tokenize "a\nb\nc")))
|
|
|
|
; comments
|
|
(tcl-assert "comment-only" 0 (len (tcl-tokenize "# comment")))
|
|
(tcl-assert "comment-nl" 0 (len (tcl-tokenize "# comment\n")))
|
|
(tcl-assert "comment-then-cmd" 1 (len (tcl-tokenize "# comment\nset x 1")))
|
|
(tcl-assert "semi-then-comment" 1 (len (tcl-tokenize "set x 1; # comment")))
|
|
|
|
; brace-quoted words
|
|
(tcl-assert "brace-type" "braced" (get (tcl-word "{hello}" 0) :type))
|
|
(tcl-assert "brace-value" "hello" (get (tcl-word "{hello}" 0) :value))
|
|
(tcl-assert "brace-spaces" "hello world" (get (tcl-word "{hello world}" 0) :value))
|
|
(tcl-assert "brace-nested" "a {b} c" (get (tcl-word "{a {b} c}" 0) :value))
|
|
(tcl-assert "brace-no-var-sub" "hello $x" (get (tcl-word "{hello $x}" 0) :value))
|
|
(tcl-assert "brace-no-cmd-sub" "[expr 1]" (get (tcl-word "{[expr 1]}" 0) :value))
|
|
|
|
; double-quoted words
|
|
(tcl-assert "dq-type" "compound" (get (tcl-word "\"hello\"" 0) :type))
|
|
(tcl-assert "dq-quoted" true (get (tcl-word "\"hello\"" 0) :quoted))
|
|
(tcl-assert "dq-literal" "hello" (get (tcl-part "\"hello\"" 0 0) :value))
|
|
|
|
; variable substitution in bare word
|
|
(tcl-assert "var-type" "var" (get (tcl-part "$x" 0 0) :type))
|
|
(tcl-assert "var-name" "x" (get (tcl-part "$x" 0 0) :name))
|
|
(tcl-assert "var-long" "long_name" (get (tcl-part "$long_name" 0 0) :name))
|
|
|
|
; ${name} form
|
|
(tcl-assert "var-brace-type" "var" (get (tcl-part "${x}" 0 0) :type))
|
|
(tcl-assert "var-brace-name" "x" (get (tcl-part "${x}" 0 0) :name))
|
|
|
|
; array variable substitution
|
|
(tcl-assert "arr-type" "var-arr" (get (tcl-part "$arr(key)" 0 0) :type))
|
|
(tcl-assert "arr-name" "arr" (get (tcl-part "$arr(key)" 0 0) :name))
|
|
(tcl-assert "arr-key-len" 1 (len (get (tcl-part "$arr(key)" 0 0) :key)))
|
|
(tcl-assert "arr-key-text" "key"
|
|
(get (nth (get (tcl-part "$arr(key)" 0 0) :key) 0) :value))
|
|
|
|
; command substitution
|
|
(tcl-assert "cmd-type" "cmd" (get (tcl-part "[expr 1+1]" 0 0) :type))
|
|
(tcl-assert "cmd-src" "expr 1+1" (get (tcl-part "[expr 1+1]" 0 0) :src))
|
|
|
|
; nested command substitution
|
|
(tcl-assert "cmd-nested-src" "expr [string length x]"
|
|
(get (tcl-part "[expr [string length x]]" 0 0) :src))
|
|
|
|
; backslash substitution in double-quoted word
|
|
(let ((ps (tcl-parts "\"a\\nb\"" 0)))
|
|
(begin
|
|
(tcl-assert "bs-n-part0" "a" (get (nth ps 0) :value))
|
|
(tcl-assert "bs-n-part1" "\n" (get (nth ps 1) :value))
|
|
(tcl-assert "bs-n-part2" "b" (get (nth ps 2) :value))))
|
|
|
|
(let ((ps (tcl-parts "\"a\\tb\"" 0)))
|
|
(tcl-assert "bs-t-part1" "\t" (get (nth ps 1) :value)))
|
|
|
|
(let ((ps (tcl-parts "\"a\\\\b\"" 0)))
|
|
(tcl-assert "bs-bs-part1" "\\" (get (nth ps 1) :value)))
|
|
|
|
; mixed word: text + var + text in double-quoted
|
|
(let ((ps (tcl-parts "\"hello $name!\"" 0)))
|
|
(begin
|
|
(tcl-assert "mixed-text0" "hello " (get (nth ps 0) :value))
|
|
(tcl-assert "mixed-var1-type" "var" (get (nth ps 1) :type))
|
|
(tcl-assert "mixed-var1-name" "name" (get (nth ps 1) :name))
|
|
(tcl-assert "mixed-text2" "!" (get (nth ps 2) :value))))
|
|
|
|
; {*} expansion
|
|
(tcl-assert "expand-type" "expand" (get (tcl-word "{*}$list" 0) :type))
|
|
|
|
; line continuation between words
|
|
(tcl-assert "cont-words" 3 (len (tcl-cmd-words "set x \\\n 1")))
|
|
|
|
; continuation — third command word is correct
|
|
(tcl-assert "cont-word2-val" "1"
|
|
(get (tcl-part "set x \\\n 1" 2 0) :value))
|
|
|
|
(dict
|
|
"passed" tcl-parse-pass
|
|
"failed" tcl-parse-fail
|
|
"failures" tcl-parse-failures)))
|