tcl: Phase 4 error handling — catch/try/throw/return-code (+39 tests, 267 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
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>
This commit is contained in:
@@ -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)))))))))))))))))))))))))))))))))))))))))))))))
|
||||
|
||||
Reference in New Issue
Block a user