diff --git a/lib/tcl/parser.sx b/lib/tcl/parser.sx new file mode 100644 index 00000000..f94fd328 --- /dev/null +++ b/lib/tcl/parser.sx @@ -0,0 +1,41 @@ +; Tcl parser — thin layer over tcl-tokenize +; Adds tcl-parse entry point and word utility fns + +; Entry point: parse Tcl source to a list of commands. +; Returns same structure as tcl-tokenize. +(define tcl-parse (fn (src) (tcl-tokenize src))) + +; True if word has no substitutions — value can be read statically. +; braced words are always simple. compound words are simple when all +; parts are plain text with no var/cmd parts. +(define tcl-word-simple? + (fn (word) + (cond + ((= (get word :type) "braced") true) + ((= (get word :type) "compound") + (let ((parts (get word :parts))) + (every? (fn (p) (= (get p :type) "text")) parts))) + (else false)))) + +; Concatenate text parts of a simple word into a single string. +; For braced words returns :value directly. +; For compound words with only text parts, joins them. +; Returns nil for words with substitutions. +(define tcl-word-literal + (fn (word) + (cond + ((= (get word :type) "braced") (get word :value)) + ((= (get word :type) "compound") + (if (tcl-word-simple? word) + (join "" (map (fn (p) (get p :value)) (get word :parts))) + nil)) + (else nil)))) + +; Number of words in a parsed command. +(define tcl-cmd-len + (fn (cmd) (len (get cmd :words)))) + +; Nth word literal from a command (index 0 = command name). +; Returns nil if word has substitutions. +(define tcl-nth-literal + (fn (cmd n) (tcl-word-literal (nth (get cmd :words) n)))) diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index a2291ab8..a8899c93 100755 --- a/lib/tcl/test.sh +++ b/lib/tcl/test.sh @@ -17,8 +17,10 @@ cat > "$TMPFILE" << 'EPOCHS' (epoch 1) (load "lib/tcl/tokenizer.sx") (epoch 2) -(load "lib/tcl/tests/parse.sx") +(load "lib/tcl/parser.sx") (epoch 3) +(load "lib/tcl/tests/parse.sx") +(epoch 4) (eval "(tcl-run-parse-tests)") EPOCHS @@ -26,12 +28,12 @@ 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 3 " | tail -1) +RESULT=$(echo "$OUTPUT" | grep -A1 "^(ok-len 4 " | tail -1) if [ -z "$RESULT" ]; then - RESULT=$(echo "$OUTPUT" | grep "^(ok 3 " | sed 's/^(ok 3 //' | sed 's/)$//') + RESULT=$(echo "$OUTPUT" | grep "^(ok 4 " | sed 's/^(ok 3 //' | sed 's/)$//') fi if [ -z "$RESULT" ]; then - echo "ERROR: no result from epoch 3" + echo "ERROR: no result from epoch 4" echo "$OUTPUT" | tail -10 exit 1 fi diff --git a/lib/tcl/tests/parse.sx b/lib/tcl/tests/parse.sx index efd39c7e..0e9df378 100644 --- a/lib/tcl/tests/parse.sx +++ b/lib/tcl/tests/parse.sx @@ -129,6 +129,57 @@ (tcl-assert "cont-word2-val" "1" (get (tcl-part "set x \\\n 1" 2 0) :value)) + + ; --- parser helpers --- + ; tcl-parse is an alias for tcl-tokenize + (tcl-assert "parse-cmd-count" 1 (len (tcl-parse "set x 1"))) + (tcl-assert "parse-2cmds" 2 (len (tcl-parse "set x 1; set y 2"))) + + ; tcl-cmd-len + (tcl-assert "cmd-len-3" 3 (tcl-cmd-len (nth (tcl-parse "set x 1") 0))) + (tcl-assert "cmd-len-1" 1 (tcl-cmd-len (nth (tcl-parse "puts") 0))) + + ; tcl-word-simple? on braced word + (tcl-assert "simple-braced" true + (tcl-word-simple? (nth (get (nth (tcl-parse "{hello}") 0) :words) 0))) + + ; tcl-word-simple? on bare word with no subs + (tcl-assert "simple-bare" true + (tcl-word-simple? (nth (get (nth (tcl-parse "hello") 0) :words) 0))) + + ; tcl-word-simple? on word containing a var sub — false + (tcl-assert "simple-var-false" false + (tcl-word-simple? (nth (get (nth (tcl-parse "$x") 0) :words) 0))) + + ; tcl-word-simple? on word containing a cmd sub — false + (tcl-assert "simple-cmd-false" false + (tcl-word-simple? (nth (get (nth (tcl-parse "[expr 1]") 0) :words) 0))) + + ; tcl-word-literal on braced word + (tcl-assert "lit-braced" "hello world" + (tcl-word-literal (nth (get (nth (tcl-parse "{hello world}") 0) :words) 0))) + + ; tcl-word-literal on bare word + (tcl-assert "lit-bare" "hello" + (tcl-word-literal (nth (get (nth (tcl-parse "hello") 0) :words) 0))) + + ; tcl-word-literal on word with var sub returns nil + (tcl-assert "lit-var-nil" nil + (tcl-word-literal (nth (get (nth (tcl-parse "$x") 0) :words) 0))) + + ; tcl-nth-literal + (tcl-assert "nth-lit-0" "set" + (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 0)) + (tcl-assert "nth-lit-1" "x" + (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 1)) + (tcl-assert "nth-lit-2" "1" + (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 2)) + + ; tcl-nth-literal returns nil when word has subs + (tcl-assert "nth-lit-nil" nil + (tcl-nth-literal (nth (tcl-parse "set x $y") 0) 2)) + + (dict "passed" tcl-parse-pass "failed" tcl-parse-fail