tcl: Phase 5 namespaces + ensembles (+22 tests, 289 total)

Implements namespace eval, current, which, exists, delete, export,
import, forget, path, and ensemble create (auto-map + -map). Procs
defined inside namespace eval are stored as fully-qualified names
(::ns::proc), resolved relative to the calling namespace at lookup
time. Proc bodies execute in their defining namespace so sibling
calls work without qualification.

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 :errorinfo "" :errorcode "" :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 {} :current-ns "::"}))
 
 (define
   tcl-register
@@ -263,13 +263,16 @@
           (let
             ((bound-frame (tcl-bind-params new-frame params call-args)))
             (let
+              ((proc-ns (let ((ns (get proc-def :ns))) (if (nil? ns) (get interp :current-ns) ns))))
+              (let
               ((proc-interp
                 (assoc interp
                   :frame bound-frame
                   :frame-stack (append (get interp :frame-stack) (list (get interp :frame)))
                   :output ""
                   :result ""
-                  :code 0))
+                  :code 0
+                  :current-ns proc-ns))
                 (caller-output (get interp :output)))
               (let
                 ((result-interp (tcl-eval-string proc-interp body)))
@@ -293,7 +296,7 @@
                         :frame-stack updated-below
                         :result result-val
                         :output (str caller-output proc-output)
-                        :code (if (= code 2) 0 code)))))))))))))
+                        :code (if (= code 2) 0 code))))))))))))))
 
 (define
   tcl-eval-cmd
@@ -313,11 +316,11 @@
               (if
                 (nil? cmd-fn)
                 (let
-                  ((proc-def (get (get cur-interp :procs) cmd-name)))
+                  ((proc-entry (tcl-proc-lookup cur-interp cmd-name)))
                   (if
-                    (nil? proc-def)
+                    (nil? proc-entry)
                     (error (str "unknown command: \"" cmd-name "\""))
-                    (tcl-call-proc cur-interp cmd-name proc-def cmd-args)))
+                    (tcl-call-proc cur-interp (get proc-entry :name) (get proc-entry :def) cmd-args)))
                 (cmd-fn cur-interp cmd-args)))))))))
 
 (define
@@ -2256,6 +2259,114 @@
                       (assoc (tcl-var-set interp varname new-dict) :result new-dict)))))))
           (else (error (str "dict: unknown subcommand \"" sub "\""))))))))
 
