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

Complete Python eval removal: epoch protocol, scope consolidation, JIT fixes

Browse Source 
Route all rendering through OCaml bridge — render_to_html no longer uses
Python async_eval. Fix register_components to parse &key params and &rest
children from defcomp forms. Remove all dead sx_ref.py imports.

Epoch protocol (prevents pipe desync):
- Every command prefixed with (epoch N), all responses tagged with epoch
- Both sides discard stale-epoch messages — desync structurally impossible
- OCaml main loop discards stale io-responses between commands

Consolidate scope primitives into sx_scope.ml:
- Single source of truth for scope-push!/pop!/peek, collect!/collected,
  emit!/emitted, context, and 12 other scope operations
- Removes duplicate registrations from sx_server.ml (including bugs where
  scope-emit! and clear-collected! were registered twice with different impls)
- Bind scope prims into env so JIT VM finds them via OP_GLOBAL_GET

JIT VM fixes:
- Trampoline thunks before passing args to CALL_PRIM
- as_list resolves thunks via _sx_trampoline_fn
- len handles all value types (Bool, Number, RawHTML, SxExpr, Spread, etc.)

Other fixes:
- ~cssx/tw signature: (tokens) → (&key tokens) to match callers
- Minimal Python evaluator in html.py for sync sx() Jinja function
- Python scope primitive stubs (thread-local) for non-OCaml paths
- Reader macro resolution via OcamlSync instead of sx_ref.py

Tests: 1114 OCaml, 1078 JS, 35 Python regression, 6/6 Playwright SSR

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-24 16:14:40 +00:00
parent e887c0d978
commit f9f810ffd7
18 changed files with 1305 additions and 478 deletions
Download Patch File Download Diff File Expand all files Collapse all files

372
hosts/ocaml/bin/sx_server.ml
View File

