diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 70d275ec..13b83e47 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1231,9 +1231,32 @@ let run_spec_tests env test_files = let s = ref state in let is_terminal st = match Sx_ref.cek_terminal_p st with Bool true -> true | _ -> false in let is_suspended st = match Sx_runtime.get_val st (String "phase") with String "io-suspended" -> true | _ -> false in + (* Check if kont has any handler frames — pure structural scan *) + let kont_has_handler kont = + let k = ref kont in + let found = ref false in + while (match !k with List (_::_) -> true | _ -> false) && not !found do + (match !k with + | List (frame :: rest) -> + (match frame with + | CekFrame f when f.cf_type = "handler" -> found := true + | _ -> ()); + k := List rest + | _ -> k := List []) + done; + !found in let rec loop () = while not (is_terminal !s) && not (is_suspended !s) do - s := Sx_ref.cek_step !s + (try s := Sx_ref.cek_step !s + with Eval_error msg -> + let kont = Sx_ref.cek_kont !s in + if kont_has_handler kont then + (* Convert to CEK-level raise so guard/handler-bind can catch it *) + let env = Sx_ref.cek_env !s in + s := Sx_ref.make_cek_value (String msg) env + (Sx_ref.kont_push (Sx_ref.make_raise_eval_frame env (Bool false)) kont) + else + raise (Eval_error msg)) done; if is_suspended !s then begin let request = Sx_runtime.get_val !s (String "request") in diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 0200c871..130c86ef 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -622,7 +622,7 @@ and kont_extract_provides kont = (* fire-provide-subscribers *) and fire_provide_subscribers name = - (let subs = (get (!_provide_subscribers_ref) (name)) in (if sx_truthy ((let _and = subs in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p (subs)))))))) then (if sx_truthy ((prim_call ">" [!_provide_batch_depth_ref; (Number 0.0)])) then (List.iter (fun sub -> ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_provide_batch_queue_ref; sub])))))) then (sx_append_b !_provide_batch_queue_ref sub) else Nil))) (sx_to_list subs); Nil) else (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list subs); Nil)) else Nil)) + (let subs = (get (!_provide_subscribers_ref) (name)) in (if sx_truthy ((let _and = subs in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p (subs)))))))) then (if sx_truthy ((prim_call ">" [!_provide_batch_depth_ref; (Number 0.0)])) then (List.iter (fun sub -> ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_provide_batch_queue_ref; sub])))))) then (_provide_batch_queue_ref := sx_append_b !_provide_batch_queue_ref sub; Nil) else Nil))) (sx_to_list subs); Nil) else (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list subs); Nil)) else Nil)) (* batch-begin! *) and batch_begin_b () = @@ -803,7 +803,7 @@ and step_sf_provide args env kont = (* step-sf-context *) and step_sf_context args env kont = - (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let default_val = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let frame = (kont_find_provide (kont) (name)) in (let () = ignore ((if sx_truthy (!_bind_tracking_ref) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_bind_tracking_ref; name])))))) then (sx_append_b !_bind_tracking_ref name) else Nil) else Nil)) in (make_cek_value ((let sv = (scope_peek (name)) in (if sx_truthy ((is_nil (sv))) then (if sx_truthy (frame) then (get (frame) ((String "value"))) else default_val) else sv))) (env) (kont)))) + (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let default_val = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let frame = (kont_find_provide (kont) (name)) in (let () = ignore ((if sx_truthy (!_bind_tracking_ref) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_bind_tracking_ref; name])))))) then (_bind_tracking_ref := sx_append_b !_bind_tracking_ref name; Nil) else Nil) else Nil)) in (make_cek_value ((let sv = (scope_peek (name)) in (if sx_truthy ((is_nil (sv))) then (if sx_truthy (frame) then (get (frame) ((String "value"))) else default_val) else sv))) (env) (kont)))) (* step-sf-peek *) and step_sf_peek args env kont = diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index 2a8af271..aeefdb44 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -834,30 +834,40 @@ (ml-emit-map-dict args set-vars) (= op "append!") (let - ((target (nth args 0)) + ((target (symbol-name (nth expr 1))) (item-expr (ml-expr-inner (nth args 1) set-vars))) (if - (and - (= (type-of target) "symbol") - (some - (fn (v) (= v (ml-mangle (symbol-name target)))) - set-vars)) + (ml-is-mutable-global? target) (let - ((mangled (ml-mangle (symbol-name target)))) + ((mangled (ml-mangle target))) (str "(" mangled - " := sx_append_b !" + "ref := sx_append_b !" mangled - " " + "ref " item-expr "; Nil)")) - (str - "(sx_append_b " - (ml-expr-inner target set-vars) - " " - item-expr - ")"))) + (if + (and + (= (type-of (nth expr 1)) "symbol") + (some (fn (v) (= v (ml-mangle target))) set-vars)) + (let + ((mangled (ml-mangle target))) + (str + "(" + mangled + " := sx_append_b !" + mangled + " " + item-expr + "; Nil)")) + (str + "(sx_append_b " + (ml-expr-inner (nth expr 1) set-vars) + " " + item-expr + ")")))) (= op "dict-set!") (str "(sx_dict_set_b "