+; --- namespace helpers ---
+
+; Normalize a namespace name to fully-qualified form: ::ns
+; Accepts: "ns", "::ns", "ns::", "::ns::", "" → "::"
+(define
+  tcl-ns-normalize
+  (fn
+    (ns)
+    (if
+      (or (equal? ns "") (equal? ns "::"))
+      "::"
+      (let
+        ; strip trailing ::
+        ((stripped
+          (if
+            (equal? (substring ns (- (string-length ns) 2) (string-length ns)) "::")
+            (substring ns 0 (- (string-length ns) 2))
+            ns)))
+        ; ensure leading ::
+        (if
+          (equal? (substring stripped 0 2) "::")
+          stripped
+          (str "::" stripped))))))
+
+; Test whether string s starts with prefix p
+(define
+  tcl-starts-with?
+  (fn
+    (s p)
+    (let
+      ((pl (string-length p)) (sl (string-length s)))
+      (if (> pl sl) false (equal? (substring s 0 pl) p)))))
+
+; Qualify a proc name relative to current-ns.
+; If name already starts with :: return as-is.
+; Otherwise prepend current-ns:: (or :: if current-ns is ::).
+(define
+  tcl-qualify-name
+  (fn
+    (name current-ns)
+    (if
+      (tcl-starts-with? name "::")
+      name
+      (if
+        (equal? current-ns "::")
+        (str "::" name)
+        (str current-ns "::" name)))))
+
+; Look up a command by name with namespace resolution.
+; Try: exact name → ::current-ns::name → ::name
+(define
+  tcl-proc-lookup
+  (fn
+    (interp name)
+    (let
+      ((procs (get interp :procs))
+        (current-ns (get interp :current-ns)))
+      (let
+        ((exact (get procs name)))
+        (if (not (nil? exact))
+          {:name name :def exact}
+          (let
+            ((qualified (tcl-qualify-name name current-ns)))
+            (let
+              ((qual-def (get procs qualified)))
+              (if (not (nil? qual-def))
+                {:name qualified :def qual-def}
+                (let
+                  ((global-name (str "::" name)))
+                  (let
+                    ((global-def (get procs global-name)))
+                    (if (not (nil? global-def))
+                      {:name global-name :def global-def}
+                      nil)))))))))))
+
+; Get all proc names in a namespace (returns list of fully-qualified names)
+(define
+  tcl-ns-procs
+  (fn
+    (procs ns)
+    (let
+      ((prefix (if (equal? ns "::") "::" (str ns "::"))))
+      (filter
+        (fn (k)
+          (if (equal? ns "::")
+            ; global ns: keys that start with :: but have no further ::
+            (and
+              (tcl-starts-with? k "::")
+              (not (tcl-starts-with? (substring k 2 (string-length k)) "::")))
+            (tcl-starts-with? k prefix)))
+        (keys procs)))))
+
+; Check if a namespace exists (has any procs)
+(define
+  tcl-ns-exists?
+  (fn
+    (procs ns)
+    (> (len (tcl-ns-procs procs ns)) 0)))
+
+; Extract last component from qualified name ::ns::foo → foo
+(define
+  tcl-ns-tail
+  (fn
+    (name)
+    (let
+      ((parts (filter (fn (p) (not (equal? p ""))) (split name ":"))))
+      (if (= 0 (len parts)) name (nth parts (- (len parts) 1))))))
+
 ; --- proc command ---
 
 (define
@@ -2263,12 +2374,24 @@
   (fn
     (interp args)
     (let
-      ((name (first args))
+      ((raw-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 ""))))
+      (let
+        ; qualify name based on current namespace
+        ((name (tcl-qualify-name raw-name (get interp :current-ns))))
+        (let
+          ; extract the namespace of the proc for runtime context
+          ((proc-ns
+            (let
+              ((parts (filter (fn (p) (not (equal? p ""))) (split name ":"))))
+              ; proc-ns is all but last component, re-joined as ::ns or ::
+              (if (<= (len parts) 1)
+                "::"
+                (str "::" (join "::" (take-n parts (- (len parts) 1))))))))
+          (assoc interp
+            :procs (assoc (get interp :procs) name {:args arg-spec :body body :ns proc-ns})
+            :result ""))))))
 
 ; --- parse uplevel/upvar level argument ---
 ; Returns absolute level number.
@@ -2412,6 +2535,178 @@
                   (go linked rest-rem))))))))
       (go interp args))))
 
