tcl: proc + uplevel + upvar + global + variable + info (+19 tests, 225 total)

Phase 3 headline feature: everything falls out of SX's first-class env chain.
- make-tcl-interp extended with :frame-stack and :procs fields
- proc: user-defined commands with param binding, rest args, isolated scope
- uplevel: run script in ancestor frame with correct frame propagation
- upvar: alias local name to remote frame variable (get/set follow alias)
- global/variable: sugar for upvar #0
- info: level, vars, locals, globals, commands, procs, args, body
- tcl-call-proc propagates updated frames back to caller after proc returns
- test.sh timeout bumped to 90s for larger runtime

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) :commands {}}))
+(define make-tcl-interp (fn () {:result "" :output "" :code 0 :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {}}))
 
 (define
   tcl-register
@@ -28,6 +28,50 @@
     (interp name f)
     (assoc interp :commands (assoc (get interp :commands) name f))))
 
+; --- upvar alias helpers ---
+
+(define upvar-alias? (fn (v) (and (dict? v) (not (nil? (get v :upvar-level))))))
+
+; take first n elements of a list
+(define
+  take-n
+  (fn
+    (lst n)
+    (if
+      (or (<= n 0) (= 0 (len lst)))
+      (list)
+      (append (list (first lst)) (take-n (rest lst) (- n 1))))))
+
+; replace element at index i in list with val (0-based)
+(define
+  replace-at
+  (fn
+    (lst i val)
+    (let
+      ((go
+        (fn
+          (remaining j acc)
+          (if
+            (= 0 (len remaining))
+            acc
+            (go
+              (rest remaining)
+              (+ j 1)
+              (append acc (list (if (= j i) val (first remaining)))))))))
+      (go lst 0 (list)))))
+
+; build full-stack = frame-stack + [current-frame]
+(define
+  tcl-full-stack
+  (fn (interp)
+    (append (get interp :frame-stack) (list (get interp :frame)))))
+
+; get target frame at absolute level from full-stack
+(define
+  tcl-frame-nth
+  (fn (full-stack level)
+    (nth full-stack level)))
+
 (define
   tcl-var-get
   (fn
@@ -37,13 +81,50 @@
       (if
         (nil? val)
         (error (str "can't read \"" name "\": no such variable"))
-        val))))
+        (if
+          (upvar-alias? val)
+          ; follow alias to target frame
+          (let
+            ((target-level (get val :upvar-level))
+              (target-name (get val :upvar-name)))
+            (let
+              ((full-stack (tcl-full-stack interp)))
+              (let
+                ((target-frame (tcl-frame-nth full-stack target-level)))
+                (let
+                  ((target-val (frame-lookup target-frame target-name)))
+                  (if
+                    (nil? target-val)
+                    (error (str "can't read \"" name "\": no such variable"))
+                    target-val)))))
+          val)))))
 
 (define
   tcl-var-set
   (fn
     (interp name val)
-    (assoc interp :frame (frame-set-top (get interp :frame) name val))))
+    (let
+      ((cur-val (get (get (get interp :frame) :locals) name)))
+      (if
+        (and (not (nil? cur-val)) (upvar-alias? cur-val))
+        ; set in target frame
+        (let
+          ((target-level (get cur-val :upvar-level))
+            (target-name (get cur-val :upvar-name)))
+          (let
+            ((full-stack (tcl-full-stack interp)))
+            (let
+              ((target-frame (tcl-frame-nth full-stack target-level)))
+              (let
+                ((updated-target (frame-set-top target-frame target-name val)))
+                (let
+                  ((new-full-stack (replace-at full-stack target-level updated-target)))
+                  (let
+                    ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
+                      (new-current (nth new-full-stack (- (len new-full-stack) 1))))
+                    (assoc interp :frame new-current :frame-stack new-frame-stack)))))))
+        ; normal set in current frame top
+        (assoc interp :frame (frame-set-top (get interp :frame) name val))))))
 
 (define
   tcl-eval-parts
@@ -143,6 +224,77 @@
       {:values (quote ()) :interp interp}
       words)))
 
