tcl: Phase 5 namespaces + ensembles (+22 tests, 289 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 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>
This commit is contained in:
147
lib/tcl/tests/namespace.sx
Normal file
147
lib/tcl/tests/namespace.sx
Normal file
@@ -0,0 +1,147 @@
|
||||
; Tcl-on-SX namespace tests (Phase 5)
|
||||
(define tcl-ns-pass 0)
|
||||
(define tcl-ns-fail 0)
|
||||
(define tcl-ns-failures (list))
|
||||
|
||||
(define
|
||||
tcl-ns-assert
|
||||
(fn
|
||||
(label expected actual)
|
||||
(if
|
||||
(equal? expected actual)
|
||||
(set! tcl-ns-pass (+ tcl-ns-pass 1))
|
||||
(begin
|
||||
(set! tcl-ns-fail (+ tcl-ns-fail 1))
|
||||
(append!
|
||||
tcl-ns-failures
|
||||
(str label ": expected=" (str expected) " got=" (str actual)))))))
|
||||
|
||||
(define
|
||||
tcl-run-namespace-tests
|
||||
(fn
|
||||
()
|
||||
(set! tcl-ns-pass 0)
|
||||
(set! tcl-ns-fail 0)
|
||||
(set! tcl-ns-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-ns-assert label expected actual)))
|
||||
(define
|
||||
ok?
|
||||
(fn (label condition) (tcl-ns-assert label true condition)))
|
||||
|
||||
; --- namespace current ---
|
||||
(ok "ns-current-global"
|
||||
(get (run "namespace current") :result)
|
||||
"::")
|
||||
|
||||
; --- namespace eval defines proc ---
|
||||
(ok "ns-eval-proc-result"
|
||||
(get (run "namespace eval myns { proc foo {} { return bar } }\nmyns::foo") :result)
|
||||
"bar")
|
||||
|
||||
; --- fully qualified call ---
|
||||
(ok "ns-qualified-call"
|
||||
(get (run "namespace eval myns { proc greet {name} { return \"hello $name\" } }\n::myns::greet World") :result)
|
||||
"hello World")
|
||||
|
||||
; --- namespace current inside eval ---
|
||||
(ok "ns-current-inside"
|
||||
(get (run "namespace eval myns { namespace current }") :result)
|
||||
"::myns")
|
||||
|
||||
; --- namespace current restored after eval ---
|
||||
(ok "ns-current-restored"
|
||||
(get (run "namespace eval myns { set x 1 }\nnamespace current") :result)
|
||||
"::")
|
||||
|
||||
; --- relative call from within namespace ---
|
||||
(ok "ns-relative-call"
|
||||
(get (run "namespace eval math {\n proc double {x} { expr {$x * 2} }\n proc quad {x} { double [double $x] }\n}\nmath::quad 3") :result)
|
||||
"12")
|
||||
|
||||
; --- proc defined as qualified name inside namespace eval ---
|
||||
(ok "ns-qualified-proc-name"
|
||||
(get (run "namespace eval utils { proc ::utils::helper {x} { return $x } }\n::utils::helper done") :result)
|
||||
"done")
|
||||
|
||||
; --- namespace exists ---
|
||||
(ok "ns-exists-yes"
|
||||
(get (run "namespace eval testns { proc p {} {} }\nnamespace exists testns") :result)
|
||||
"1")
|
||||
|
||||
(ok "ns-exists-no"
|
||||
(get (run "namespace exists nosuchns") :result)
|
||||
"0")
|
||||
|
||||
(ok "ns-exists-global"
|
||||
(get (run "proc top {} {}\nnamespace exists ::") :result)
|
||||
"1")
|
||||
|
||||
; --- namespace delete ---
|
||||
(ok "ns-delete-removes"
|
||||
(get (run "namespace eval todel { proc pp {} { return yes } }\nnamespace delete todel\nnamespace exists todel") :result)
|
||||
"0")
|
||||
|
||||
; --- namespace which ---
|
||||
(ok "ns-which-found"
|
||||
(get (run "namespace eval wns { proc wfn {} {} }\nnamespace which -command wns::wfn") :result)
|
||||
"::wns::wfn")
|
||||
|
||||
(ok "ns-which-not-found"
|
||||
(get (run "namespace which -command nosuchfn") :result)
|
||||
"")
|
||||
|
||||
; --- namespace ensemble create auto-map ---
|
||||
(ok "ns-ensemble-add"
|
||||
(get (run "namespace eval mymath {\n proc add {a b} { expr {$a + $b} }\n proc mul {a b} { expr {$a * $b} }\n namespace ensemble create\n}\nmymath add 3 4") :result)
|
||||
"7")
|
||||
|
||||
(ok "ns-ensemble-mul"
|
||||
(get (run "namespace eval mymath {\n proc add {a b} { expr {$a + $b} }\n proc mul {a b} { expr {$a * $b} }\n namespace ensemble create\n}\nmymath mul 3 4") :result)
|
||||
"12")
|
||||
|
||||
; --- namespace ensemble with -map ---
|
||||
(ok "ns-ensemble-map"
|
||||
(get (run "namespace eval ops {\n proc do-add {a b} { expr {$a + $b} }\n namespace ensemble create -map {plus ::ops::do-add}\n}\nops plus 5 6") :result)
|
||||
"11")
|
||||
|
||||
; --- proc inside namespace eval with args ---
|
||||
(ok "ns-proc-args"
|
||||
(get (run "namespace eval calc {\n proc sum {a b c} { expr {$a + $b + $c} }\n}\ncalc::sum 1 2 3") :result)
|
||||
"6")
|
||||
|
||||
; --- info procs inside namespace ---
|
||||
(ok? "ns-info-procs-in-ns"
|
||||
(let
|
||||
((r (get (run "namespace eval foo { proc bar {} {} }\nnamespace eval foo { info procs }") :result)))
|
||||
(contains? (tcl-list-split r) "bar")))
|
||||
|
||||
; --- variable inside namespace eval ---
|
||||
(ok "ns-variable-inside"
|
||||
(get (run "namespace eval storage {\n variable count 0\n proc bump {} { global count\n incr count\n return $count }\n}\n::storage::bump\n::storage::bump") :result)
|
||||
"2")
|
||||
|
||||
; --- nested namespaces ---
|
||||
(ok "ns-nested"
|
||||
(get (run "namespace eval outer {\n namespace eval inner {\n proc greet {} { return nested }\n }\n}\n::outer::inner::greet") :result)
|
||||
"nested")
|
||||
|
||||
; --- namespace eval accumulates procs ---
|
||||
(ok "ns-eval-accumulate"
|
||||
(get (run "namespace eval acc { proc f1 {} { return one } }\nnamespace eval acc { proc f2 {} { return two } }\nacc::f1") :result)
|
||||
"one")
|
||||
|
||||
(ok "ns-eval-accumulate-2"
|
||||
(get (run "namespace eval acc { proc f1 {} { return one } }\nnamespace eval acc { proc f2 {} { return two } }\nacc::f2") :result)
|
||||
"two")
|
||||
|
||||
(dict
|
||||
"passed"
|
||||
tcl-ns-pass
|
||||
"failed"
|
||||
tcl-ns-fail
|
||||
"failures"
|
||||
tcl-ns-failures)))
|
||||
Reference in New Issue
Block a user