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:
@@ -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))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
|
||||
@@ -19,10 +19,12 @@ cat > "$HELPER" << 'HELPER_EOF'
|
||||
(define __pr (tcl-run-parse-tests))
|
||||
(define __er (tcl-run-eval-tests))
|
||||
(define __xr (tcl-run-error-tests))
|
||||
(define __nr (tcl-run-namespace-tests))
|
||||
(define tcl-test-summary
|
||||
(str "PARSE:" (get __pr "passed") ":" (get __pr "failed")
|
||||
" EVAL:" (get __er "passed") ":" (get __er "failed")
|
||||
" ERROR:" (get __xr "passed") ":" (get __xr "failed")))
|
||||
" ERROR:" (get __xr "passed") ":" (get __xr "failed")
|
||||
" NAMESPACE:" (get __nr "passed") ":" (get __nr "failed")))
|
||||
HELPER_EOF
|
||||
|
||||
cat > "$TMPFILE" << EPOCHS
|
||||
@@ -39,16 +41,18 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(epoch 6)
|
||||
(load "lib/tcl/tests/error.sx")
|
||||
(epoch 7)
|
||||
(load "$HELPER")
|
||||
(load "lib/tcl/tests/namespace.sx")
|
||||
(epoch 8)
|
||||
(load "$HELPER")
|
||||
(epoch 9)
|
||||
(eval "tcl-test-summary")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 90 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||
|
||||
# Extract summary line from epoch 8 output
|
||||
SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 8 " | tail -1 | tr -d '"')
|
||||
# Extract summary line from epoch 9 output
|
||||
SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 9 " | tail -1 | tr -d '"')
|
||||
|
||||
if [ -z "$SUMMARY" ]; then
|
||||
echo "ERROR: no summary from test run"
|
||||
@@ -56,31 +60,35 @@ if [ -z "$SUMMARY" ]; then
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# 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 PARSE:N:M EVAL:N:M ERROR:N:M NAMESPACE: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]*')
|
||||
NAMESPACE_PART=$(echo "$SUMMARY" | grep -o 'NAMESPACE:[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=$(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)
|
||||
NAMESPACE_PASSED=$(echo "$NAMESPACE_PART" | cut -d: -f2)
|
||||
NAMESPACE_FAILED=$(echo "$NAMESPACE_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}
|
||||
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}
|
||||
NAMESPACE_PASSED=${NAMESPACE_PASSED:-0}; NAMESPACE_FAILED=${NAMESPACE_FAILED:-1}
|
||||
|
||||
TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED + ERROR_PASSED))
|
||||
TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED + ERROR_FAILED))
|
||||
TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED + ERROR_PASSED + NAMESPACE_PASSED))
|
||||
TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED + ERROR_FAILED + NAMESPACE_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, error: $ERROR_PASSED)"
|
||||
echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED, error: $ERROR_PASSED, namespace: $NAMESPACE_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)), error: $ERROR_PASSED/$((ERROR_PASSED+ERROR_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)), namespace: $NAMESPACE_PASSED/$((NAMESPACE_PASSED+NAMESPACE_FAILED)))"
|
||||
if [ -z "$VERBOSE" ]; then
|
||||
echo "--- output ---"
|
||||
echo "$OUTPUT" | tail -30
|
||||
|
||||
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