+; --- proc call ---
+
+; Bind proc parameters: returns updated frame
+(define
+  tcl-bind-params
+  (fn
+    (frame params call-args)
+    (if
+      (= 0 (len params))
+      frame
+      (let
+        ((pname (first params)) (rest-ps (rest params)))
+        (if
+          (equal? pname "args")
+          ; rest param: collect remaining call-args as list string
+          (frame-set-top frame "args" (tcl-list-build call-args))
+          (if
+            (= 0 (len call-args))
+            (error (str "wrong # args: no value for parameter \"" pname "\""))
+            (tcl-bind-params
+              (frame-set-top frame pname (first call-args))
+              rest-ps
+              (rest call-args))))))))
+
+(define
+  tcl-call-proc
+  (fn
+    (interp proc-name proc-def call-args)
+    (let
+      ((param-spec (get proc-def :args))
+        (body (get proc-def :body)))
+      (let
+        ((params (if (equal? param-spec "") (list) (tcl-list-split param-spec))))
+        (let
+          ((caller-stack-len (len (get interp :frame-stack)))
+            (new-frame (make-frame (+ (len (get interp :frame-stack)) 1) nil)))
+          (let
+            ((bound-frame (tcl-bind-params new-frame params call-args)))
+            (let
+              ((proc-interp
+                (assoc interp
+                  :frame bound-frame
+                  :frame-stack (append (get interp :frame-stack) (list (get interp :frame)))
+                  :output ""
+                  :result ""
+                  :code 0))
+                (caller-output (get interp :output)))
+              (let
+                ((result-interp (tcl-eval-string proc-interp body)))
+                (let
+                  ((code (get result-interp :code))
+                    (result-val (get result-interp :result))
+                    (proc-output (get result-interp :output)))
+                  (let
+                    ; result-stack = [updated-frame-0..updated-caller-frame]
+                    ; recover updated caller frame and below-caller frames
+                    ((result-stack (get result-interp :frame-stack)))
+                    (let
+                      ((updated-below (take-n result-stack caller-stack-len))
+                        (updated-caller
+                          (if
+                            (> (len result-stack) caller-stack-len)
+                            (nth result-stack caller-stack-len)
+                            (get interp :frame))))
+                      (assoc interp
+                        :frame updated-caller
+                        :frame-stack updated-below
+                        :result result-val
+                        :output (str caller-output proc-output)
+                        :code (if (= code 2) 0 code)))))))))))))
+
 (define
   tcl-eval-cmd
   (fn
@@ -160,7 +312,12 @@
               ((cmd-fn (get (get cur-interp :commands) cmd-name)))
               (if
                 (nil? cmd-fn)
-                (error (str "unknown command: \"" cmd-name "\""))
+                (let
+                  ((proc-def (get (get cur-interp :procs) cmd-name)))
+                  (if
+                    (nil? proc-def)
+                    (error (str "unknown command: \"" cmd-name "\""))
+                    (tcl-call-proc cur-interp cmd-name proc-def cmd-args)))
                 (cmd-fn cur-interp cmd-args)))))))))
 
 (define
@@ -1875,6 +2032,229 @@
                       (assoc (tcl-var-set interp varname new-dict) :result new-dict)))))))
           (else (error (str "dict: unknown subcommand \"" sub "\""))))))))
 
