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

R7RS guard special form + transpiler fixes

Browse Source 
- guard as CEK special form in evaluator.sx, desugars to call/cc +
  handler-bind with sentinel-based re-raise (avoids handler loop)
- bootstrap.py: fix bind_lambda_with_rest type annotations, auto-inject
  make_raise_guard_frame when transpiler drops it
- mcp_tree: add timeout param to sx_test (default 300s)
- 2566/2568 tests pass (2 pre-existing scope failures)

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-03 12:34:01 +00:00
parent 508a0017a7
commit 21ad052272
4 changed files with 105 additions and 13 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
hosts/ocaml/bin/mcp_tree.ml
View File

@@ -704,13 +704,14 @@ let rec handle_tool name args =
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let timeout = args |> member "timeout" |> to_int_option |> Option.value ~default:300 in
let cmd = match host with
| "ocaml" ->
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && dune exec bin/run_tests.exe%s 2>&1"
project_dir (if full then " -- --full" else "")
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && timeout %d dune exec bin/run_tests.exe%s 2>&1"
project_dir timeout (if full then " -- --full" else "")
| "js" | _ ->
Printf.sprintf "cd %s && node hosts/javascript/run_tests.js%s 2>&1"
project_dir (if full then " --full" else "")
Printf.sprintf "cd %s && timeout %d node hosts/javascript/run_tests.js%s 2>&1"
project_dir timeout (if full then " --full" else "")
in
let ic = Unix.open_process_in cmd in
let lines = ref [] in

19
hosts/ocaml/bootstrap.py
View File

@@ -320,7 +320,8 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
# The transpiler can't handle the index-of-based approach, so we inject it.
REST_HELPER = """
(* &rest lambda param binding — injected by bootstrap.py *)
and bind_lambda_with_rest params args local =
and bind_lambda_with_rest (params : value) (args : value) (local_val : value) : bool =
let local = match local_val with Env e -> e | _ -> failwith "bind_lambda_with_rest: expected env" in
let param_list = sx_to_list params in
let arg_list = sx_to_list args in
let rec find_rest i = function
@@ -333,12 +334,12 @@ and bind_lambda_with_rest params args local =
let positional = List.filteri (fun i _ -> i < pos) param_list in
List.iteri (fun i p ->
let v = if i < List.length arg_list then List.nth arg_list i else Nil in
ignore (env_bind local (value_to_str p) v)
ignore (Sx_types.env_bind local (value_to_str p) v)
) positional;
let rest_args = if List.length arg_list > pos
then List (List.filteri (fun i _ -> i >= pos) arg_list)
else List [] in
ignore (env_bind local rest_name rest_args);
ignore (Sx_types.env_bind local rest_name rest_args);
true
| None -> false
"""
@@ -348,6 +349,18 @@ and bind_lambda_with_rest params args local =
REST_HELPER + "\n(* call-lambda *)\nand call_lambda",
)
# Inject make_raise_guard_frame if missing (transpiler merge bug drops it)
if "and make_raise_guard_frame" not in output:
RAISE_GUARD_FRAME = """
(* make-raise-guard-frame — injected by bootstrap.py *)
and make_raise_guard_frame env saved_kont =
(CekFrame { cf_type = "raise-guard"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = saved_kont; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
"""
output = output.replace(
"(* make-signal-return-frame *)\nand make_signal_return_frame",
RAISE_GUARD_FRAME + "\n(* make-signal-return-frame *)\nand make_signal_return_frame",
)
# Patch call_lambda to use &rest-aware binding
call_lambda_marker = "(* call-lambda *)\nand call_lambda f args caller_env =\n"
call_comp_marker = "\n(* call-component *)"

16
hosts/ocaml/lib/sx_ref.ml
View File

File diff suppressed because one or more lines are too long

74
spec/evaluator.sx
View File

@@ -1028,6 +1028,79 @@
env
(kont-push (make-raise-eval-frame env false) kont))))
(define
step-sf-guard
(fn
(args env kont)
(let
((var-clauses (first args))
(body (rest args))
(var (first var-clauses))
(clauses (rest var-clauses))
(sentinel (make-symbol "__guard-reraise__")))
(step-eval-list
(list
(quote let)
(list
(list
(quote __guard-result)
(cons
(quote call/cc)
(list
(cons
(quote fn)
(cons
(quote (__guard-k))
(list
(cons
(quote handler-bind)
(cons
(list
(list
(cons
(quote fn)
(cons (quote (_)) (quote (true))))
(cons
(quote fn)
(cons
(list var)
(list
(list
(quote __guard-k)
(cons
(quote cond)
(append
clauses
(list
(list
(quote else)
(list
(quote list)
(list
(quote quote)
sentinel)
var)))))))))))
(list
(list
(quote __guard-k)
(cons (quote begin) body))))))))))))
(list
(quote if)
(list
(quote and)
(list (quote list?) (quote __guard-result))
(list (quote =) (list (quote len) (quote __guard-result)) 2)
(list
(quote =)
(list (quote first) (quote __guard-result))
(list (quote quote) sentinel)))
(list
(quote raise)
(list (quote nth) (quote __guard-result) 1))
(quote __guard-result)))
env
kont))))
(define
step-eval-list
(fn
@@ -1116,6 +1189,7 @@
env
kont))
(step-sf-begin args env kont)))
("guard" (step-sf-guard args env kont))
("quote"
(make-cek-value
(if (empty? args) nil (first args))