coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

tcl: Phase 4 env-as-value — current-env/eval-in-env/env-lookup/env-extend (+5 tests, 342/342 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 19:13:28 +00:00
parent d21cde336a
commit 83dbb5958a
4 changed files with 137 additions and 73 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
hosts/ocaml/bin/sx_server.ml
View File

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