+; --- proc command ---
+
+(define
+  tcl-cmd-proc
+  (fn
+    (interp args)
+    (let
+      ((name (first args))
+        (arg-spec (nth args 1))
+        (body (nth args 2)))
+      (assoc interp
+        :procs (assoc (get interp :procs) name {:args arg-spec :body body})
+        :result ""))))
+
+; --- parse uplevel/upvar level argument ---
+; Returns absolute level number.
+; current-level = len(frame-stack)
+(define
+  tcl-parse-level
+  (fn
+    (level-str current-level)
+    (if
+      (equal? (substring level-str 0 1) "#")
+      ; absolute: #N
+      (parse-int (substring level-str 1 (string-length level-str)))
+      ; relative: N levels up from current
+      (- current-level (parse-int level-str)))))
+
+; --- uplevel command ---
+
+(define
+  tcl-cmd-uplevel
+  (fn
+    (interp args)
+    (let
+      ((current-level (len (get interp :frame-stack))))
+      (let
+        ; check if first arg is a level specifier
+        ((has-level
+          (and
+            (> (len args) 1)
+            (or
+              (equal? (substring (first args) 0 1) "#")
+              (let
+                ((fst (first args)))
+                (and
+                  (> (string-length fst) 0)
+                  (tcl-expr-digit? (substring fst 0 1)))))))
+          (level-str (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (first args) "1"))
+          (script (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (nth args 1) (first args))))
+        (let
+          ((target-level (tcl-parse-level level-str current-level)))
+          (let
+            ((full-stack (tcl-full-stack interp)))
+            (let
+              ((target-frame (tcl-frame-nth full-stack target-level)))
+              (let
+                ((temp-interp
+                  (assoc interp
+                    :frame target-frame
+                    :frame-stack (take-n (get interp :frame-stack) target-level)
+                    :output ""))
+                  (saved-output (get interp :output)))
+                (let
+                  ((result-interp (tcl-eval-string temp-interp script)))
+                  (let
+                    ((updated-target (get result-interp :frame))
+                      (new-output (get result-interp :output)))
+                    (let
+                      ((new-full-stack (replace-at full-stack target-level updated-target)))
+                      (let
+                        ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
+                          (new-current (nth new-full-stack (- (len new-full-stack) 1))))
+                        (assoc interp
+                          :frame new-current
+                          :frame-stack new-frame-stack
+                          :result (get result-interp :result)
+                          :output (str saved-output new-output)
+                          :code (get result-interp :code))))))))))))))
+
+; --- upvar command ---
+
+(define
+  tcl-cmd-upvar
+  (fn
+    (interp args)
+    (let
+      ((current-level (len (get interp :frame-stack))))
+      (let
+        ; check if first arg is a level specifier
+        ((has-level
+          (and
+            (> (len args) 2)
+            (or
+              (equal? (substring (first args) 0 1) "#")
+              (tcl-expr-digit? (substring (first args) 0 1)))))
+          (level-str (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (first args) "1"))
+          (pair-args (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (rest args) args)))
+        (let
+          ((target-level (tcl-parse-level level-str current-level)))
+          (let
+            ((bind-pairs
+              (fn
+                (i-interp remaining)
+                (if
+                  (< (len remaining) 2)
+                  i-interp
+                  (let
+                    ((remote-name (first remaining))
+                      (local-name (nth remaining 1)))
+                    (let
+                      ((alias {:upvar-level target-level :upvar-name remote-name}))
+                      (bind-pairs
+                        (assoc i-interp :frame (frame-set-top (get i-interp :frame) local-name alias))
+                        (rest (rest remaining)))))))))
+            (assoc (bind-pairs interp pair-args) :result "")))))))
+
+; --- global command ---
+
+(define
+  tcl-cmd-global
+  (fn
+    (interp args)
+    (reduce
+      (fn
+        (i name)
+        (tcl-cmd-upvar i (list "#0" name name)))
+      interp
+      args)))
+
+; --- variable command ---
+
+(define
+  tcl-cmd-variable
+  (fn
+    (interp args)
+    (let
+      ((go
+        (fn
+          (i remaining)
+          (if
+            (= 0 (len remaining))
+            i
+            (let
+              ((name (first remaining))
+                (rest-rem (rest remaining)))
+              (let
+                ((linked (tcl-cmd-upvar i (list "#0" name name))))
+                (if
+                  (and (> (len rest-rem) 0) (not (equal? (substring (first rest-rem) 0 1) "-")))
+                  (let
+                    ((val (first rest-rem)))
+                    (go (assoc (tcl-var-set linked name val) :result "") (rest rest-rem)))
+                  (go linked rest-rem))))))))
+      (go interp args))))
+
+; --- info command ---
+
+(define
+  tcl-cmd-info
+  (fn
+    (interp args)
+    (if
+      (= 0 (len args))
+      (error "info: wrong # args")
+      (let
+        ((sub (first args)) (rest-args (rest args)))
+        (cond
+          ; info level
+          ((equal? sub "level")
+            (assoc interp :result (str (len (get interp :frame-stack)))))
+          ; info vars / info locals
+          ((or (equal? sub "vars") (equal? sub "locals"))
+            (let
+              ((frame-locals (get (get interp :frame) :locals)))
+              (assoc interp :result
+                (tcl-list-build
+                  (filter
+                    (fn (k) (not (upvar-alias? (get frame-locals k))))
+                    (keys frame-locals))))))
+          ; info globals
+          ((equal? sub "globals")
+            (let
+              ((global-frame
+                (if
+                  (= 0 (len (get interp :frame-stack)))
+                  (get interp :frame)
+                  (first (get interp :frame-stack)))))
+              (let
+                ((global-locals (get global-frame :locals)))
+                (assoc interp :result
+                  (tcl-list-build
+                    (filter
+                      (fn (k) (not (upvar-alias? (get global-locals k))))
+                      (keys global-locals)))))))
+          ; info commands
+          ((equal? sub "commands")
+            (assoc interp :result (tcl-list-build (keys (get interp :commands)))))
+          ; info procs
+          ((equal? sub "procs")
+            (assoc interp :result (tcl-list-build (keys (get interp :procs)))))
+          ; info args procname
+          ((equal? sub "args")
+            (let
+              ((pname (first rest-args)))
+              (let
+                ((proc-def (get (get interp :procs) pname)))
+                (if
+                  (nil? proc-def)
+                  (error (str "info args: \"" pname "\" isn't a procedure"))
+                  (assoc interp :result (get proc-def :args))))))
+          ; info body procname
+          ((equal? sub "body")
+            (let
+              ((pname (first rest-args)))
+              (let
+                ((proc-def (get (get interp :procs) pname)))
+                (if
+                  (nil? proc-def)
+                  (error (str "info body: \"" pname "\" isn't a procedure"))
+                  (assoc interp :result (get proc-def :body))))))
+          (else (error (str "info: unknown subcommand \"" sub "\""))))))))
+
 (define
   make-default-tcl-interp
   (fn
@@ -1949,4 +2329,16 @@
                                                                         ((i (tcl-register i "split" tcl-cmd-split)))
                                                                         (let
                                                                           ((i (tcl-register i "join" tcl-cmd-join)))
-                                                                          (tcl-register i "dict" tcl-cmd-dict))))))))))))))))))))))))))))))))))))))
+                                                                          (let
+                                                                            ((i (tcl-register i "dict" tcl-cmd-dict)))
+                                                                            (let
+                                                                              ((i (tcl-register i "proc" tcl-cmd-proc)))
+                                                                              (let
+                                                                                ((i (tcl-register i "uplevel" tcl-cmd-uplevel)))
+                                                                                (let
+                                                                                  ((i (tcl-register i "upvar" tcl-cmd-upvar)))
+                                                                                  (let
+                                                                                    ((i (tcl-register i "global" tcl-cmd-global)))
+                                                                                    (let
+                                                                                      ((i (tcl-register i "variable" tcl-cmd-variable)))
+                                                                                      (tcl-register i "info" tcl-cmd-info))))))))))))))))))))))))))))))))))))))))))))

