tcl: Phase 4 env-as-value — current-env/eval-in-env/env-lookup/env-extend (+5 tests, 342/342 total)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

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) ---- *)

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)

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
 
+

lib/tcl/tests/idioms.sx

@@ -29,161 +29,164 @@
     (define
       ok
       (fn (label actual expected) (tcl-idiom-assert label expected actual)))
-
+    (ok
-    ; 1. lmap idiom: accumulate mapped values with foreach+lappend
+      "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")
-
+    (ok
-    ; 2. Recursive list flatten
+      "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")
-
+    (ok
-    ; 3. String builder accumulator
+      "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")
-
+    (ok
-    ; 4. Default parameter via info exists
+      "idiom-default-param"
-    (ok "idiom-default-param"
+      (get (run "if {![info exists x]} { set x 42 }\nset x") :result)
-      (get
-        (run "if {![info exists x]} { set x 42 }\nset x")
-        :result)
       "42")
-
+    (ok
-    ; 5. Association list lookup (parallel key/value lists)
+      "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")
-
+    (ok
-    ; 6. Proc with optional args via args
+      "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")
-
+    (ok
-    ; 7. Builder pattern: dict create from args
+      "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")
-
+    (ok
-    ; 8. Loop with index using array
+      "idiom-loop-with-index"
-    (ok "idiom-loop-with-index"
       (get
-        (run
+        (run "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)")
-          "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)")
         :result)
       "b")
-
+    (ok
-    ; 9. String reverse via split+lreverse+join
+      "idiom-string-reverse"
-    (ok "idiom-string-reverse"
       (get
         (run
           "set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"")
         :result)
       "olleh")
-
+    (ok "idiom-number-format" (get (run "format \"%05d\" 42") :result) "00042")
-    ; 10. Number to padded string
+    (ok
-    (ok "idiom-number-format"
+      "idiom-dict-comprehension"
-      (get (run "format \"%05d\" 42") :result)
-      "00042")
-
-    ; 11. Dict comprehension pattern
-    (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")
-
+    (ok
-    ; 12. Stack ADT using list: push/pop
+      "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")
-
+    (ok
-    ; 13. Queue ADT using list: enqueue/dequeue
+      "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")
-
+    (ok
-    ; 14. Pipeline via proc chaining
+      "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")
-
+    (ok
-    ; 15. Memoize pattern using dict (simple cache, not recursive)
+      "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")
-
+    (ok
-    ; 16. Simple expression evaluator in Tcl (recursive descent)
+      "idiom-recursive-eval"
-    (ok "idiom-recursive-eval"
       (get
         (run
           "proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}")
         :result)
       "11")
-
+    (ok
-    ; 17. Apply proc to each pair in a dict
+      "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")
-
+    (ok
-    ; 18. Find max in list
+      "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")
-
+    (ok
-    ; 19. Filter list by predicate
+      "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")
-
+    (ok
-    ; 20. Zip two lists
+      "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