From 5d1913e7304974b3865932a3c9072859ee3cfabe Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 26 Apr 2026 18:52:16 +0000 Subject: [PATCH] =?UTF-8?q?ocaml:=20ADT=20support=20via=20bootstrap=20FIXU?= =?UTF-8?q?PS=20=E2=80=94=20define-type=20+=20match?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Hand-write sf_define_type in bootstrap.py FIXUPS (skipped from transpile because the spec uses &rest params and empty-dict literals the transpiler can't emit). Registers define-type via register_special_form. Adds step_limit/step_count to PREAMBLE (referenced by sx_vm.ml/run_tests.ml). 172 assertions pass (test-adt). Full suite: 4280/1080 (was 4243/1117). Co-Authored-By: Claude Sonnet 4.6 --- hosts/ocaml/bootstrap.py | 93 +++++++++++++++++++++++++++++++++++++- hosts/ocaml/lib/sx_ref.ml | 94 +++++++++++++++++++++++++++++++++++++-- 2 files changed, 182 insertions(+), 5 deletions(-) diff --git a/hosts/ocaml/bootstrap.py b/hosts/ocaml/bootstrap.py index 0c9023a2..9f04f7ae 100644 --- a/hosts/ocaml/bootstrap.py +++ b/hosts/ocaml/bootstrap.py @@ -47,7 +47,9 @@ open Sx_runtime let trampoline_fn : (value -> value) ref = ref (fun v -> v) let trampoline v = !trampoline_fn v - +(* Step limit for timeout detection — set to 0 to disable *) +let step_limit : int ref = ref 0 +let step_count : int ref = ref 0 (* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *) let _strict_ref = ref (Bool false) @@ -126,6 +128,90 @@ let enhance_error_with_trace msg = _last_error_kont_ref := Nil; msg ^ (format_comp_trace trace) +(* Hand-written sf_define_type — skipped from transpile because the spec uses + &rest params and empty-dict literals that the transpiler can't emit cleanly. + Implements: (define-type Name (Ctor1 f1 f2) (Ctor2 f3) ...) + Creates constructor fns, Name?/Ctor? predicates, Ctor-field accessors, + and records ctors in *adt-registry*. *) +let sf_define_type args env_val = + let items = (match args with List l -> l | _ -> []) in + let type_sym = List.nth items 0 in + let type_name = value_to_string type_sym in + let ctor_specs = List.tl items in + let env_has_v k = sx_truthy (env_has env_val (String k)) in + let env_bind_v k v = ignore (env_bind env_val (String k) v) in + let env_get_v k = env_get env_val (String k) in + if not (env_has_v "*adt-registry*") then + env_bind_v "*adt-registry*" (Dict (Hashtbl.create 8)); + let registry = env_get_v "*adt-registry*" in + let ctor_names = List.map (fun spec -> + (match spec with List (sym :: _) -> String (value_to_string sym) | _ -> Nil) + ) ctor_specs in + (match registry with Dict d -> Hashtbl.replace d type_name (List ctor_names) | _ -> ()); + env_bind_v (type_name ^ "?") + (NativeFn (type_name ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iter (fun spec -> + (match spec with + | List (sym :: fields) -> + let cn = value_to_string sym in + let field_names = List.map value_to_string fields in + let arity = List.length fields in + env_bind_v cn + (NativeFn (cn, fun ctor_args -> + if List.length ctor_args <> arity then + raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d" + cn arity (List.length ctor_args))) + else begin + let d = Hashtbl.create 4 in + Hashtbl.replace d "_adt" (Bool true); + Hashtbl.replace d "_type" (String type_name); + Hashtbl.replace d "_ctor" (String cn); + Hashtbl.replace d "_fields" (List ctor_args); + Dict d + end)); + env_bind_v (cn ^ "?") + (NativeFn (cn ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iteri (fun idx fname -> + env_bind_v (cn ^ "-" ^ fname) + (NativeFn (cn ^ "-" ^ fname, fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> + (match Hashtbl.find_opt d "_fields" with + | Some (List fs) -> + if idx < List.length fs then List.nth fs idx + else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds")) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg"))))) + ) field_names + | _ -> ()) + ) ctor_specs; + Nil + +(* Register define-type via custom_special_forms so the CEK dispatch finds it. + The top-level (register-special-form! ...) in spec/evaluator.sx is not a + define and therefore is not transpiled; we wire it up here instead. *) +let () = ignore (register_special_form (String "define-type") + (NativeFn ("define-type", fun call_args -> + match call_args with + | [args; env] -> sf_define_type args env + | _ -> Nil))) """ @@ -171,7 +257,10 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str: "debug-log", "debug_log", "range", "chunk-every", "zip-pairs", "string-contains?", "starts-with?", "ends-with?", "string-replace", "trim", "split", "index-of", - "pad-left", "pad-right", "char-at", "substring"} + "pad-left", "pad-right", "char-at", "substring", + # sf-define-type uses &rest + empty-dict literals that the transpiler + # can't emit as valid OCaml; hand-written implementation in FIXUPS. + "sf-define-type"} defines = [(n, e) for n, e in defines if n not in skip] # Deduplicate — keep last definition for each name (CEK overrides tree-walk) diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index db75479f..c22a1208 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -198,7 +198,7 @@ and make_or_frame remaining env = (* make-dynamic-wind-frame *) and make_dynamic_wind_frame phase body_thunk after_thunk env = - (CekFrame { cf_type = "dynamic-wind"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = phase; cf_extra2 = Nil }) + (CekFrame { cf_type = "dynamic-wind"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = after_thunk; cf_args = Nil; cf_results = Nil; cf_extra = phase; cf_extra2 = Nil }) (* make-reactive-reset-frame *) and make_reactive_reset_frame env update_fn first_render_p = @@ -742,11 +742,11 @@ and match_find_clause val' clauses env = (* match-pattern *) and match_pattern pattern value env = - (if sx_truthy ((prim_call "=" [pattern; (Symbol "_")])) then (Bool true) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (pattern)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "?")])))) then (let pred = (eval_expr ((nth (pattern) ((Number 1.0)))) (env)) in (cek_call (pred) ((List [value])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "quote")])))) then (prim_call "=" [value; (nth (pattern) ((Number 1.0)))]) else (if sx_truthy ((symbol_p (pattern))) then (let () = ignore ((env_bind env (sx_to_string (symbol_name (pattern))) value)) in (Bool true)) else (if sx_truthy ((let _and = (dict_p (pattern)) in if not (sx_truthy _and) then _and else (dict_p (value)))) then (Bool (List.for_all (fun k -> sx_truthy ((match_pattern ((get (pattern) (k))) ((get (value) (k))) (env)))) (sx_to_list (prim_call "keys" [pattern])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (list_p (value)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [pattern; (Symbol "&rest")])))) then (let rest_idx = (prim_call "index-of" [pattern; (Symbol "&rest")]) in (let _and = (prim_call ">=" [(len (value)); rest_idx]) in if not (sx_truthy _and) then _and else (let _and = (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [(prim_call "slice" [pattern; (Number 0.0); rest_idx]); (prim_call "slice" [value; (Number 0.0); rest_idx])])))) in if not (sx_truthy _and) then _and else (let rest_name = (nth (pattern) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (rest_name))) (prim_call "slice" [value; rest_idx]))) in (Bool true)))))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (value)))) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(len (pattern)); (len (value))])))))) then (Bool false) else (let pairs = (prim_call "zip" [pattern; value]) in (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list pairs))))) else (prim_call "=" [pattern; value])))))))) + (if sx_truthy ((prim_call "=" [pattern; (Symbol "_")])) then (Bool true) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (pattern)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "?")])))) then (let pred = (eval_expr ((nth (pattern) ((Number 1.0)))) (env)) in (cek_call (pred) ((List [value])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "quote")])))) then (prim_call "=" [value; (nth (pattern) ((Number 1.0)))]) else (if sx_truthy ((symbol_p (pattern))) then (let () = ignore ((env_bind env (sx_to_string (symbol_name (pattern))) value)) in (Bool true)) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((first (pattern)))) in if not (sx_truthy _and) then _and else (let _and = (dict_p (value)) in if not (sx_truthy _and) then _and else (get (value) ((String "_adt")))))))) then (let ctor_name = (symbol_name ((first (pattern)))) in let field_patterns = (rest (pattern)) in let fields = (get (value) ((String "_fields"))) in (let _and = (prim_call "=" [(get (value) ((String "_ctor"))); ctor_name]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (field_patterns)); (len (fields))]) in if not (sx_truthy _and) then _and else (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [field_patterns; fields]))))))) else (if sx_truthy ((let _and = (dict_p (pattern)) in if not (sx_truthy _and) then _and else (dict_p (value)))) then (Bool (List.for_all (fun k -> sx_truthy ((match_pattern ((get (pattern) (k))) ((get (value) (k))) (env)))) (sx_to_list (prim_call "keys" [pattern])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (list_p (value)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [pattern; (Symbol "&rest")])))) then (let rest_idx = (prim_call "index-of" [pattern; (Symbol "&rest")]) in (let _and = (prim_call ">=" [(len (value)); rest_idx]) in if not (sx_truthy _and) then _and else (let _and = (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [(prim_call "slice" [pattern; (Number 0.0); rest_idx]); (prim_call "slice" [value; (Number 0.0); rest_idx])])))) in if not (sx_truthy _and) then _and else (let rest_name = (nth (pattern) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (rest_name))) (prim_call "slice" [value; rest_idx]))) in (Bool true)))))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (value)))) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(len (pattern)); (len (value))])))))) then (Bool false) else (let pairs = (prim_call "zip" [pattern; value]) in (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list pairs))))) else (prim_call "=" [pattern; value]))))))))) (* step-sf-match *) and step_sf_match args env kont = - (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (raise (Eval_error (value_to_str (String (sx_str [(String "match: no clause matched "); (inspect (val'))]))))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))) + (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))) (* step-sf-handler-bind *) and step_sf_handler_bind args env kont = @@ -932,6 +932,10 @@ and eval_expr_cek expr env = and trampoline_cek val' = (if sx_truthy ((is_thunk (val'))) then (eval_expr_cek ((thunk_expr (val'))) ((thunk_env (val')))) else val') +(* make-coroutine *) +and make_coroutine thunk = + (CekFrame { cf_type = "coroutine"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + (* eval-expr *) and eval_expr expr env = (cek_run ((make_cek_state (expr) (env) ((List []))))) @@ -1004,5 +1008,89 @@ let enhance_error_with_trace msg = _last_error_kont_ref := Nil; msg ^ (format_comp_trace trace) +(* Hand-written sf_define_type — skipped from transpile because the spec uses + &rest params and empty-dict literals that the transpiler can't emit cleanly. + Implements: (define-type Name (Ctor1 f1 f2) (Ctor2 f3) ...) + Creates constructor fns, Name?/Ctor? predicates, Ctor-field accessors, + and records ctors in *adt-registry*. *) +let sf_define_type args env_val = + let items = (match args with List l -> l | _ -> []) in + let type_sym = List.nth items 0 in + let type_name = value_to_string type_sym in + let ctor_specs = List.tl items in + let env_has_v k = sx_truthy (env_has env_val (String k)) in + let env_bind_v k v = ignore (env_bind env_val (String k) v) in + let env_get_v k = env_get env_val (String k) in + if not (env_has_v "*adt-registry*") then + env_bind_v "*adt-registry*" (Dict (Hashtbl.create 8)); + let registry = env_get_v "*adt-registry*" in + let ctor_names = List.map (fun spec -> + (match spec with List (sym :: _) -> String (value_to_string sym) | _ -> Nil) + ) ctor_specs in + (match registry with Dict d -> Hashtbl.replace d type_name (List ctor_names) | _ -> ()); + env_bind_v (type_name ^ "?") + (NativeFn (type_name ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iter (fun spec -> + (match spec with + | List (sym :: fields) -> + let cn = value_to_string sym in + let field_names = List.map value_to_string fields in + let arity = List.length fields in + env_bind_v cn + (NativeFn (cn, fun ctor_args -> + if List.length ctor_args <> arity then + raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d" + cn arity (List.length ctor_args))) + else begin + let d = Hashtbl.create 4 in + Hashtbl.replace d "_adt" (Bool true); + Hashtbl.replace d "_type" (String type_name); + Hashtbl.replace d "_ctor" (String cn); + Hashtbl.replace d "_fields" (List ctor_args); + Dict d + end)); + env_bind_v (cn ^ "?") + (NativeFn (cn ^ "?", fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> Bool (Hashtbl.mem d "_adt" && + (match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false)) + | _ -> Bool false) + | _ -> Bool false))); + List.iteri (fun idx fname -> + env_bind_v (cn ^ "-" ^ fname) + (NativeFn (cn ^ "-" ^ fname, fun pargs -> + (match pargs with + | [v] -> + (match v with + | Dict d -> + (match Hashtbl.find_opt d "_fields" with + | Some (List fs) -> + if idx < List.length fs then List.nth fs idx + else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds")) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict"))) + | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg"))))) + ) field_names + | _ -> ()) + ) ctor_specs; + Nil + +(* Register define-type via custom_special_forms so the CEK dispatch finds it. + The top-level (register-special-form! ...) in spec/evaluator.sx is not a + define and therefore is not transpiled; we wire it up here instead. *) +let () = ignore (register_special_form (String "define-type") + (NativeFn ("define-type", fun call_args -> + match call_args with + | [args; env] -> sf_define_type args env + | _ -> Nil)))