From 83dbb5958adaa2478add8a13b3f9b81cb4415036 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 6 May 2026 19:13:28 +0000 Subject: [PATCH] =?UTF-8?q?tcl:=20Phase=204=20env-as-value=20=E2=80=94=20c?= =?UTF-8?q?urrent-env/eval-in-env/env-lookup/env-extend=20(+5=20tests,=203?= =?UTF-8?q?42/342=20total)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- hosts/ocaml/bin/sx_server.ml | 32 ++++++- hosts/ocaml/lib/sx_primitives.ml | 34 +++++++- hosts/ocaml/lib/sx_runtime.ml | 1 + lib/tcl/tests/idioms.sx | 143 ++++++++++++++++--------------- 4 files changed, 137 insertions(+), 73 deletions(-) diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index a14d9e25..8be1f004 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -688,6 +688,11 @@ let setup_evaluator_bridge env = | [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e)) | [expr] -> Sx_ref.eval_expr expr (Env env) | _ -> raise (Eval_error "eval-expr: expected (expr env?)")); + (* eval-in-env: (env expr) → result. Evaluates expr in the given env. *) + Sx_primitives.register "eval-in-env" (fun args -> + match args with + | [e; expr] -> Sx_ref.eval_expr expr e + | _ -> raise (Eval_error "eval-in-env: (env expr)")); bind "trampoline" (fun args -> match args with | [v] -> @@ -749,7 +754,13 @@ let setup_evaluator_bridge env = | _ -> raise (Eval_error "register-special-form!: expected (name handler)")); ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms); ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args -> - List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args)))) + List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args)))); + (* current-env: special form — returns current lexical env as a first-class value *) + ignore (Sx_ref.register_special_form (String "current-env") + (NativeFn ("current-env", fun args -> + match args with + | [_arg_list; env_val] -> env_val + | _ -> Nil))) (* ---- Type predicates and introspection ---- *) let setup_introspection env = @@ -935,7 +946,24 @@ let setup_env_operations env = bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string")); bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value")); bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value")); - bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env")); + bind "env-extend" (fun args -> + match args with + | e :: pairs -> + let child = Sx_types.env_extend (uw e) in + let rec go = function + | [] -> () + | k :: v :: rest -> + ignore (Sx_types.env_bind child (Sx_runtime.value_to_str k) v); go rest + | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in + go pairs; Env child + | _ -> raise (Eval_error "env-extend: expected env")); + bind "env-lookup" (fun args -> + match args with + | [e; key] -> + let k = Sx_runtime.value_to_str key in + let raw = uw e in + if Sx_types.env_has raw k then Sx_types.env_get raw k else Nil + | _ -> raise (Eval_error "env-lookup: (env key)")); bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs")) (* ---- Strict mode (gradual type system support) ---- *) diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 4a0cd7f8..c9c8feed 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -2010,4 +2010,36 @@ let () = end done; String (Buffer.contents buf) - | _ -> raise (Eval_error "clock-format: (seconds [format])")) + | _ -> raise (Eval_error "clock-format: (seconds [format])")); + + (* === Env-as-value (Phase 4) === *) + + (* env-lookup: (env key) → value or nil. Works on Env, Dict, or Nil. *) + register "env-lookup" (fun args -> + let unwrap = function + | Env e -> e + | Nil -> make_env () + | _ -> raise (Eval_error "env-lookup: first arg must be an environment") in + match args with + | [env_val; key] -> + let e = unwrap env_val in + let k = value_to_string key in + if env_has e k then env_get e k else Nil + | _ -> raise (Eval_error "env-lookup: (env key)")); + + (* env-extend: (env [key val ...]) → new child env with optional bindings. *) + register "env-extend" (fun args -> + match args with + | [] -> raise (Eval_error "env-extend: requires at least one arg") + | env_val :: pairs -> + let parent_env = match env_val with + | Env e -> e + | Nil -> make_env () + | _ -> raise (Eval_error "env-extend: first arg must be an environment") in + let child = env_extend parent_env in + let rec add_bindings = function + | [] -> () + | k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest + | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in + add_bindings pairs; + Env child) diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index bb36af60..a912ac6a 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -529,3 +529,4 @@ let jit_try_call f args = (match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel) | _ -> incr _jit_skip; _jit_skip_sentinel + diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx index 1a6fac71..c5009adb 100644 --- a/lib/tcl/tests/idioms.sx +++ b/lib/tcl/tests/idioms.sx @@ -29,161 +29,164 @@ (define ok (fn (label actual expected) (tcl-idiom-assert label expected actual))) - - ; 1. lmap idiom: accumulate mapped values with foreach+lappend - (ok "idiom-lmap" + (ok + "idiom-lmap" (get - (run "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result") + (run + "set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result") :result) "1 4 9") - - ; 2. Recursive list flatten - (ok "idiom-flatten" + (ok + "idiom-flatten" (get (run "proc flatten {lst} { set out {}\n foreach item $lst {\n if {[llength $item] > 1} {\n foreach sub [flatten $item] { lappend out $sub }\n } else {\n lappend out $item\n }\n }\n return $out\n}\nflatten {1 {2 3} {4 {5 6}}}") :result) "1 2 3 4 5 6") - - ; 3. String builder accumulator - (ok "idiom-string-builder" + (ok + "idiom-string-builder" (get - (run "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf") + (run + "set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf") :result) "Hello World Tcl") - - ; 4. Default parameter via info exists - (ok "idiom-default-param" - (get - (run "if {![info exists x]} { set x 42 }\nset x") - :result) + (ok + "idiom-default-param" + (get (run "if {![info exists x]} { set x 42 }\nset x") :result) "42") - - ; 5. Association list lookup (parallel key/value lists) - (ok "idiom-alist-lookup" + (ok + "idiom-alist-lookup" (get (run "set keys {a b c}\nset vals {10 20 30}\nset idx [lsearch $keys b]\nlindex $vals $idx") :result) "20") - - ; 6. Proc with optional args via args - (ok "idiom-optional-args" + (ok + "idiom-optional-args" (get (run "proc greet {name args} {\n set greeting \"Hello\"\n if {[llength $args] > 0} { set greeting [lindex $args 0] }\n return \"$greeting $name\"\n}\ngreet World Hi") :result) "Hi World") - - ; 7. Builder pattern: dict create from args - (ok "idiom-dict-builder" + (ok + "idiom-dict-builder" (get (run "proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name") :result) "Alice") - - ; 8. Loop with index using array - (ok "idiom-loop-with-index" + (ok + "idiom-loop-with-index" (get - (run - "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)") + (run "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)") :result) "b") - - ; 9. String reverse via split+lreverse+join - (ok "idiom-string-reverse" + (ok + "idiom-string-reverse" (get (run "set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"") :result) "olleh") - - ; 10. Number to padded string - (ok "idiom-number-format" - (get (run "format \"%05d\" 42") :result) - "00042") - - ; 11. Dict comprehension pattern - (ok "idiom-dict-comprehension" + (ok "idiom-number-format" (get (run "format \"%05d\" 42") :result) "00042") + (ok + "idiom-dict-comprehension" (get (run "set squares {}\nforeach n {1 2 3 4} { dict set squares $n [expr {$n * $n}] }\ndict get $squares 3") :result) "9") - - ; 12. Stack ADT using list: push/pop - (ok "idiom-stack" + (ok + "idiom-stack" (get (run "proc stack-push {stackvar val} { upvar $stackvar s; lappend s $val }\nproc stack-pop {stackvar} { upvar $stackvar s; set val [lindex $s end]; set s [lrange $s 0 end-1]; return $val }\nset stk {}\nstack-push stk 10\nstack-push stk 20\nstack-push stk 30\nstack-pop stk") :result) "30") - - ; 13. Queue ADT using list: enqueue/dequeue - (ok "idiom-queue" + (ok + "idiom-queue" (get (run "proc q-enq {qvar val} { upvar $qvar q; lappend q $val }\nproc q-deq {qvar} { upvar $qvar q; set val [lindex $q 0]; set q [lrange $q 1 end]; return $val }\nset q {}\nq-enq q alpha\nq-enq q beta\nq-enq q gamma\nq-deq q") :result) "alpha") - - ; 14. Pipeline via proc chaining - (ok "idiom-pipeline" + (ok + "idiom-pipeline" (get (run "proc double {x} { expr {$x * 2} }\nproc add1 {x} { expr {$x + 1} }\nproc pipeline {val procs} { foreach p $procs { set val [$p $val] }; return $val }\npipeline 5 {double add1 double}") :result) "22") - - ; 15. Memoize pattern using dict (simple cache, not recursive) - (ok "idiom-memoize" + (ok + "idiom-memoize" (get (run "set cache {}\nproc cached-square {n} { global cache\n if {[dict exists $cache $n]} { return [dict get $cache $n] }\n set r [expr {$n * $n}]\n dict set cache $n $r\n return $r\n}\nset a [cached-square 7]\nset b [cached-square 7]\nset c [cached-square 8]\nexpr {$a == $b && $c == 64}") :result) "1") - - ; 16. Simple expression evaluator in Tcl (recursive descent) - (ok "idiom-recursive-eval" + (ok + "idiom-recursive-eval" (get (run "proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}") :result) "11") - - ; 17. Apply proc to each pair in a dict - (ok "idiom-dict-for" + (ok + "idiom-dict-for" (get (run "set d [dict create a 1 b 2 c 3]\nset total 0\ndict for {k v} $d { incr total $v }\nset total") :result) "6") - - ; 18. Find max in list - (ok "idiom-find-max" + (ok + "idiom-find-max" (get (run "proc list-max {lst} {\n set m [lindex $lst 0]\n foreach x $lst { if {$x > $m} { set m $x } }\n return $m\n}\nlist-max {3 1 4 1 5 9 2 6}") :result) "9") - - ; 19. Filter list by predicate - (ok "idiom-filter-list" + (ok + "idiom-filter-list" (get (run "proc list-filter {lst pred} {\n set out {}\n foreach x $lst { if {[$pred $x]} { lappend out $x } }\n return $out\n}\nproc is-even {n} { expr {$n % 2 == 0} }\nlist-filter {1 2 3 4 5 6} is-even") :result) "2 4 6") - - ; 20. Zip two lists - (ok "idiom-zip" + (ok + "idiom-zip" (get (run "proc zip {a b} {\n set out {}\n set n [llength $a]\n for {set i 0} {$i < $n} {incr i} {\n lappend out [lindex $a $i]\n lappend out [lindex $b $i]\n }\n return $out\n}\nzip {1 2 3} {a b c}") :result) "1 a 2 b 3 c") - + (ok + "env-lookup-basic" + (env-lookup (let ((x 42)) (current-env)) "x") + 42) + (ok + "env-lookup-missing" + (env-lookup (let ((x 42)) (current-env)) "z") + nil) + (ok + "env-extend-lookup" + (let + ((e (let ((x 5)) (current-env)))) + (env-lookup (env-extend e "y" 10) "y")) + 10) + (ok + "eval-in-env-parent" + (let + ((x 5)) + (eval-in-env (env-extend (current-env) "y" 10) (quote (+ x y)))) + 15) + (ok + "eval-in-env-multi" + (let + ((base (current-env))) + (eval-in-env + (env-extend (env-extend base "a" 3) "b" 7) + (quote (* a b)))) + 21) (dict "passed" tcl-idiom-pass