lib/tcl/test.sh

@@ -40,7 +40,7 @@ cat > "$TMPFILE" << EPOCHS
 (eval "tcl-test-summary")
 EPOCHS
 
-OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>&1)
+OUTPUT=$(timeout 90 "$SX_SERVER" < "$TMPFILE" 2>&1)
 [ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
 
 # Extract summary line from epoch 7 output

lib/tcl/tests/eval.sx

@@ -286,6 +286,30 @@
     (ok "dict-incr-missing" (get (run "set d {}\ndict incr d n") :result) "n 1")
     (ok "dict-append" (get (run "set d {x hello}\ndict append d x _hi") :result) "x hello_hi")
     (ok "dict-append-new" (get (run "set d {}\ndict append d k val") :result) "k val")
+    ; --- proc tests ---
+    (ok "proc-basic" (get (run "proc add {a b} {expr {$a + $b}}\nadd 3 4") :result) "7")
+    (ok "proc-return" (get (run "proc greet {name} {set msg \"hi $name\"\nreturn $msg}\ngreet World") :result) "hi World")
+    (ok "proc-factorial" (get (run "proc factorial {n} {if {$n <= 1} {return 1}\nexpr {$n * [factorial [expr {$n - 1}]]}}\nfactorial 5") :result) "120")
+    (ok "proc-args" (get (run "proc sum args {set t 0\nforeach x $args {incr t $x}\nreturn $t}\nsum 1 2 3 4") :result) "10")
+    (ok "proc-isolated" (get (run "set x outer\nproc p {} {set x inner\nreturn $x}\np") :result) "inner")
+    (ok "proc-caller-unchanged" (tcl-var-get (run "set x outer\nproc p {} {set x inner\nreturn $x}\np\nset dummy 1") "x") "outer")
+    (ok "proc-output" (get (run "proc hello {} {puts -nonewline hi}\nhello") :output) "hi")
+    ; --- upvar tests ---
+    (ok "upvar-incr" (tcl-var-get (run "proc incr2 {varname} {upvar 1 $varname v\nincr v}\nset counter 10\nincr2 counter\nset counter") "counter") "11")
+    (ok "upvar-double" (tcl-var-get (run "proc double-it {varname} {upvar 1 $varname x\nset x [expr {$x * 2}]}\nset val 5\ndouble-it val\nset val") "val") "10")
+    (ok "upvar-result" (get (run "proc double-it {varname} {upvar 1 $varname x\nset x [expr {$x * 2}]}\nset val 5\ndouble-it val\nset val") :result) "10")
+    ; --- uplevel tests ---
+    (ok "uplevel-set" (tcl-var-get (run "proc setvar {name val} {uplevel 1 \"set $name $val\"}\nsetvar x 99\nset x") "x") "99")
+    (ok "uplevel-get" (get (run "proc getvar {name} {uplevel 1 \"set $name\"}\nset y 77\ngetvar y") :result) "77")
+    ; --- global tests ---
+    (ok "global-read" (get (run "set g 100\nproc getg {} {global g\nreturn $g}\ngetg") :result) "100")
+    (ok "global-write" (tcl-var-get (run "set g 0\nproc bumping {} {global g\nincr g}\nbumping\nbumping\nset g") "g") "2")
+    ; --- info tests ---
+    (ok "info-level-0" (get (run "info level") :result) "0")
+    (ok "info-level-proc" (get (run "proc p {} {info level}\np") :result) "1")
+    (ok "info-procs" (let ((r (get (run "proc myfn {} {}\ninfo procs") :result))) (contains? (tcl-list-split r) "myfn")) true)
+    (ok "info-args" (get (run "proc add {a b} {expr {$a+$b}}\ninfo args add") :result) "a b")
+    (ok "info-commands-has-set" (let ((r (get (run "info commands") :result))) (contains? (tcl-list-split r) "set")) true)
     (dict
       "passed"
       tcl-eval-pass