tcl: Phase 4 error handling — catch/try/throw/return-code (+39 tests, 267 total)

Implements catch, throw, try, return -code options, and error with
errorinfo/errorcode fields. catch runs sub-script isolated, captures
result and exit code (0-4); try dispatches on/finally clauses;
throw sets code 1 with errorcode; return -code parses flag options.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

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

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

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