From 1d68f20a37d05430d943bed316e52c8e38bebe67 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 5 Apr 2026 19:31:00 +0000 Subject: [PATCH] CEK-safe native call boundary: apply-cek + eval-error? marker MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Native functions (NativeFn/VmClosure) called through the CEK evaluator can now have their Eval_errors caught by guard/handler-bind. The fix is at the exact OCaml↔CEK boundary in continue-with-call: - sx_runtime.ml: sx_apply_cek wraps native calls, returns error marker dict {__eval_error__: true, message: "..."} instead of raising - sx_runtime.ml: is_eval_error predicate checks for the marker - spec/evaluator.sx: continue-with-call callable branch uses apply-cek, detects error markers, converts to raise-eval CEK state - transpiler.sx: apply-cek and eval-error? emit cases added No mutable flags, no re-entry risk. Errors flow through the CEK handler chain naturally. 2798/2800 tests pass. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/lib/sx_ref.ml | 2 +- hosts/ocaml/lib/sx_runtime.ml | 22 ++++++++++++++++++++++ hosts/ocaml/transpiler.sx | 14 ++++++++++++++ spec/evaluator.sx | 10 +++++++++- 4 files changed, 46 insertions(+), 2 deletions(-) diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 130c86ef..a739fbda 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -895,7 +895,7 @@ and step_continue state = (* continue-with-call *) and continue_with_call f args env raw_args kont = - (if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((is_nil (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))))) + (if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (let result' = (sx_apply_cek f args) in (if sx_truthy ((Bool (is_eval_error result'))) then (make_cek_value ((get (result') ((String "message")))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_value (result') (env) (kont)))) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((is_nil (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))))) (* sf-case-step-loop *) and sf_case_step_loop match_val clauses env kont = diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index 6692fd70..73be4a56 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -67,6 +67,28 @@ let () = Sx_primitives._sx_call_fn := sx_call let sx_apply f args_list = sx_call f (sx_to_list args_list) +(** CEK-safe apply — catches Eval_error from native fns and returns an error + marker dict instead of raising. The CEK evaluator checks for this and + converts to a raise-eval state so guard/handler-bind can intercept it. + Non-native calls (lambda, continuation) delegate to sx_apply unchanged. *) +let sx_apply_cek f args_list = + match f with + | NativeFn _ | VmClosure _ -> + (try sx_apply f args_list + with Eval_error msg -> + let d = Hashtbl.create 3 in + Hashtbl.replace d "__eval_error__" (Bool true); + Hashtbl.replace d "message" (String msg); + Dict d) + | _ -> sx_apply f args_list + +(** Check if a value is an eval-error marker from sx_apply_cek. *) +let is_eval_error v = + match v with + | Dict d -> (match Hashtbl.find_opt d "__eval_error__" with + | Some (Bool true) -> true | _ -> false) + | _ -> false + (** Mutable append — add item to a list ref or accumulator. In transpiled code, lists that get appended to are mutable refs. *) let sx_append_b lst item = diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index aeefdb44..eb670121 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -226,6 +226,8 @@ "register-library" "sx-call" "sx-apply" + "apply-cek" + "eval-error?" "collect!" "collected" "clear-collected!" @@ -798,6 +800,18 @@ " " (ml-expr-inner (nth args 1) set-vars) ")") + (= op "apply-cek") + (str + "(sx_apply_cek " + (ml-expr-inner (first args) set-vars) + " " + (ml-expr-inner (nth args 1) set-vars) + ")") + (= op "eval-error?") + (str + "(Bool (is_eval_error " + (ml-expr-inner (first args) set-vars) + "))") (= op "for-each") (ml-emit-for-each args set-vars) (= op "map") diff --git a/spec/evaluator.sx b/spec/evaluator.sx index 2922b954..66521c55 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -4247,7 +4247,15 @@ (not (lambda? f)) (not (component? f)) (not (island? f))) - (make-cek-value (apply f args) env kont) + (let + ((result (apply-cek f args))) + (if + (eval-error? result) + (make-cek-value + (get result "message") + env + (kont-push (make-raise-eval-frame env false) kont)) + (make-cek-value result env kont))) (lambda? f) (let ((params (lambda-params f))