+; --- namespace command ---
+
+; namespace ensemble dispatch fn for a given ns and map
+(define
+  tcl-make-ensemble
+  (fn
+    (procs ns map-dict)
+    (fn
+      (interp args)
+      (if
+        (= 0 (len args))
+        (error (str "wrong # args: ensemble \"" ns "\" requires subcommand"))
+        (let
+          ((subcmd (first args)) (rest-args (rest args)))
+          (let
+            ((target-name (tcl-dict-get map-dict subcmd)))
+            (if (not (nil? target-name))
+              ; dispatch via mapped name
+              (let
+                ((proc-entry (tcl-proc-lookup interp target-name)))
+                (if (nil? proc-entry)
+                  (error (str "ensemble: command \"" target-name "\" not found"))
+                  (tcl-call-proc interp (get proc-entry :name) (get proc-entry :def) rest-args)))
+              (error (str "unknown or ambiguous subcommand \"" subcmd "\": must be one of " (join ", " (map first (tcl-dict-to-pairs map-dict))))))))))))
+
+(define
+  tcl-cmd-namespace
+  (fn
+    (interp args)
+    (if
+      (= 0 (len args))
+      (error "namespace: wrong # args")
+      (let
+        ((sub (first args)) (rest-args (rest args)))
+        (cond
+          ; namespace eval ns body
+          ((equal? sub "eval")
+            (let
+              ((ns-raw (if (> (len rest-args) 0) (first rest-args) ""))
+                (body (if (> (len rest-args) 1) (nth rest-args 1) "")))
+              (let
+                ; if ns-raw is relative (no leading ::), resolve relative to current-ns
+                ((ns
+                  (let
+                    ((normalized (tcl-ns-normalize ns-raw))
+                      (current-ns (get interp :current-ns)))
+                    ; tcl-ns-normalize always adds :: prefix, so ::name is absolute
+                    ; check if the original had leading ::
+                    (if
+                      (tcl-starts-with? ns-raw "::")
+                      normalized
+                      ; relative: if current is ::, just use ::name; else ::current::name
+                      (if
+                        (equal? current-ns "::")
+                        normalized
+                        (str current-ns "::" (tcl-ns-tail normalized))))))
+                  (saved-ns (get interp :current-ns)))
+                (let
+                  ((ns-interp (assoc interp :current-ns ns)))
+                  (let
+                    ((result-interp (tcl-eval-string ns-interp body)))
+                    ; restore current-ns after eval
+                    (assoc result-interp :current-ns saved-ns))))))
+          ; namespace current
+          ((equal? sub "current")
+            (assoc interp :result (get interp :current-ns)))
+          ; namespace which -command name
+          ((equal? sub "which")
+            (let
+              ((name (if (and (> (len rest-args) 0) (equal? (first rest-args) "-command"))
+                  (if (> (len rest-args) 1) (nth rest-args 1) "")
+                  (if (> (len rest-args) 0) (first rest-args) ""))))
+              (let
+                ((entry (tcl-proc-lookup interp name)))
+                (if (nil? entry)
+                  (assoc interp :result "")
+                  (assoc interp :result (get entry :name))))))
+          ; namespace exists ns
+          ((equal? sub "exists")
+            (let
+              ((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) ""))))
+              (assoc interp :result (if (tcl-ns-exists? (get interp :procs) ns) "1" "0"))))
+          ; namespace delete ns
+          ((equal? sub "delete")
+            (let
+              ((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) ""))))
+              (let
+                ((prefix (if (equal? ns "::") "::" (str ns "::"))))
+                (let
+                  ((remaining-procs
+                    (reduce
+                      (fn (acc k) (if (tcl-starts-with? k prefix) acc (assoc acc k (get (get interp :procs) k))))
+                      {}
+                      (keys (get interp :procs)))))
+                  (assoc interp :procs remaining-procs :result "")))))
+          ; namespace export pattern — stub
+          ((equal? sub "export")
+            (assoc interp :result ""))
+          ; namespace import ns::name
+          ((equal? sub "import")
+            (let
+              ((target-name (if (> (len rest-args) 0) (first rest-args) "")))
+              (let
+                ((tail (tcl-ns-tail target-name))
+                  (entry (tcl-proc-lookup interp target-name)))
+                (if (nil? entry)
+                  (error (str "namespace import: \"" target-name "\" not found"))
+                  (let
+                    ((local-name (tcl-qualify-name tail (get interp :current-ns))))
+                    (assoc interp
+                      :procs (assoc (get interp :procs) local-name (get entry :def))
+                      :result ""))))))
+          ; namespace forget name — remove import alias
+          ((equal? sub "forget")
+            (let
+              ((name (if (> (len rest-args) 0) (first rest-args) "")))
+              (let
+                ((qualified (tcl-qualify-name name (get interp :current-ns))))
+                (let
+                  ((new-procs (reduce
+                    (fn (acc k) (if (equal? k qualified) acc (assoc acc k (get (get interp :procs) k))))
+                    {}
+                    (keys (get interp :procs)))))
+                  (assoc interp :procs new-procs :result "")))))
+          ; namespace path ?nslist? — stub
+          ((equal? sub "path")
+            (assoc interp :result ""))
+          ; namespace ensemble create ?-map dict?
+          ((equal? sub "ensemble")
+            (if (and (> (len rest-args) 0) (equal? (first rest-args) "create"))
+              (let
+                ((ens-args (rest rest-args))
+                  (current-ns (get interp :current-ns)))
+                (let
+                  ; parse optional -map {subcmd cmd ...}
+                  ((map-str
+                    (let
+                      ((go
+                        (fn
+                          (remaining)
+                          (if
+                            (< (len remaining) 2)
+                            nil
+                            (if (equal? (first remaining) "-map")
+                              (nth remaining 1)
+                              (go (rest remaining)))))))
+                      (go ens-args))))
+                  (let
+                    ; build dispatch map
+                    ((dispatch-map
+                      (if (nil? map-str)
+                        ; auto-map: all procs in this namespace → tail name
+                        (let
+                          ((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns)))
+                          (reduce
+                            (fn (acc qname)
+                              (let
+                                ((tail (tcl-ns-tail qname)))
+                                (tcl-dict-set-pair acc tail qname)))
+                            ""
+                            ns-proc-names))
+                        map-str)))
+                    ; ensemble command name = tail of current-ns
+                    (let
+                      ((ens-name (tcl-ns-tail current-ns))
+                        (ens-fn (tcl-make-ensemble (get interp :procs) current-ns dispatch-map)))
+                      (assoc interp
+                        :commands (assoc (get interp :commands) ens-name ens-fn)
+                        :result "")))))
+              (error "namespace ensemble: unknown subcommand")))
+          (else (error (str "namespace: unknown subcommand \"" sub "\""))))))))
+
 ; --- info command ---
 
 (define
@@ -2454,29 +2749,33 @@
           ; info commands
           ((equal? sub "commands")
             (assoc interp :result (tcl-list-build (keys (get interp :commands)))))
-          ; info procs
+          ; info procs — return unqualified names of procs in current namespace
           ((equal? sub "procs")
-            (assoc interp :result (tcl-list-build (keys (get interp :procs)))))
+            (let
+              ((current-ns (get interp :current-ns)))
+              (let
+                ((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns)))
+                (assoc interp :result (tcl-list-build (map tcl-ns-tail ns-proc-names))))))
           ; info args procname
           ((equal? sub "args")
             (let
               ((pname (first rest-args)))
               (let
-                ((proc-def (get (get interp :procs) pname)))
+                ((entry (tcl-proc-lookup interp pname)))
                 (if
-                  (nil? proc-def)
+                  (nil? entry)
                   (error (str "info args: \"" pname "\" isn't a procedure"))
-                  (assoc interp :result (get proc-def :args))))))
+                  (assoc interp :result (get (get entry :def) :args))))))
           ; info body procname
           ((equal? sub "body")
             (let
               ((pname (first rest-args)))
               (let
-                ((proc-def (get (get interp :procs) pname)))
+                ((entry (tcl-proc-lookup interp pname)))
                 (if
-                  (nil? proc-def)
+                  (nil? entry)
                   (error (str "info body: \"" pname "\" isn't a procedure"))
-                  (assoc interp :result (get proc-def :body))))))
+                  (assoc interp :result (get (get entry :def) :body))))))
           (else (error (str "info: unknown subcommand \"" sub "\""))))))))
 
 (define
@@ -2571,4 +2870,6 @@
                                                                                           ((i (tcl-register i "catch" tcl-cmd-catch)))
                                                                                           (let
                                                                                             ((i (tcl-register i "throw" tcl-cmd-throw)))
-                                                                                            (tcl-register i "try" tcl-cmd-try)))))))))))))))))))))))))))))))))))))))))))))))
+                                                                                            (let
+                                                                                              ((i (tcl-register i "try" tcl-cmd-try)))
+                                                                                              (tcl-register i "namespace" tcl-cmd-namespace))))))))))))))))))))))))))))))))))))))))))))))))