@@ -61,21 +61,26 @@ let rec serialize_value = function
| RawHTML s -> "\"" ^ escape_sx_string s ^ "\""
| _ -> "nil"
(** Request epoch — monotonically increasing, set by (epoch N) from Python.
All responses are tagged with the current epoch so Python can discard
stale messages from previous requests. Makes pipe desync impossible. *)
let current_epoch = ref 0
let send line =
print_string line;
print_char '\n';
flush stdout
let send_ok () = send "(ok)"
let send_ok_value v = send (Printf.sprintf "(ok %s)" (serialize_value v))
let send_error msg = send (Printf.sprintf "(error \"%s\")" (escape_sx_string msg))
let send_ok () = send (Printf.sprintf "(ok %d)" !current_epoch)
let send_ok_value v = send (Printf.sprintf "(ok %d %s)" !current_epoch (serialize_value v))
let send_error msg = send (Printf.sprintf "(error %d \"%s\")" !current_epoch (escape_sx_string msg))
(** Length-prefixed binary send — handles any content without escaping.
Sends: (ok-len N)\n followed by exactly N bytes of raw data, then \n.
Sends: (ok-len EPOCH N)\n followed by exactly N bytes of raw data, then \n.
Python reads the length line, then reads exactly N bytes. *)
let send_ok_blob s =
let n = String.length s in
Printf.printf "(ok-len %d)\n" n;
Printf.printf "(ok-len %d %d)\n" !current_epoch n;
print_string s;
print_char '\n';
flush stdout
@@ -125,171 +130,11 @@ let io_batch_mode = ref false
let io_queue : (int * string * value list) list ref = ref []
let io_counter = ref 0
(* Request cookies — set by Python bridge before each page render.
get-cookie reads from here on the server; set-cookie is a no-op
(server can't set response cookies from SX — that's the framework's job). *)
let _request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
let () = Sx_primitives.register "get-cookie" (fun args ->
match args with
| [String name] ->
(match Hashtbl.find_opt _request_cookies name with
| Some v -> String v
| None -> Nil)
| _ -> Nil)
let () = Sx_primitives.register "set-cookie" (fun _args ->
(* No-op on server — cookies are set via HTTP response headers *)
Nil)
(* Module-level scope stacks — shared between make_server_env (aser
scope-push!/pop!) and step-sf-context (via get-primitive "scope-peek"). *)
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
let () = Sx_primitives.register "scope-push!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
Hashtbl.replace _scope_stacks name (value :: stack); Nil
| _ -> Nil)
let () = Sx_primitives.register "scope-pop!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
| _ -> Nil)
let () = Sx_primitives.register "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil)
let () = Sx_primitives.register "context" (fun args ->
match args with
| [String name] | [String name; _] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack, args with
| v :: _, _ -> v
| [], [_; default_val] -> default_val
| [], _ -> Nil)
| _ -> Nil)
(** collect! — lazy scope accumulator. Creates root scope if missing,
emits value (deduplicates). Used by cssx and spread components. *)
let () = Sx_primitives.register "collect!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
if not (List.mem value items) then
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
| [] ->
(* Lazy root scope — create with the value *)
Hashtbl.replace _scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil)
let () = Sx_primitives.register "collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List [])
let () = Sx_primitives.register "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace _scope_stacks name (List [] :: rest)
| [] -> Hashtbl.replace _scope_stacks name [List []]);
Nil
| _ -> Nil)
(* emit!/emitted — adapter-html.sx uses these for spread attr collection *)
let () = Sx_primitives.register "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
| v :: rest ->
(* Non-list top — wrap current entries as list + new value *)
Hashtbl.replace _scope_stacks name (List [value] :: v :: rest)
| [] ->
Hashtbl.replace _scope_stacks name [List [value]]);
Nil
| _ -> Nil)
let () = Sx_primitives.register "emitted" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List [])
let () = Sx_primitives.register "scope-emitted" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List [])
let () = Sx_primitives.register "scope-collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List [])
let () = Sx_primitives.register "scope-clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace _scope_stacks name (List [] :: rest)
| [] -> Hashtbl.replace _scope_stacks name [List []]);
Nil
| _ -> Nil)
let () = Sx_primitives.register "provide-push!" (fun args ->
match Sx_primitives.get_primitive "scope-push!" with
| NativeFn (_, fn) -> fn args | _ -> Nil)
let () = Sx_primitives.register "provide-pop!" (fun args ->
match Sx_primitives.get_primitive "scope-pop!" with
| NativeFn (_, fn) -> fn args | _ -> Nil)
let () = Sx_primitives.register "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
| Nil :: rest ->
Hashtbl.replace _scope_stacks name (List [value] :: rest)
| [] ->
(* Lazy root scope *)
Hashtbl.replace _scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil)
let () = Sx_primitives.register "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace _scope_stacks name (List [] :: rest)
| [] -> ());
Nil
| _ -> Nil)
(* Scope stacks and cookies — all primitives registered in sx_scope.ml.
We just reference the shared state for the IO bridge. *)
module Sx_scope = Sx.Sx_scope
let _request_cookies = Sx_scope.request_cookies
let _scope_stacks = Sx_scope.scope_stacks
(** Helpers safe to defer — pure functions whose results are only used
as rendering output (inlined into SX wire format), not in control flow. *)
@@ -303,6 +148,29 @@ let is_batchable name args =
| String h :: _ -> List.mem h batchable_helpers
| _ -> false
(** Read an io-response from stdin, discarding stale messages from old epochs. *)
let rec read_io_response () =
match read_line_blocking () with
| None -> raise (Eval_error "IO bridge: stdin closed while waiting for io-response")
| Some line ->
let exprs = Sx_parser.parse_all line in
match exprs with
(* Epoch-tagged: (io-response EPOCH value) *)
| [List [Symbol "io-response"; Number n; value]]
when int_of_float n = !current_epoch -> value
| [List (Symbol "io-response" :: Number n :: values)]
when int_of_float n = !current_epoch ->
(match values with [v] -> v | _ -> List values)
(* Legacy untagged: (io-response value) — accept for backwards compat *)
| [List [Symbol "io-response"; value]] -> value
| [List (Symbol "io-response" :: values)] ->
(match values with [v] -> v | _ -> List values)
(* Stale epoch or unexpected — discard and retry *)
| _ ->
Printf.eprintf "[io] discarding stale message (%d chars, epoch=%d)\n%!"
(String.length line) !current_epoch;
read_io_response ()
(** Send an io-request — batch mode returns placeholder, else blocks. *)
let io_request name args =
if !io_batch_mode && is_batchable name args then begin
@@ -313,20 +181,36 @@ let io_request name args =
SxExpr (Printf.sprintf "(\xc2\xabIO:%d\xc2\xbb)" id)
end else begin
let args_str = String.concat " " (List.map serialize_value args) in
send (Printf.sprintf "(io-request \"%s\" %s)" name args_str);
(* Block on stdin for io-response *)
send (Printf.sprintf "(io-request %d \"%s\" %s)" !current_epoch name args_str);
read_io_response ()
end
(** Read a batched io-response, discarding stale epoch messages. *)
let read_batched_io_response () =
let rec loop () =
match read_line_blocking () with
| None -> raise (Eval_error "IO bridge: stdin closed while waiting for io-response")
| None -> raise (Eval_error "IO batch: stdin closed")
| Some line ->
let exprs = Sx_parser.parse_all line in
match exprs with
| [List [Symbol "io-response"; value]] -> value
| [List (Symbol "io-response" :: values)] ->
(match values with
| [v] -> v
| _ -> List values)
| _ -> raise (Eval_error ("IO bridge: unexpected response: " ^ line))
end
(* Epoch-tagged: (io-response EPOCH value) *)
| [List [Symbol "io-response"; Number n; String s]]
when int_of_float n = !current_epoch -> s
| [List [Symbol "io-response"; Number n; SxExpr s]]
when int_of_float n = !current_epoch -> s
| [List [Symbol "io-response"; Number n; v]]
when int_of_float n = !current_epoch -> serialize_value v
(* Legacy untagged *)
| [List [Symbol "io-response"; String s]]
| [List [Symbol "io-response"; SxExpr s]] -> s
| [List [Symbol "io-response"; v]] -> serialize_value v
(* Stale — discard and retry *)
| _ ->
Printf.eprintf "[io-batch] discarding stale message (%d chars)\n%!"
(String.length line);
loop ()
in
loop ()
(** Flush batched IO: send all requests, read all responses, replace placeholders. *)
let flush_batched_io result_str =
@@ -335,44 +219,35 @@ let flush_batched_io result_str =
io_counter := 0;
if queue = [] then result_str
else begin
(* Send all batched requests with IDs *)
(* Send all batched requests with IDs, tagged with epoch *)
List.iter (fun (id, name, args) ->
let args_str = String.concat " " (List.map serialize_value args) in
send (Printf.sprintf "(io-request %d \"%s\" %s)" id name args_str)
send (Printf.sprintf "(io-request %d %d \"%s\" %s)" !current_epoch id name args_str)
) queue;
send (Printf.sprintf "(io-done %d)" (List.length queue));
send (Printf.sprintf "(io-done %d %d)" !current_epoch (List.length queue));
(* Read all responses and replace placeholders *)
let final = ref result_str in
List.iter (fun (id, _, _) ->
match read_line_blocking () with
| Some line ->
let exprs = Sx_parser.parse_all line in
let value_str = match exprs with
| [List [Symbol "io-response"; String s]]
| [List [Symbol "io-response"; SxExpr s]] -> s
| [List [Symbol "io-response"; v]] -> serialize_value v
| _ -> "nil"
in
let placeholder = Printf.sprintf "(\xc2\xabIO:%d\xc2\xbb)" id in
(* Replace all occurrences of this placeholder *)
let plen = String.length placeholder in
let buf = Buffer.create (String.length !final) in
let pos = ref 0 in
let s = !final in
let slen = String.length s in
while !pos <= slen - plen do
if String.sub s !pos plen = placeholder then begin
Buffer.add_string buf value_str;
pos := !pos + plen
end else begin
Buffer.add_char buf s.[!pos];
incr pos
end
done;
if !pos < slen then
Buffer.add_substring buf s !pos (slen - !pos);
final := Buffer.contents buf
| None -> raise (Eval_error "IO batch: stdin closed")
let value_str = read_batched_io_response () in
let placeholder = Printf.sprintf "(\xc2\xabIO:%d\xc2\xbb)" id in
(* Replace all occurrences of this placeholder *)
let plen = String.length placeholder in
let buf = Buffer.create (String.length !final) in
let pos = ref 0 in
let s = !final in
let slen = String.length s in
while !pos <= slen - plen do
if String.sub s !pos plen = placeholder then begin
Buffer.add_string buf value_str;
pos := !pos + plen
end else begin
Buffer.add_char buf s.[!pos];
incr pos
end
done;
if !pos < slen then
Buffer.add_substring buf s !pos (slen - !pos);
final := Buffer.contents buf
) queue;
!final
end
@@ -519,56 +394,21 @@ let make_server_env () =
(* Scope stack — platform primitives for render-time dynamic scope.
Used by aser for spread/provide/emit patterns.
Module-level so step-sf-context can check it via get-primitive. *)
let scope_stacks = _scope_stacks in
bind "scope-push!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
Hashtbl.replace scope_stacks name (value :: stack); Nil
| _ -> Nil);
bind "scope-pop!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace scope_stacks name rest
| [] -> ()); Nil
| _ -> Nil);
bind "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil);
(* scope-emit! / scope-peek — Hashtbl-based scope primitives for aser.
Different names from emit!/emitted to avoid CEK special form conflict. *)
bind "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
| Nil :: rest ->
Hashtbl.replace scope_stacks name (List [value] :: rest)
| _ :: _ -> ()
| [] -> ()); Nil
| _ -> Nil);
(* context — scope lookup. The CEK handles this as a special form
by walking continuation frames, but compiled VM code needs it as
a function that reads from the scope_stacks hashtable. *)
let context_impl = NativeFn ("context", fun args ->
match args with
| [String name] | [String name; _] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack, args with
| v :: _, _ -> v
| [], [_; default_val] -> default_val
| [], _ -> Nil)
| _ -> Nil) in
ignore (env_bind env "sx-context" context_impl);
ignore (env_bind env "context" context_impl);
(* Scope primitives are registered globally in sx_scope.ml.
Bind them into the env so the JIT VM can find them via vm.globals
(OP_GLOBAL_GET checks env.bindings before the primitives table). *)
List.iter (fun name ->
try ignore (env_bind env name (Sx_primitives.get_primitive name))
with _ -> ()
) ["scope-push!"; "scope-pop!"; "scope-peek"; "context";
"collect!"; "collected"; "clear-collected!";
"scope-emit!"; "emit!"; "emitted"; "scope-emitted";
"scope-collected"; "scope-clear-collected!";
"provide-push!"; "provide-pop!";
"get-cookie"; "set-cookie"];
(* sx-context is an env alias for context *)
let context_prim = Sx_primitives.get_primitive "context" in
ignore (env_bind env "sx-context" context_prim);
(* qq-expand-runtime — quasiquote expansion at runtime.
The bytecode compiler emits CALL_PRIM "qq-expand-runtime" for
@@ -1667,9 +1507,17 @@ let () =
| Some line ->
let line = String.trim line in
if line = "" then () (* skip blank lines *)
(* Discard stale io-responses from previous requests. *)
else if String.length line > 14
&& String.sub line 0 14 = "(io-response " then
Printf.eprintf "[sx-server] discarding stale io-response (%d chars)\n%!"
(String.length line)
else begin
let exprs = Sx_parser.parse_all line in
match exprs with
(* Epoch marker: (epoch N) — set current epoch, read next command *)
| [List [Symbol "epoch"; Number n]] ->
current_epoch := int_of_float n
| [cmd] -> dispatch env cmd
| _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs))
end

