diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index c781ddf0..eec711bd 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -20,7 +20,7 @@ (frame name val) (assoc frame :locals (assoc (get frame :locals) name val)))) -(define make-tcl-interp (fn () {:result "" :output "" :code 0 :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {}})) +(define make-tcl-interp (fn () {:result "" :output "" :code 0 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {}})) (define tcl-register @@ -837,21 +837,245 @@ (define tcl-cmd-continue (fn (interp args) (assoc interp :code 4))) +; Parse -code name/number to integer +(define + tcl-return-code-num + (fn + (s) + (cond + ((equal? s "ok") 0) + ((equal? s "error") 1) + ((equal? s "return") 2) + ((equal? s "break") 3) + ((equal? s "continue") 4) + (else (parse-int s))))) + +; Parse return options from args list +; Returns {:code N :result val :errorinfo str :errorcode str} +(define + tcl-parse-return-opts + (fn + (args) + (let + ((go + (fn + (remaining code ei ec) + (if + (or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-"))) + {:code code :result (if (> (len remaining) 0) (first remaining) "") :errorinfo ei :errorcode ec} + (let + ((flag (first remaining)) (rest1 (rest remaining))) + (cond + ((equal? flag "-code") + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo ei :errorcode ec} + (go (rest rest1) (tcl-return-code-num (first rest1)) ei ec))) + ((equal? flag "-errorinfo") + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo "" :errorcode ec} + (go (rest rest1) code (first rest1) ec))) + ((equal? flag "-errorcode") + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo ei :errorcode ""} + (go (rest rest1) code ei (first rest1)))) + ((equal? flag "-level") + ; stub: consume the level arg and ignore + (if + (= 0 (len rest1)) + {:code code :result "" :errorinfo ei :errorcode ec} + (go (rest rest1) code ei ec))) + (else + ; unknown flag: treat as value + {:code code :result flag :errorinfo ei :errorcode ec}))))))) + (go args 2 "" "")))) + (define tcl-cmd-return (fn (interp args) (let - ((val (if (> (len args) 0) (last args) ""))) - (assoc (assoc interp :result val) :code 2)))) + ((opts (tcl-parse-return-opts args))) + (assoc interp + :result (get opts :result) + :code (get opts :code) + :errorinfo (get opts :errorinfo) + :errorcode (get opts :errorcode))))) (define tcl-cmd-error (fn (interp args) (let - ((msg (if (> (len args) 0) (first args) "error"))) - (assoc (assoc interp :result msg) :code 1)))) + ((msg (if (> (len args) 0) (first args) "error")) + (ei (if (> (len args) 1) (nth args 1) "")) + (ec (if (> (len args) 2) (nth args 2) ""))) + (assoc interp :result msg :code 1 :errorinfo ei :errorcode ec)))) + +; --- catch command --- +; catch script ?resultVar? ?optionsVar? +(define + tcl-cmd-catch + (fn + (interp args) + (let + ((script (first args)) + (result-var (if (> (len args) 1) (nth args 1) nil)) + (opts-var (if (> (len args) 2) (nth args 2) nil))) + (let + ; run script in a sub-interp with code/result/output reset + ((sub-interp (assoc interp :code 0 :result "" :output "")) + (caller-output (get interp :output))) + (let + ((result-interp (tcl-eval-string sub-interp script))) + (let + ((rc (get result-interp :code)) + (rv (get result-interp :result)) + (rei (get result-interp :errorinfo)) + (rec (get result-interp :errorcode)) + (sub-output (get result-interp :output))) + (let + ; merge sub-interp frame changes back but reset code to 0 + ((merged (assoc result-interp + :code 0 + :result (str rc) + :output (str caller-output sub-output)))) + (let + ; set resultVar if given + ((after-rv + (if (nil? result-var) + merged + (tcl-var-set merged result-var rv)))) + (let + ; set optsVar if given + ((opts-str (str "-code " rc " -errorinfo " (if (equal? rei "") "{}" rei) " -errorcode " (if (equal? rec "") "{}" rec)))) + (let + ((after-opts + (if (nil? opts-var) + after-rv + (tcl-var-set after-rv opts-var opts-str)))) + (assoc after-opts :result (str rc)))))))))))) + +; --- throw command --- +; throw type message +(define + tcl-cmd-throw + (fn + (interp args) + (let + ((ec (if (> (len args) 0) (first args) "")) + (msg (if (> (len args) 1) (nth args 1) ""))) + (assoc interp :result msg :code 1 :errorcode ec :errorinfo "")))) + +; --- try command --- +; try script ?on code var body? ... ?finally body? +(define + tcl-try-code-matches? + (fn + (code-str rc) + (cond + ((equal? code-str "ok") (= rc 0)) + ((equal? code-str "error") (= rc 1)) + ((equal? code-str "return") (= rc 2)) + ((equal? code-str "break") (= rc 3)) + ((equal? code-str "continue") (= rc 4)) + (else (= rc (parse-int code-str)))))) + +(define + tcl-cmd-try + (fn + (interp args) + (let + ((script (first args)) + (rest-args (rest args))) + ; Parse clauses: list of {:type "on"|"finally" :code str :var str :body str} + (let + ((parse-clauses + (fn + (remaining acc) + (if + (= 0 (len remaining)) + acc + (let + ((kw (first remaining))) + (cond + ((equal? kw "on") + (if (< (len remaining) 4) + acc + (parse-clauses + (slice remaining 4 (len remaining)) + (append acc (list {:type "on" :code (nth remaining 1) :var (nth remaining 2) :body (nth remaining 3)}))))) + ((equal? kw "finally") + (if (< (len remaining) 2) + acc + (parse-clauses + (slice remaining 2 (len remaining)) + (append acc (list {:type "finally" :body (nth remaining 1)}))))) + (else acc)))))) + (clauses (parse-clauses rest-args (list)))) + ; Run the main script + (let + ((sub-interp (assoc interp :code 0 :result "")) + (caller-output (get interp :output))) + (let + ((result-interp (tcl-eval-string sub-interp script))) + (let + ((rc (get result-interp :code)) + (rv (get result-interp :result)) + (sub-output (get result-interp :output))) + ; Find matching "on" clause + (let + ((find-clause + (fn + (cs) + (if + (= 0 (len cs)) + nil + (let + ((c (first cs))) + (if + (and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc)) + c + (find-clause (rest cs))))))) + (matched (find-clause clauses)) + ; Find finally clause + (finally-clause + (reduce + (fn (acc c) (if (equal? (get c :type) "finally") c acc)) + nil + clauses))) + ; Evaluate matched handler if any + (let + ((after-handler + (if + (nil? matched) + (assoc result-interp :output (str caller-output sub-output)) + (let + ((handler-interp + (assoc result-interp + :code 0 + :output (str caller-output sub-output)))) + (let + ((bound-interp + (if (equal? (get matched :var) "") + handler-interp + (tcl-var-set handler-interp (get matched :var) rv)))) + (tcl-eval-string bound-interp (get matched :body))))))) + ; Run finally if present + (let + ((final-result + (if + (nil? finally-clause) + after-handler + (let + ((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body)))) + ; Restore code from after-handler unless finally itself errored + (if (= (get fi :code) 0) + (assoc fi :code (get after-handler :code) :result (get after-handler :result)) + fi))))) + final-result)))))))))) (define tcl-cmd-unset @@ -2341,4 +2565,10 @@ ((i (tcl-register i "global" tcl-cmd-global))) (let ((i (tcl-register i "variable" tcl-cmd-variable))) - (tcl-register i "info" tcl-cmd-info)))))))))))))))))))))))))))))))))))))))))))) + (let + ((i (tcl-register i "info" tcl-cmd-info))) + (let + ((i (tcl-register i "catch" tcl-cmd-catch))) + (let + ((i (tcl-register i "throw" tcl-cmd-throw))) + (tcl-register i "try" tcl-cmd-try))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index 2bfcef36..9ae03efe 100755 --- a/lib/tcl/test.sh +++ b/lib/tcl/test.sh @@ -14,13 +14,15 @@ TMPFILE=$(mktemp) HELPER=$(mktemp --suffix=.sx) trap "rm -f $TMPFILE $HELPER" EXIT -# Helper file: run both test suites and format a parseable summary string +# Helper file: run all test suites and format a parseable summary string cat > "$HELPER" << 'HELPER_EOF' (define __pr (tcl-run-parse-tests)) (define __er (tcl-run-eval-tests)) +(define __xr (tcl-run-error-tests)) (define tcl-test-summary (str "PARSE:" (get __pr "passed") ":" (get __pr "failed") - " EVAL:" (get __er "passed") ":" (get __er "failed"))) + " EVAL:" (get __er "passed") ":" (get __er "failed") + " ERROR:" (get __xr "passed") ":" (get __xr "failed"))) HELPER_EOF cat > "$TMPFILE" << EPOCHS @@ -35,16 +37,18 @@ cat > "$TMPFILE" << EPOCHS (epoch 5) (load "lib/tcl/tests/eval.sx") (epoch 6) -(load "$HELPER") +(load "lib/tcl/tests/error.sx") (epoch 7) +(load "$HELPER") +(epoch 8) (eval "tcl-test-summary") EPOCHS OUTPUT=$(timeout 90 "$SX_SERVER" < "$TMPFILE" 2>&1) [ "$VERBOSE" = "-v" ] && echo "$OUTPUT" -# Extract summary line from epoch 7 output -SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 7 " | tail -1 | tr -d '"') +# Extract summary line from epoch 8 output +SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 8 " | tail -1 | tr -d '"') if [ -z "$SUMMARY" ]; then echo "ERROR: no summary from test run" @@ -52,30 +56,34 @@ if [ -z "$SUMMARY" ]; then exit 1 fi -# Parse PARSE:N:M EVAL:N:M +# Parse PARSE:N:M EVAL:N:M ERROR:N:M PARSE_PART=$(echo "$SUMMARY" | grep -o 'PARSE:[0-9]*:[0-9]*') EVAL_PART=$(echo "$SUMMARY" | grep -o 'EVAL:[0-9]*:[0-9]*') +ERROR_PART=$(echo "$SUMMARY" | grep -o 'ERROR:[0-9]*:[0-9]*') PARSE_PASSED=$(echo "$PARSE_PART" | cut -d: -f2) PARSE_FAILED=$(echo "$PARSE_PART" | cut -d: -f3) EVAL_PASSED=$(echo "$EVAL_PART" | cut -d: -f2) EVAL_FAILED=$(echo "$EVAL_PART" | cut -d: -f3) +ERROR_PASSED=$(echo "$ERROR_PART" | cut -d: -f2) +ERROR_FAILED=$(echo "$ERROR_PART" | cut -d: -f3) PARSE_PASSED=${PARSE_PASSED:-0}; PARSE_FAILED=${PARSE_FAILED:-1} EVAL_PASSED=${EVAL_PASSED:-0}; EVAL_FAILED=${EVAL_FAILED:-1} +ERROR_PASSED=${ERROR_PASSED:-0}; ERROR_FAILED=${ERROR_FAILED:-1} -TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED)) -TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED)) +TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED + ERROR_PASSED)) +TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED + ERROR_FAILED)) TOTAL=$((TOTAL_PASSED + TOTAL_FAILED)) if [ "$TOTAL_FAILED" = "0" ]; then - echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED)" + echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED, error: $ERROR_PASSED)" exit 0 else - echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)))" + echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)), error: $ERROR_PASSED/$((ERROR_PASSED+ERROR_FAILED)))" if [ -z "$VERBOSE" ]; then echo "--- output ---" - echo "$OUTPUT" | tail -20 + echo "$OUTPUT" | tail -30 fi exit 1 fi diff --git a/lib/tcl/tests/error.sx b/lib/tcl/tests/error.sx new file mode 100644 index 00000000..8ea6ff32 --- /dev/null +++ b/lib/tcl/tests/error.sx @@ -0,0 +1,192 @@ +; Tcl-on-SX error handling tests (Phase 4) +(define tcl-err-pass 0) +(define tcl-err-fail 0) +(define tcl-err-failures (list)) + +(define + tcl-err-assert + (fn + (label expected actual) + (if + (equal? expected actual) + (set! tcl-err-pass (+ tcl-err-pass 1)) + (begin + (set! tcl-err-fail (+ tcl-err-fail 1)) + (append! + tcl-err-failures + (str label ": expected=" (str expected) " got=" (str actual))))))) + +(define + tcl-run-error-tests + (fn + () + (set! tcl-err-pass 0) + (set! tcl-err-fail 0) + (set! tcl-err-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-err-assert label expected actual))) + (define + ok? + (fn (label condition) (tcl-err-assert label true condition))) + + ; --- catch basic --- + (ok "catch-ok-code" (get (run "catch {set x 1}") :result) "0") + (ok "catch-ok-result-var" (tcl-var-get (run "catch {set x hello} r") "r") "hello") + (ok "catch-ok-returns-0" (get (run "catch {set x hello} r") :result) "0") + + ; --- catch error --- + (ok "catch-error-code" (get (run "catch {error oops} r") :result) "1") + (ok "catch-error-result-var" (tcl-var-get (run "catch {error oops} r") "r") "oops") + + ; --- catch outer code stays 0 --- + (ok? "catch-outer-code-ok" (= (get (run "catch {error boom} r") :code) 0)) + + ; --- catch code 2 (return) --- + (ok "catch-return-code" (get (run "proc p {} {return hello}\ncatch {p} r") :result) "0") + (ok "catch-return-val" (tcl-var-get (run "proc p {} {return hello}\ncatch {p} r") "r") "hello") + + ; --- catch code 3 (break) --- + (ok "catch-break-code" (get (run "catch {break} r") :result) "3") + + ; --- catch code 4 (continue) --- + (ok "catch-continue-code" (get (run "catch {continue} r") :result) "4") + + ; --- catch no resultVar --- + (ok "catch-no-var-ok" (get (run "catch {set x 1}") :result) "0") + (ok "catch-no-var-err" (get (run "catch {error boom}") :result) "1") + + ; --- catch with optsVar --- + (ok? "catch-opts-var-set" + (let + ((i (run "catch {error boom} r opts"))) + (not (equal? (tcl-var-get i "opts") "")))) + (ok? "catch-opts-contains-code" + (let + ((i (run "catch {error boom} r opts"))) + (let + ((opts-str (tcl-var-get i "opts"))) + (not (equal? (tcl-string-first "-code" opts-str 0) "-1"))))) + + ; --- catch nested --- + (ok "catch-nested" + (tcl-var-get (run "catch {catch {error inner} r2} outer") "r2") + "inner") + + ; --- return -code error --- + (ok "return-code-error-code" + (get (run "catch {return -code error oops} r") :result) + "1") + (ok "return-code-error-val" + (tcl-var-get (run "catch {return -code error oops} r") "r") + "oops") + + ; --- return -code ok --- + (ok "return-code-ok" + (get (run "catch {return -code ok hello} r") :result) + "0") + (ok "return-code-ok-val" + (tcl-var-get (run "catch {return -code ok hello} r") "r") + "hello") + + ; --- return -code break --- + (ok "return-code-break" + (get (run "catch {return -code break} r") :result) + "3") + + ; --- return -code continue --- + (ok "return-code-continue" + (get (run "catch {return -code continue} r") :result) + "4") + + ; --- return -code numeric --- + (ok "return-code-numeric-5" + (get (run "catch {return -code 5 msg} r") :result) + "5") + + ; --- return plain still code 2 (catch sees raw return code) --- + (ok "return-plain-code" + (get (run "catch {return hello} r") :result) + "2") + (ok "return-plain-val" + (tcl-var-get (run "catch {return hello} r") "r") + "hello") + + ; --- proc return -code error --- + (ok "proc-return-code-error" + (get (run "proc p {} {return -code error bad}\ncatch {p} r") :result) + "1") + (ok "proc-return-code-error-val" + (tcl-var-get (run "proc p {} {return -code error bad}\ncatch {p} r") "r") + "bad") + + ; --- error with info/code args --- + (ok? "error-errorinfo-stored" + (let + ((i (run "catch {error msg myinfo mycode} r"))) + (= (get i :code) 0))) + + ; --- throw --- + (ok "throw-code" (get (run "catch {throw MYERR something} r") :result) "1") + (ok "throw-msg" (tcl-var-get (run "catch {throw MYERR something} r") "r") "something") + + ; --- try basic ok --- + (ok "try-ok-result" + (get (run "try {set x hello} on ok {r} {set r2 $r}") :result) + "hello") + + ; --- try on error --- + (ok "try-on-error-handled" + (get (run "try {error boom} on error {e} {set caught $e}") :result) + "boom") + (ok "try-on-error-var" + (tcl-var-get (run "try {error boom} on error {e} {set caught $e}") "caught") + "boom") + + ; --- try finally always runs --- + (ok "try-finally-ok" + (tcl-var-get (run "try {set x 1} finally {set done yes}") "done") + "yes") + (ok "try-finally-error" + (tcl-var-get (run "catch {try {error boom} finally {set done yes}} r") "done") + "yes") + + ; --- try on error + finally --- + (ok "try-error-finally" + (tcl-var-get + (run "try {error oops} on error {e} {set caught $e} finally {set cleaned yes}") + "cleaned") + "yes") + (ok "try-error-finally-caught" + (tcl-var-get + (run "try {error oops} on error {e} {set caught $e} finally {set cleaned yes}") + "caught") + "oops") + + ; --- try on ok and on error --- + (ok "try-multi-clause-ok" + (tcl-var-get + (run "try {set x 1} on ok {r} {set which ok} on error {e} {set which err}") + "which") + "ok") + (ok "try-multi-clause-err" + (tcl-var-get + (run "try {error boom} on ok {r} {set which ok} on error {e} {set which err}") + "which") + "err") + + ; --- catch preserves output --- + (ok "catch-output-preserved" + (get (run "puts -nonewline before\ncatch {puts -nonewline inside\nerror oops}\nputs -nonewline after") + :output) + "beforeinsideafter") + + (dict + "passed" + tcl-err-pass + "failed" + tcl-err-fail + "failures" + tcl-err-failures)))