VM upvalues + HO primitives + 40 tests (36 pass, 4 fail)
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -7,6 +7,12 @@ open Sx_types
|
||||
|
||||
let primitives : (string, value list -> value) Hashtbl.t = Hashtbl.create 128
|
||||
|
||||
(** Forward refs for calling SX functions from primitives (breaks cycle). *)
|
||||
let _sx_call_fn : (value -> value list -> value) ref =
|
||||
ref (fun _ _ -> raise (Eval_error "sx_call not initialized"))
|
||||
let _sx_trampoline_fn : (value -> value) ref =
|
||||
ref (fun v -> v)
|
||||
|
||||
let register name fn = Hashtbl.replace primitives name fn
|
||||
|
||||
let is_primitive name = Hashtbl.mem primitives name
|
||||
@@ -590,4 +596,34 @@ let () =
|
||||
List.iter (fun (k, v) -> dict_set d k v) pairs;
|
||||
Dict d
|
||||
| _ -> raise (Eval_error "spread-attrs: 1 spread"));
|
||||
|
||||
(* Higher-order forms as callable primitives — used by the VM.
|
||||
The CEK machine handles these as special forms with dedicated frames;
|
||||
the VM needs them as plain callable values. *)
|
||||
(* Call any SX callable — handles NativeFn, Lambda (via trampoline), VM closures *)
|
||||
let call_any f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| _ -> !_sx_trampoline_fn (!_sx_call_fn f args)
|
||||
in
|
||||
register "map" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.map (fun x -> call_any f [x]) items)
|
||||
| _ -> raise (Eval_error "map: expected (fn list)"));
|
||||
register "filter" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.filter (fun x -> sx_truthy (call_any f [x])) items)
|
||||
| _ -> raise (Eval_error "filter: expected (fn list)"));
|
||||
register "for-each" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List.iter (fun x -> ignore (call_any f [x])) items; Nil
|
||||
| _ -> raise (Eval_error "for-each: expected (fn list)"));
|
||||
register "reduce" (fun args ->
|
||||
match args with
|
||||
| [f; init; (List items | ListRef { contents = items })] ->
|
||||
List.fold_left (fun acc x -> call_any f [acc; x]) init items
|
||||
| _ -> raise (Eval_error "reduce: expected (fn init list)"));
|
||||
()
|
||||
|
||||
@@ -23,14 +23,12 @@ let _prim_param_types_ref = ref Nil
|
||||
(* === Transpiled from evaluator (frames + eval + CEK) === *)
|
||||
|
||||
(* make-cek-state *)
|
||||
let _cek_steps = ref 0
|
||||
|
||||
let rec make_cek_state control env kont =
|
||||
(incr _cek_steps; CekState { cs_control = control; cs_env = env; cs_kont = kont; cs_phase = "eval"; cs_value = Nil })
|
||||
(CekState { cs_control = control; cs_env = env; cs_kont = kont; cs_phase = "eval"; cs_value = Nil })
|
||||
|
||||
(* make-cek-value *)
|
||||
and make_cek_value value env kont =
|
||||
(incr _cek_steps; CekState { cs_control = Nil; cs_env = env; cs_kont = kont; cs_phase = "continue"; cs_value = value })
|
||||
(CekState { cs_control = Nil; cs_env = env; cs_kont = kont; cs_phase = "continue"; cs_value = value })
|
||||
|
||||
(* cek-terminal? *)
|
||||
and cek_terminal_p state =
|
||||
|
||||
@@ -46,12 +46,15 @@ let sx_call f args =
|
||||
| Lambda l ->
|
||||
let local = Sx_types.env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
|
||||
(* Return the body + env for the trampoline to evaluate *)
|
||||
Thunk (l.l_body, local)
|
||||
| Continuation (k, _) ->
|
||||
k (match args with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error ("Not callable: " ^ inspect f))
|
||||
|
||||
(* Initialize forward ref so primitives can call SX functions *)
|
||||
let () = Sx_primitives._sx_call_fn := sx_call
|
||||
(* Trampoline ref is set by sx_ref.ml after it's loaded *)
|
||||
|
||||
(** Apply a function to a list of args. *)
|
||||
let sx_apply f args_list =
|
||||
sx_call f (sx_to_list args_list)
|
||||
|
||||
Reference in New Issue
Block a user