15
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -36,10 +36,11 @@ let as_string = function
| String s -> s
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
let as_list = function
let rec as_list = function
| List l -> l
| ListRef r -> !r
| Nil -> []
| Thunk _ as t -> as_list (!_sx_trampoline_fn t)
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
let as_bool = function
@@ -316,8 +317,16 @@ let () =
| [List l] | [ListRef { contents = l }] -> Number (float_of_int (List.length l))
| [String s] -> Number (float_of_int (String.length s))
| [Dict d] -> Number (float_of_int (Hashtbl.length d))
| [Nil] -> Number 0.0
| _ -> raise (Eval_error "len: 1 arg"));
| [Nil] | [Bool false] -> Number 0.0
| [Bool true] -> Number 1.0
| [Number _] -> Number 1.0
| [RawHTML s] -> Number (float_of_int (String.length s))
| [SxExpr s] -> Number (float_of_int (String.length s))
| [Spread pairs] -> Number (float_of_int (List.length pairs))
| [Component _] | [Island _] | [Lambda _] | [NativeFn _]
| [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Number 0.0
| _ -> raise (Eval_error (Printf.sprintf "len: %d args"
(List.length args))));
register "first" (fun args ->
match args with
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x

154
hosts/ocaml/lib/sx_scope.ml Normal file
View File

@@ -0,0 +1,154 @@
(** Scope stacks — dynamic scope for render-time effects.
Provides scope-push!/pop!/peek, collect!/collected/clear-collected!,
scope-emit!/emitted/scope-emitted, context, and cookie access.
All functions are registered as primitives so both the CEK evaluator
and the JIT VM can find them in the same place. *)
open Sx_types
(** The shared scope stacks hashtable. Each key maps to a stack of values.
Used by aser for spread/provide/emit patterns, CSSX collect/flush, etc. *)
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
(** Request cookies — set by the Python bridge before each render.
get-cookie reads from here; set-cookie is a no-op on the server. *)
let request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
(** Clear all scope stacks. Called between requests if needed. *)
let clear_all () = Hashtbl.clear scope_stacks
let () =
let register = Sx_primitives.register in
(* --- Cookies --- *)
register "get-cookie" (fun args ->
match args with
| [String name] ->
(match Hashtbl.find_opt request_cookies name with
| Some v -> String v
| None -> Nil)
| _ -> Nil);
register "set-cookie" (fun _args -> Nil);
(* --- Core scope stack operations --- *)
register "scope-push!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
Hashtbl.replace scope_stacks name (value :: stack); Nil
| _ -> Nil);
register "scope-pop!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with _ :: rest -> Hashtbl.replace scope_stacks name rest | [] -> ()); Nil
| _ -> Nil);
register "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil);
(* --- Context (scope lookup with optional default) --- *)
register "context" (fun args ->
match args with
| [String name] | [String name; _] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack, args with
| v :: _, _ -> v
| [], [_; default_val] -> default_val
| [], _ -> Nil)
| _ -> Nil);
(* --- Collect / collected / clear-collected! --- *)
register "collect!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
if not (List.mem value items) then
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
| [] ->
Hashtbl.replace scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace scope_stacks name (List [] :: rest)
| [] -> Hashtbl.replace scope_stacks name [List []]);
Nil
| _ -> Nil);
(* --- Emit / emitted (for spread attrs in adapter-html.sx) --- *)
register "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
| Nil :: rest ->
Hashtbl.replace scope_stacks name (List [value] :: rest)
| [] ->
Hashtbl.replace scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "emit!" (fun args ->
(* Alias for scope-emit! *)
match Sx_primitives.get_primitive "scope-emit!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
register "emitted" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "scope-emitted" (fun args ->
match Sx_primitives.get_primitive "emitted" with
| NativeFn (_, fn) -> fn args | _ -> List []);
register "scope-collected" (fun args ->
match Sx_primitives.get_primitive "collected" with
| NativeFn (_, fn) -> fn args | _ -> List []);
register "scope-clear-collected!" (fun args ->
match Sx_primitives.get_primitive "clear-collected!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
(* --- Provide aliases --- *)
register "provide-push!" (fun args ->
match Sx_primitives.get_primitive "scope-push!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
register "provide-pop!" (fun args ->
match Sx_primitives.get_primitive "scope-pop!" with
| NativeFn (_, fn) -> fn args | _ -> Nil)

7
hosts/ocaml/lib/sx_vm.ml
View File

@@ -345,6 +345,13 @@ and run vm =
let argc = read_u8 frame in
let name = match consts.(idx) with String s -> s | _ -> "" in
let args = List.init argc (fun _ -> pop vm) |> List.rev in
(* Resolve thunks — the CEK evaluator does this automatically
via trampoline, but the VM must do it explicitly before
passing args to primitives. *)
let args = List.map (fun v ->
match v with
| Thunk _ -> !Sx_primitives._sx_trampoline_fn v
| _ -> v) args in
let result =
try
(* Check primitives FIRST (native implementations of map/filter/etc.),