merge: architecture → loops/tcl — R7RS, JIT, env-as-value

Resolved conflicts in hosts/ocaml/lib/sx_primitives.ml:
- Took architecture's make-regexp/regexp-* primitives (Tcl runtime depends on them)
- Took architecture's Integer typing for clock-seconds/milliseconds/format
- Kept Phase 4 env-lookup/env-extend additions

Tcl: 342/342 tests passing.

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

hosts/ocaml/bin/sx_server.ml

@@ -703,6 +703,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] ->
@@ -764,7 +769,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 =
@@ -950,7 +961,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

@@ -3138,4 +3138,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

@@ -539,3 +539,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/fiber.sx

@@ -0,0 +1,44 @@
+; lib/fiber.sx — pure SX fiber library using call/cc
+;
+; A fiber is a cooperative coroutine with true suspension (no eager
+; pre-execution). Each fiber is a dict {:resume fn :done? fn}.
+;
+; make-fiber body   → fiber dict
+;   body = (fn (yield init-val) ...)  — body receives yield + first resume val
+;   yield = (fn (val) ...)            — suspends fiber, returns val to resumer
+;
+; fiber-resume f v  → next yielded value, or nil when body returns
+; fiber-done? f     → true after body has returned
+
+(define make-fiber
+  (fn (body)
+    (let
+      ((resume-k nil)
+        (caller-k nil)
+        (done false))
+      (let
+        ((yield
+            (fn (val)
+              (call/cc
+                (fn (k)
+                  (set! resume-k k)
+                  (caller-k val))))))
+        {:resume
+         (fn (val)
+           (if
+             done
+             nil
+             (call/cc
+               (fn (k)
+                 (set! caller-k k)
+                 (if
+                   (nil? resume-k)
+                   (begin
+                     (body yield val)
+                     (set! done true)
+                     (k nil))
+                   (resume-k val))))))
+         :done? (fn () done)}))))
+
+(define fiber-resume (fn (f v) ((get f :resume) v)))
+(define fiber-done?  (fn (f) ((get f :done?))))

lib/tcl/test.sh

@@ -39,6 +39,7 @@ cat > "$TMPFILE" << EPOCHS
 (epoch 3)
 (load "lib/tcl/tests/parse.sx")
 (epoch 4)
+(load "lib/fiber.sx")
 (load "lib/tcl/runtime.sx")
 (epoch 5)
 (load "lib/tcl/tests/eval.sx")

lib/tcl/tests/coro.sx

@@ -95,15 +95,15 @@
       (get (run "proc g {} { yield }\ncoroutine cg g\ncg") :result)
       "")
 
-    ; --- clock seconds stub ---
+    ; --- clock seconds ---
     (ok "clock-seconds"
-      (get (run "clock seconds") :result)
-      "0")
+      (> (parse-int (get (run "clock seconds") :result)) 0)
+      true)
 
-    ; --- clock milliseconds stub ---
+    ; --- clock milliseconds ---
     (ok "clock-milliseconds"
-      (get (run "clock milliseconds") :result)
-      "0")
+      (> (parse-int (get (run "clock milliseconds") :result)) 0)
+      true)
 
     ; --- clock format stub ---
     (ok "clock-format"

lib/tcl/tests/eval.sx

@@ -329,6 +329,54 @@
         (run "proc with-temp-var {varname tempval body} {\n    upvar 1 $varname v\n    set saved $v\n    set v $tempval\n    uplevel 1 $body\n    set v $saved\n}\nset x 100\nwith-temp-var x 999 {\n    set captured $x\n}\nlist $x $captured")
         :result)
       "100 999")
+    (ok
+      "array-set-get"
+      (get
+        (run "array set a {x 1 y 2 z 3}; array get a x")
+        :result)
+      "x 1")
+    (ok
+      "array-names"
+      (get
+        (run "array set a {p 10 q 20}; lsort [array names a]")
+        :result)
+      "p q")
+    (ok
+      "array-size"
+      (get
+        (run "array set a {x 1 y 2 z 3}; array size a")
+        :result)
+      "3")
+    (ok
+      "array-exists-true"
+      (get
+        (run "array set a {x 1}; array exists a")
+        :result)
+      "1")
+    (ok
+      "array-exists-false"
+      (get
+        (run "array exists nosucharray")
+        :result)
+      "0")
+    (ok
+      "array-unset-key"
+      (get
+        (run "array set a {x 1 y 2 z 3}; array unset a y; lsort [array names a]")
+        :result)
+      "x z")
+    (ok
+      "array-scalar-access"
+      (get
+        (run "set a(foo) hello; set a(bar) world; set a(foo)")
+        :result)
+      "hello")
+    (ok
+      "array-get-all"
+      (get
+        (run "set a(k) v; set pairs [array get a]; llength $pairs")
+        :result)
+      "2")
     (dict
       "passed"
       tcl-eval-pass

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