giles
7b4c918773
All 26 browser modules recompiled with define-library/import forms. Compilation works without vm-compile-adapter (JIT pre-compilation hangs with library wrappers in some JIT paths — skipped for now, CEK compilation is ~34s total). Key fixes: - eval command: import-aware loop that handles define-library/import locally without touching the Python bridge pipe (avoids deadlock) - compile-modules.js: skip vm-compile-adapter, bump timeout 2621/2621 OCaml tests passing. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1193 lines
49 KiB
OCaml
1193 lines
49 KiB
OCaml
(** Built-in primitive functions (~80 pure functions).
|
|
|
|
Registered in a global table; the evaluator checks this table
|
|
when a symbol isn't found in the lexical environment. *)
|
|
|
|
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 _is_client : bool ref = ref false
|
|
|
|
(** Scope stacks — dynamic scope for render-time effects.
|
|
Each key maps to a stack of values. Used by aser for
|
|
spread/provide/emit patterns, CSSX collect/flush, etc.
|
|
Migrated from sx_scope.ml. *)
|
|
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
|
|
|
|
(** Debug trace for scope operations *)
|
|
let _scope_trace = ref false
|
|
let _scope_log : string list ref = ref []
|
|
let scope_trace_enable () = _scope_trace := true; _scope_log := []
|
|
let scope_trace_disable () = _scope_trace := false
|
|
let scope_trace_drain () =
|
|
let log = List.rev !_scope_log in
|
|
_scope_log := [];
|
|
log
|
|
|
|
(** 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 scope_clear_all () = Hashtbl.clear _scope_stacks
|
|
|
|
let register name fn = Hashtbl.replace primitives name fn
|
|
|
|
let is_primitive name = Hashtbl.mem primitives name
|
|
|
|
let get_primitive name =
|
|
match Hashtbl.find_opt primitives name with
|
|
| Some fn -> NativeFn (name, fn)
|
|
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
|
|
|
(* --- Helpers --- *)
|
|
|
|
(* Trampoline hook — set by sx_ref after initialization to break circular dep *)
|
|
let trampoline_hook : (value -> value) ref = ref (fun v -> v)
|
|
|
|
let rec as_number = function
|
|
| Number n -> n
|
|
| Bool true -> 1.0
|
|
| Bool false -> 0.0
|
|
| Nil -> 0.0
|
|
| String s -> (match float_of_string_opt s with Some n -> n | None -> Float.nan)
|
|
| Thunk _ as t ->
|
|
(* Trampoline thunks — they shouldn't leak but sometimes do *)
|
|
as_number (!trampoline_hook t)
|
|
| v -> raise (Eval_error ("Expected number, got " ^ type_of v ^ ": " ^ (match v with Dict d -> (match Hashtbl.find_opt d "__signal" with Some _ -> "signal{value=" ^ (match Hashtbl.find_opt d "value" with Some v' -> value_to_string v' | None -> "?") ^ "}" | None -> "dict") | _ -> "")))
|
|
|
|
let as_string = function
|
|
| String s -> s
|
|
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
|
|
|
|
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
|
|
| Bool b -> b
|
|
| v -> sx_truthy v
|
|
|
|
let rec to_string = function
|
|
| String s -> s
|
|
| Number n ->
|
|
if Float.is_integer n then string_of_int (int_of_float n)
|
|
else Printf.sprintf "%g" n
|
|
| Bool true -> "true"
|
|
| Bool false -> "false"
|
|
| Nil -> ""
|
|
| Symbol s -> s
|
|
| Keyword k -> k
|
|
| Thunk _ as t -> to_string (!trampoline_hook t)
|
|
| SxExpr s -> s
|
|
| RawHTML s -> s
|
|
| v -> inspect v
|
|
|
|
let () =
|
|
(* === Arithmetic === *)
|
|
register "+" (fun args ->
|
|
Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args));
|
|
register "-" (fun args ->
|
|
match args with
|
|
| [] -> Number 0.0
|
|
| [a] -> Number (-. (as_number a))
|
|
| a :: rest -> Number (List.fold_left (fun acc x -> acc -. as_number x) (as_number a) rest));
|
|
register "*" (fun args ->
|
|
Number (List.fold_left (fun acc a -> acc *. as_number a) 1.0 args));
|
|
register "/" (fun args ->
|
|
match args with
|
|
| [a; b] -> Number (as_number a /. as_number b)
|
|
| _ -> raise (Eval_error "/: expected 2 args"));
|
|
register "mod" (fun args ->
|
|
match args with
|
|
| [a; b] -> Number (Float.rem (as_number a) (as_number b))
|
|
| _ -> raise (Eval_error "mod: expected 2 args"));
|
|
register "inc" (fun args ->
|
|
match args with [a] -> Number (as_number a +. 1.0) | _ -> raise (Eval_error "inc: 1 arg"));
|
|
register "dec" (fun args ->
|
|
match args with [a] -> Number (as_number a -. 1.0) | _ -> raise (Eval_error "dec: 1 arg"));
|
|
register "abs" (fun args ->
|
|
match args with [a] -> Number (Float.abs (as_number a)) | _ -> raise (Eval_error "abs: 1 arg"));
|
|
register "floor" (fun args ->
|
|
match args with [a] -> Number (floor (as_number a))
|
|
| _ -> raise (Eval_error "floor: 1 arg"));
|
|
register "ceil" (fun args ->
|
|
match args with [a] -> Number (ceil (as_number a))
|
|
| _ -> raise (Eval_error "ceil: 1 arg"));
|
|
register "round" (fun args ->
|
|
match args with
|
|
| [a] -> Number (Float.round (as_number a))
|
|
| [a; b] ->
|
|
let n = as_number a and places = int_of_float (as_number b) in
|
|
let factor = 10.0 ** float_of_int places in
|
|
Number (Float.round (n *. factor) /. factor)
|
|
| _ -> raise (Eval_error "round: 1-2 args"));
|
|
register "min" (fun args ->
|
|
match args with
|
|
| [] -> raise (Eval_error "min: at least 1 arg")
|
|
| _ -> Number (List.fold_left (fun acc a -> Float.min acc (as_number a)) Float.infinity args));
|
|
register "max" (fun args ->
|
|
match args with
|
|
| [] -> raise (Eval_error "max: at least 1 arg")
|
|
| _ -> Number (List.fold_left (fun acc a -> Float.max acc (as_number a)) Float.neg_infinity args));
|
|
register "sqrt" (fun args ->
|
|
match args with [a] -> Number (Float.sqrt (as_number a)) | _ -> raise (Eval_error "sqrt: 1 arg"));
|
|
register "pow" (fun args ->
|
|
match args with [a; b] -> Number (as_number a ** as_number b)
|
|
| _ -> raise (Eval_error "pow: 2 args"));
|
|
register "clamp" (fun args ->
|
|
match args with
|
|
| [x; lo; hi] ->
|
|
let x = as_number x and lo = as_number lo and hi = as_number hi in
|
|
Number (Float.max lo (Float.min hi x))
|
|
| _ -> raise (Eval_error "clamp: 3 args"));
|
|
register "parse-int" (fun args ->
|
|
let parse_leading_int s =
|
|
let len = String.length s in
|
|
let start = ref 0 in
|
|
let neg = len > 0 && s.[0] = '-' in
|
|
if neg then start := 1
|
|
else if len > 0 && s.[0] = '+' then start := 1;
|
|
let j = ref !start in
|
|
while !j < len && s.[!j] >= '0' && s.[!j] <= '9' do incr j done;
|
|
if !j > !start then
|
|
let n = int_of_string (String.sub s !start (!j - !start)) in
|
|
Some (if neg then -n else n)
|
|
else None
|
|
in
|
|
match args with
|
|
| [String s] -> (match parse_leading_int s with Some n -> Number (float_of_int n) | None -> Nil)
|
|
| [String s; default_val] ->
|
|
(match parse_leading_int s with Some n -> Number (float_of_int n) | None -> default_val)
|
|
| [Number n] | [Number n; _] -> Number (float_of_int (int_of_float n))
|
|
| [_; default_val] -> default_val
|
|
| _ -> Nil);
|
|
register "parse-float" (fun args ->
|
|
match args with
|
|
| [String s] -> (match float_of_string_opt s with Some n -> Number n | None -> Nil)
|
|
| [Number n] -> Number n
|
|
| _ -> Nil);
|
|
|
|
(* === Comparison === *)
|
|
(* Safe equality: physical equality for potentially-circular types
|
|
(Dict, Lambda, Component, Island, Signal, NativeFn),
|
|
structural equality for acyclic types (Number, String, Bool, etc.).
|
|
Lists are compared element-wise recursively with the same safety. *)
|
|
let rec safe_eq a b =
|
|
if a == b then true (* physical equality fast path *)
|
|
else match a, b with
|
|
| Number x, Number y -> x = y
|
|
| String x, String y -> x = y
|
|
| Bool x, Bool y -> x = y
|
|
| Nil, Nil -> true
|
|
| Symbol x, Symbol y -> x = y
|
|
| Keyword x, Keyword y -> x = y
|
|
| (List la | ListRef { contents = la }),
|
|
(List lb | ListRef { contents = lb }) ->
|
|
List.length la = List.length lb &&
|
|
List.for_all2 safe_eq la lb
|
|
(* Dict: check __host_handle for DOM node identity *)
|
|
| Dict a, Dict b ->
|
|
(match Hashtbl.find_opt a "__host_handle", Hashtbl.find_opt b "__host_handle" with
|
|
| Some (Number ha), Some (Number hb) -> ha = hb
|
|
| _ -> false)
|
|
(* Records: same type + structurally equal fields *)
|
|
| Record a, Record b ->
|
|
a.r_type.rt_uid = b.r_type.rt_uid &&
|
|
Array.length a.r_fields = Array.length b.r_fields &&
|
|
(let eq = ref true in
|
|
for i = 0 to Array.length a.r_fields - 1 do
|
|
if not (safe_eq a.r_fields.(i) b.r_fields.(i)) then eq := false
|
|
done; !eq)
|
|
(* Lambda/Component/Island/Signal/NativeFn: physical only *)
|
|
| _ -> false
|
|
in
|
|
register "=" (fun args ->
|
|
match args with
|
|
| [a; b] -> Bool (safe_eq a b)
|
|
| _ -> raise (Eval_error "=: 2 args"));
|
|
register "!=" (fun args ->
|
|
match args with
|
|
| [a; b] -> Bool (not (safe_eq a b))
|
|
| _ -> raise (Eval_error "!=: 2 args"));
|
|
register "<" (fun args ->
|
|
match args with
|
|
| [String a; String b] -> Bool (a < b)
|
|
| [a; b] -> Bool (as_number a < as_number b)
|
|
| _ -> raise (Eval_error "<: 2 args"));
|
|
register ">" (fun args ->
|
|
match args with
|
|
| [String a; String b] -> Bool (a > b)
|
|
| [a; b] -> Bool (as_number a > as_number b)
|
|
| _ -> raise (Eval_error ">: 2 args"));
|
|
register "<=" (fun args ->
|
|
match args with
|
|
| [String a; String b] -> Bool (a <= b)
|
|
| [a; b] -> Bool (as_number a <= as_number b)
|
|
| _ -> raise (Eval_error "<=: 2 args"));
|
|
register ">=" (fun args ->
|
|
match args with
|
|
| [String a; String b] -> Bool (a >= b)
|
|
| [a; b] -> Bool (as_number a >= as_number b)
|
|
| _ -> raise (Eval_error ">=: 2 args"));
|
|
|
|
(* === Logic === *)
|
|
register "not" (fun args ->
|
|
match args with [a] -> Bool (not (sx_truthy a)) | _ -> raise (Eval_error "not: 1 arg"));
|
|
|
|
(* === Predicates === *)
|
|
register "nil?" (fun args ->
|
|
match args with [a] -> Bool (is_nil a) | _ -> raise (Eval_error "nil?: 1 arg"));
|
|
register "number?" (fun args ->
|
|
match args with [Number _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "number?: 1 arg"));
|
|
register "integer?" (fun args ->
|
|
match args with [Number f] -> Bool (Float.is_integer f) | [_] -> Bool false | _ -> raise (Eval_error "integer?: 1 arg"));
|
|
register "string?" (fun args ->
|
|
match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg"));
|
|
register "boolean?" (fun args ->
|
|
match args with [Bool _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "boolean?: 1 arg"));
|
|
register "list?" (fun args ->
|
|
match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg"));
|
|
register "dict?" (fun args ->
|
|
match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
|
|
register "symbol?" (fun args ->
|
|
match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
|
|
register "keyword?" (fun args ->
|
|
match args with [Keyword _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "keyword?: 1 arg"));
|
|
register "empty?" (fun args ->
|
|
match args with
|
|
| [List []] | [ListRef { contents = [] }] -> Bool true
|
|
| [List _] | [ListRef _] -> Bool false
|
|
| [String ""] -> Bool true | [String _] -> Bool false
|
|
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
|
| [Nil] -> Bool true
|
|
| [_] -> Bool false
|
|
| _ -> raise (Eval_error "empty?: 1 arg"));
|
|
register "odd?" (fun args ->
|
|
match args with [a] -> Bool (int_of_float (as_number a) mod 2 <> 0) | _ -> raise (Eval_error "odd?: 1 arg"));
|
|
register "even?" (fun args ->
|
|
match args with [a] -> Bool (int_of_float (as_number a) mod 2 = 0) | _ -> raise (Eval_error "even?: 1 arg"));
|
|
register "zero?" (fun args ->
|
|
match args with [a] -> Bool (as_number a = 0.0) | _ -> raise (Eval_error "zero?: 1 arg"));
|
|
|
|
(* === Strings === *)
|
|
register "str" (fun args -> String (String.concat "" (List.map to_string args)));
|
|
register "upper" (fun args ->
|
|
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upper: 1 arg"));
|
|
register "upcase" (fun args ->
|
|
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upcase: 1 arg"));
|
|
register "lower" (fun args ->
|
|
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "lower: 1 arg"));
|
|
register "downcase" (fun args ->
|
|
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "downcase: 1 arg"));
|
|
register "trim" (fun args ->
|
|
match args with [a] -> String (String.trim (as_string a)) | _ -> raise (Eval_error "trim: 1 arg"));
|
|
register "string-length" (fun args ->
|
|
match args with [a] -> Number (float_of_int (String.length (as_string a)))
|
|
| _ -> raise (Eval_error "string-length: 1 arg"));
|
|
register "string-contains?" (fun args ->
|
|
match args with
|
|
| [String haystack; String needle] ->
|
|
let rec find i =
|
|
if i + String.length needle > String.length haystack then false
|
|
else if String.sub haystack i (String.length needle) = needle then true
|
|
else find (i + 1)
|
|
in Bool (find 0)
|
|
| _ -> raise (Eval_error "string-contains?: 2 string args"));
|
|
register "starts-with?" (fun args ->
|
|
match args with
|
|
| [String s; String prefix] ->
|
|
Bool (String.length s >= String.length prefix &&
|
|
String.sub s 0 (String.length prefix) = prefix)
|
|
| _ -> raise (Eval_error "starts-with?: 2 string args"));
|
|
register "ends-with?" (fun args ->
|
|
match args with
|
|
| [String s; String suffix] ->
|
|
let sl = String.length s and xl = String.length suffix in
|
|
Bool (sl >= xl && String.sub s (sl - xl) xl = suffix)
|
|
| _ -> raise (Eval_error "ends-with?: 2 string args"));
|
|
register "index-of" (fun args ->
|
|
match args with
|
|
| [String haystack; String needle] ->
|
|
let nl = String.length needle and hl = String.length haystack in
|
|
let rec find i =
|
|
if i + nl > hl then Number (-1.0)
|
|
else if String.sub haystack i nl = needle then Number (float_of_int i)
|
|
else find (i + 1)
|
|
in find 0
|
|
| [List items; target] | [ListRef { contents = items }; target] ->
|
|
let eq a b = match a, b with
|
|
| String x, String y -> x = y | Number x, Number y -> x = y
|
|
| Symbol x, Symbol y -> x = y | Keyword x, Keyword y -> x = y
|
|
| Bool x, Bool y -> x = y | Nil, Nil -> true | _ -> a == b in
|
|
let rec find i = function
|
|
| [] -> Nil
|
|
| h :: _ when eq h target -> Number (float_of_int i)
|
|
| _ :: tl -> find (i + 1) tl
|
|
in find 0 items
|
|
| _ -> raise (Eval_error "index-of: 2 string args or list+target"));
|
|
register "substring" (fun args ->
|
|
match args with
|
|
| [String s; Number start; Number end_] ->
|
|
let i = int_of_float start and j = int_of_float end_ in
|
|
let len = String.length s in
|
|
let i = max 0 (min i len) and j = max 0 (min j len) in
|
|
String (String.sub s i (max 0 (j - i)))
|
|
| _ -> raise (Eval_error "substring: 3 args"));
|
|
register "substr" (fun args ->
|
|
match args with
|
|
| [String s; Number start; Number len] ->
|
|
let i = int_of_float start and n = int_of_float len in
|
|
let sl = String.length s in
|
|
let i = max 0 (min i sl) in
|
|
let n = max 0 (min n (sl - i)) in
|
|
String (String.sub s i n)
|
|
| [String s; Number start] ->
|
|
let i = int_of_float start in
|
|
let sl = String.length s in
|
|
let i = max 0 (min i sl) in
|
|
String (String.sub s i (sl - i))
|
|
| _ -> raise (Eval_error "substr: 2-3 args"));
|
|
register "split" (fun args ->
|
|
match args with
|
|
| [String s; String sep] ->
|
|
List (List.map (fun p -> String p) (String.split_on_char sep.[0] s))
|
|
| _ -> raise (Eval_error "split: 2 args"));
|
|
register "join" (fun args ->
|
|
match args with
|
|
| [String sep; (List items | ListRef { contents = items })] ->
|
|
String (String.concat sep (List.map to_string items))
|
|
| _ -> raise (Eval_error "join: 2 args"));
|
|
register "replace" (fun args ->
|
|
let to_str = function
|
|
| String s -> s | SxExpr s -> s | RawHTML s -> s
|
|
| Keyword k -> k | Symbol s -> s
|
|
| Nil -> "" | Bool true -> "true" | Bool false -> "false"
|
|
| Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n
|
|
| Thunk _ as t -> (match !_sx_trampoline_fn t with String s -> s | v -> to_string v)
|
|
| v -> to_string v
|
|
in
|
|
match args with
|
|
| [s; old_s; new_s] ->
|
|
let s = to_str s and old_s = to_str old_s and new_s = to_str new_s in
|
|
let ol = String.length old_s in
|
|
if ol = 0 then String s
|
|
else begin
|
|
let buf = Buffer.create (String.length s) in
|
|
let rec go i =
|
|
if i >= String.length s then ()
|
|
else if i + ol <= String.length s && String.sub s i ol = old_s then begin
|
|
Buffer.add_string buf new_s;
|
|
go (i + ol)
|
|
end else begin
|
|
Buffer.add_char buf s.[i];
|
|
go (i + 1)
|
|
end
|
|
in go 0;
|
|
String (Buffer.contents buf)
|
|
end
|
|
| _ -> raise (Eval_error "replace: 3 string args"));
|
|
register "char-from-code" (fun args ->
|
|
match args with
|
|
| [Number n] ->
|
|
let buf = Buffer.create 4 in
|
|
Buffer.add_utf_8_uchar buf (Uchar.of_int (int_of_float n));
|
|
String (Buffer.contents buf)
|
|
| _ -> raise (Eval_error "char-from-code: 1 arg"));
|
|
|
|
(* === Collections === *)
|
|
register "list" (fun args -> ListRef (ref args));
|
|
register "len" (fun args ->
|
|
match args with
|
|
| [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] | [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 "length" (Hashtbl.find primitives "len");
|
|
register "first" (fun args ->
|
|
match args with
|
|
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
|
|
| [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil
|
|
| [x] -> raise (Eval_error ("first: expected list, got " ^ inspect x))
|
|
| _ -> raise (Eval_error "first: 1 list arg"));
|
|
register "rest" (fun args ->
|
|
match args with
|
|
| [List (_ :: xs)] | [ListRef { contents = _ :: xs }] -> List xs
|
|
| [List []] | [ListRef { contents = [] }] -> List [] | [Nil] -> List []
|
|
| _ -> raise (Eval_error "rest: 1 list arg"));
|
|
register "last" (fun args ->
|
|
match args with
|
|
| [List l] | [ListRef { contents = l }] ->
|
|
(match List.rev l with x :: _ -> x | [] -> Nil)
|
|
| _ -> raise (Eval_error "last: 1 list arg"));
|
|
register "init" (fun args ->
|
|
match args with
|
|
| [List l] | [ListRef { contents = l }] ->
|
|
(match List.rev l with _ :: rest -> List (List.rev rest) | [] -> List [])
|
|
| _ -> raise (Eval_error "init: 1 list arg"));
|
|
register "nth" (fun args ->
|
|
match args with
|
|
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
|
(try List.nth l (int_of_float n) with _ -> Nil)
|
|
| [String s; Number n] ->
|
|
let i = int_of_float n in
|
|
if i >= 0 && i < String.length s then String (String.make 1 s.[i])
|
|
else Nil
|
|
| _ -> raise (Eval_error "nth: list/string and number"));
|
|
register "cons" (fun args ->
|
|
match args with
|
|
| [x; List l] | [x; ListRef { contents = l }] -> List (x :: l)
|
|
| [x; Nil] -> List [x]
|
|
| _ -> raise (Eval_error "cons: value and list"));
|
|
register "append" (fun args ->
|
|
match args with
|
|
| [List la | ListRef { contents = la }; List lb | ListRef { contents = lb }] ->
|
|
List (la @ lb)
|
|
| [List la | ListRef { contents = la }; Nil] -> List la
|
|
| [Nil; List lb | ListRef { contents = lb }] -> List lb
|
|
| [List la | ListRef { contents = la }; v] -> List (la @ [v])
|
|
| [v; List lb | ListRef { contents = lb }] -> List ([v] @ lb)
|
|
| _ ->
|
|
let all = List.concat_map as_list args in
|
|
List all);
|
|
register "append!" (fun args ->
|
|
match args with
|
|
| [ListRef r; item] -> r := !r @ [item]; ListRef r
|
|
| [List items; item] -> List (items @ [item])
|
|
| _ -> raise (Eval_error "append!: list and item"));
|
|
register "reverse" (fun args ->
|
|
match args with
|
|
| [List l] | [ListRef { contents = l }] -> List (List.rev l)
|
|
| _ -> raise (Eval_error "reverse: 1 list"));
|
|
register "flatten" (fun args ->
|
|
let rec flat = function
|
|
| List items | ListRef { contents = items } -> List.concat_map flat items
|
|
| x -> [x]
|
|
in
|
|
match args with
|
|
| [List l] | [ListRef { contents = l }] -> List (List.concat_map flat l)
|
|
| _ -> raise (Eval_error "flatten: 1 list"));
|
|
register "concat" (fun args -> List (List.concat_map as_list args));
|
|
register "contains?" (fun args ->
|
|
match args with
|
|
| [List l; item] | [ListRef { contents = l }; item] ->
|
|
(* Physical equality first (handles signals/dicts/closures safely),
|
|
structural fallback only for acyclic types (string/number/bool/nil/symbol/keyword) *)
|
|
let safe_eq a b =
|
|
a == b ||
|
|
(match a, b with
|
|
| Number x, Number y -> x = y
|
|
| String x, String y -> x = y
|
|
| Bool x, Bool y -> x = y
|
|
| Nil, Nil -> true
|
|
| Symbol x, Symbol y -> x = y
|
|
| Keyword x, Keyword y -> x = y
|
|
| Dict a, Dict b ->
|
|
(match Hashtbl.find_opt a "__host_handle", Hashtbl.find_opt b "__host_handle" with
|
|
| Some (Number ha), Some (Number hb) -> ha = hb
|
|
| _ -> false)
|
|
| _ -> false)
|
|
in
|
|
Bool (List.exists (fun x -> safe_eq x item) l)
|
|
| [String s; String sub] ->
|
|
let rec find i =
|
|
if i + String.length sub > String.length s then false
|
|
else if String.sub s i (String.length sub) = sub then true
|
|
else find (i + 1)
|
|
in Bool (find 0)
|
|
| _ -> raise (Eval_error "contains?: 2 args"));
|
|
register "range" (fun args ->
|
|
match args with
|
|
| [Number stop] ->
|
|
let n = int_of_float stop in
|
|
List (List.init (max 0 n) (fun i -> Number (float_of_int i)))
|
|
| [Number start; Number stop] ->
|
|
let s = int_of_float start and e = int_of_float stop in
|
|
let len = max 0 (e - s) in
|
|
List (List.init len (fun i -> Number (float_of_int (s + i))))
|
|
| [Number start; Number stop; Number step] ->
|
|
let s = start and e = stop and st = step in
|
|
if st = 0.0 then List []
|
|
else
|
|
let items = ref [] in
|
|
let i = ref s in
|
|
if st > 0.0 then
|
|
(while !i < e do items := Number !i :: !items; i := !i +. st done)
|
|
else
|
|
(while !i > e do items := Number !i :: !items; i := !i +. st done);
|
|
List (List.rev !items)
|
|
| _ -> raise (Eval_error "range: 1-3 args"));
|
|
register "slice" (fun args ->
|
|
match args with
|
|
| [(List l | ListRef { contents = l }); Number start] ->
|
|
let i = max 0 (int_of_float start) in
|
|
let rec drop n = function _ :: xs when n > 0 -> drop (n-1) xs | l -> l in
|
|
List (drop i l)
|
|
| [(List l | ListRef { contents = l }); Number start; Number end_] ->
|
|
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
|
let len = List.length l in
|
|
let j = min j len in
|
|
let rec take_range idx = function
|
|
| [] -> []
|
|
| x :: xs ->
|
|
if idx >= j then []
|
|
else if idx >= i then x :: take_range (idx+1) xs
|
|
else take_range (idx+1) xs
|
|
in List (take_range 0 l)
|
|
| [String s; Number start] ->
|
|
let i = max 0 (int_of_float start) in
|
|
String (String.sub s i (max 0 (String.length s - i)))
|
|
| [String s; Number start; Number end_] ->
|
|
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
|
let sl = String.length s in
|
|
let j = min j sl in
|
|
String (String.sub s i (max 0 (j - i)))
|
|
| _ -> raise (Eval_error "slice: 2-3 args"));
|
|
register "sort" (fun args ->
|
|
match args with
|
|
| [List l] | [ListRef { contents = l }] -> List (List.sort compare l)
|
|
| _ -> raise (Eval_error "sort: 1 list"));
|
|
register "zip" (fun args ->
|
|
match args with
|
|
| [a; b] ->
|
|
let la = as_list a and lb = as_list b in
|
|
let rec go l1 l2 acc = match l1, l2 with
|
|
| x :: xs, y :: ys -> go xs ys (List [x; y] :: acc)
|
|
| _ -> List.rev acc
|
|
in List (go la lb [])
|
|
| _ -> raise (Eval_error "zip: 2 lists"));
|
|
register "zip-pairs" (fun args ->
|
|
match args with
|
|
| [v] ->
|
|
let l = as_list v in
|
|
let rec go = function
|
|
| a :: b :: rest -> List [a; b] :: go rest
|
|
| _ -> []
|
|
in List (go l)
|
|
| _ -> raise (Eval_error "zip-pairs: 1 list"));
|
|
register "take" (fun args ->
|
|
match args with
|
|
| [(List l | ListRef { contents = l }); Number n] ->
|
|
let rec take_n i = function
|
|
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
|
| _ -> []
|
|
in List (take_n (int_of_float n) l)
|
|
| _ -> raise (Eval_error "take: list and number"));
|
|
register "drop" (fun args ->
|
|
match args with
|
|
| [(List l | ListRef { contents = l }); Number n] ->
|
|
let rec drop_n i = function
|
|
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
|
| l -> l
|
|
in List (drop_n (int_of_float n) l)
|
|
| _ -> raise (Eval_error "drop: list and number"));
|
|
register "chunk-every" (fun args ->
|
|
match args with
|
|
| [(List l | ListRef { contents = l }); Number n] ->
|
|
let size = int_of_float n in
|
|
let rec go = function
|
|
| [] -> []
|
|
| l ->
|
|
let rec take_n i = function
|
|
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
|
| _ -> []
|
|
in
|
|
let rec drop_n i = function
|
|
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
|
| l -> l
|
|
in
|
|
List (take_n size l) :: go (drop_n size l)
|
|
in List (go l)
|
|
| _ -> raise (Eval_error "chunk-every: list and number"));
|
|
register "unique" (fun args ->
|
|
match args with
|
|
| [(List l | ListRef { contents = l })] ->
|
|
let seen = Hashtbl.create 16 in
|
|
let result = List.filter (fun x ->
|
|
let key = inspect x in
|
|
if Hashtbl.mem seen key then false
|
|
else (Hashtbl.replace seen key true; true)
|
|
) l in
|
|
List result
|
|
| _ -> raise (Eval_error "unique: 1 list"));
|
|
|
|
(* === Dict === *)
|
|
register "dict" (fun args ->
|
|
let d = make_dict () in
|
|
let rec go = function
|
|
| [] -> Dict d
|
|
| Keyword k :: v :: rest -> dict_set d k v; go rest
|
|
| String k :: v :: rest -> dict_set d k v; go rest
|
|
| _ -> raise (Eval_error "dict: pairs of key value")
|
|
in go args);
|
|
register "get" (fun args ->
|
|
match args with
|
|
| [Dict d; String k] -> dict_get d k
|
|
| [Dict d; Keyword k] -> dict_get d k
|
|
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
|
(try List.nth l (int_of_float n) with _ -> Nil)
|
|
| [Nil; _] -> Nil (* nil.anything → nil *)
|
|
| [_; _] -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
|
|
| _ -> Nil);
|
|
register "has-key?" (fun args ->
|
|
match args with
|
|
| [Dict d; String k] -> Bool (dict_has d k)
|
|
| [Dict d; Keyword k] -> Bool (dict_has d k)
|
|
| _ -> raise (Eval_error "has-key?: dict and key"));
|
|
register "assoc" (fun args ->
|
|
match args with
|
|
| Dict d :: rest ->
|
|
let d2 = Hashtbl.copy d in
|
|
let rec go = function
|
|
| [] -> Dict d2
|
|
| String k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
|
| Keyword k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
|
| _ -> raise (Eval_error "assoc: pairs")
|
|
in go rest
|
|
| _ -> raise (Eval_error "assoc: dict + pairs"));
|
|
register "dissoc" (fun args ->
|
|
match args with
|
|
| Dict d :: keys ->
|
|
let d2 = Hashtbl.copy d in
|
|
List.iter (fun k -> Hashtbl.remove d2 (to_string k)) keys;
|
|
Dict d2
|
|
| _ -> raise (Eval_error "dissoc: dict + keys"));
|
|
register "merge" (fun args ->
|
|
let d = make_dict () in
|
|
List.iter (function
|
|
| Dict src -> Hashtbl.iter (fun k v -> Hashtbl.replace d k v) src
|
|
| _ -> raise (Eval_error "merge: all args must be dicts")
|
|
) args;
|
|
Dict d);
|
|
register "keys" (fun args ->
|
|
match args with [Dict d] -> List (dict_keys d) | _ -> raise (Eval_error "keys: 1 dict"));
|
|
register "vals" (fun args ->
|
|
match args with [Dict d] -> List (dict_vals d) | _ -> raise (Eval_error "vals: 1 dict"));
|
|
register "mutable-list" (fun _args -> ListRef (ref []));
|
|
register "set-nth!" (fun args ->
|
|
match args with
|
|
| [ListRef r; Number n; v] ->
|
|
let i = int_of_float n in
|
|
let l = !r in
|
|
r := List.mapi (fun j x -> if j = i then v else x) l;
|
|
Nil
|
|
| [List _; _; _] ->
|
|
raise (Eval_error "set-nth!: list is immutable, use ListRef")
|
|
| _ -> raise (Eval_error "set-nth!: expected (list idx val)"));
|
|
register "dict-set!" (fun args ->
|
|
match args with
|
|
| [Dict d; String k; v] -> dict_set d k v; v
|
|
| [Dict d; Keyword k; v] -> dict_set d k v; v
|
|
| _ -> raise (Eval_error "dict-set!: dict key val"));
|
|
register "dict-get" (fun args ->
|
|
match args with
|
|
| [Dict d; String k] -> dict_get d k
|
|
| [Dict d; Keyword k] -> dict_get d k
|
|
| _ -> raise (Eval_error "dict-get: dict and key"));
|
|
register "dict-has?" (fun args ->
|
|
match args with
|
|
| [Dict d; String k] -> Bool (dict_has d k)
|
|
| _ -> raise (Eval_error "dict-has?: dict and key"));
|
|
register "dict-delete!" (fun args ->
|
|
match args with
|
|
| [Dict d; String k] -> dict_delete d k; Nil
|
|
| _ -> raise (Eval_error "dict-delete!: dict and key"));
|
|
|
|
(* === Misc === *)
|
|
register "type-of" (fun args ->
|
|
match args with [a] -> String (type_of a) | _ -> raise (Eval_error "type-of: 1 arg"));
|
|
register "inspect" (fun args ->
|
|
match args with [a] -> String (inspect a) | _ -> raise (Eval_error "inspect: 1 arg"));
|
|
register "serialize" (fun args ->
|
|
match args with
|
|
| [SxExpr s] -> String s
|
|
| [RawHTML s] -> String s
|
|
| [Spread pairs] ->
|
|
(* Serialize spread values as (make-spread {:key "val" ...}) *)
|
|
let dict_parts = List.map (fun (k, v) ->
|
|
Printf.sprintf ":%s %s" k (inspect v)) pairs in
|
|
String (Printf.sprintf "(make-spread {%s})" (String.concat " " dict_parts))
|
|
| [Component c] ->
|
|
(* Serialize component values as their ~name reference *)
|
|
String (Printf.sprintf "~%s" c.c_name)
|
|
| [Island i] ->
|
|
String (Printf.sprintf "~%s" i.i_name)
|
|
| [Lambda _] -> String "<lambda>"
|
|
| [Record r] -> String (Printf.sprintf "#<%s>" r.r_type.rt_name)
|
|
| [a] -> String (inspect a) (* used for dedup keys in compiler *)
|
|
| _ -> raise (Eval_error "serialize: 1 arg"));
|
|
register "make-symbol" (fun args ->
|
|
match args with
|
|
| [String s] -> Symbol s
|
|
| _ -> raise (Eval_error "make-symbol: expected string"));
|
|
register "error" (fun args ->
|
|
match args with [String msg] -> raise (Eval_error msg)
|
|
| [a] -> raise (Eval_error (to_string a))
|
|
| _ -> raise (Eval_error "error: 1 arg"));
|
|
register "host-error" (fun args ->
|
|
match args with [String msg] -> raise (Eval_error msg)
|
|
| [a] -> raise (Eval_error (to_string a))
|
|
| _ -> raise (Eval_error "host-error: 1 arg"));
|
|
register "try-catch" (fun args ->
|
|
match args with
|
|
| [try_fn; catch_fn] ->
|
|
(try !_sx_trampoline_fn (!_sx_call_fn try_fn [])
|
|
with Eval_error msg ->
|
|
!_sx_trampoline_fn (!_sx_call_fn catch_fn [String msg]))
|
|
| _ -> raise (Eval_error "try-catch: expected (try-fn catch-fn)"));
|
|
(* client? — false by default (server); sx_browser.ml sets _is_client := true *)
|
|
register "client?" (fun _args -> Bool !_is_client);
|
|
(* Named stores — global mutable registry, bypasses env scoping issues *)
|
|
let store_registry : (string, value) Hashtbl.t = Hashtbl.create 16 in
|
|
register "def-store" (fun args ->
|
|
match args with
|
|
| [String name; init_fn] ->
|
|
if not (Hashtbl.mem store_registry name) then begin
|
|
let store = !_sx_trampoline_fn (!_sx_call_fn init_fn []) in
|
|
Hashtbl.replace store_registry name store
|
|
end;
|
|
(match Hashtbl.find_opt store_registry name with Some v -> v | None -> Nil)
|
|
| _ -> raise (Eval_error "def-store: expected (name init-fn)"));
|
|
register "use-store" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
(match Hashtbl.find_opt store_registry name with
|
|
| Some v -> v
|
|
| None -> raise (Eval_error ("Store not found: " ^ name)))
|
|
| _ -> raise (Eval_error "use-store: expected (name)"));
|
|
register "clear-stores" (fun _args -> Hashtbl.clear store_registry; Nil);
|
|
(* SSR stubs — resource returns loading state on server.
|
|
NOTE: effect and register-in-scope must NOT be registered as primitives
|
|
here — the bytecode compiler uses primitive? to decide CALL_PRIM vs
|
|
GLOBAL_GET+CALL. If effect is a primitive, bytecoded modules emit
|
|
CALL_PRIM which returns Nil instead of calling the real effect function
|
|
from core-signals.sx. The server overrides effect in sx_server.ml via
|
|
env_bind AFTER compilation. *)
|
|
(* register "effect" — REMOVED: see note above *)
|
|
(* register "register-in-scope" — REMOVED: see note above *)
|
|
(* resource — SSR stub: return signal with {loading: true}, client hydrates real fetch *)
|
|
register "resource" (fun _args ->
|
|
let state = Hashtbl.create 8 in
|
|
Hashtbl.replace state "loading" (Bool true);
|
|
Hashtbl.replace state "data" Nil;
|
|
Hashtbl.replace state "error" Nil;
|
|
let sig_d = Hashtbl.create 8 in
|
|
Hashtbl.replace sig_d "__signal" (Bool true);
|
|
Hashtbl.replace sig_d "value" (Dict state);
|
|
Hashtbl.replace sig_d "subscribers" (List []);
|
|
Hashtbl.replace sig_d "deps" (List []);
|
|
Dict sig_d);
|
|
register "apply" (fun args ->
|
|
let call f a =
|
|
match f with
|
|
| NativeFn (_, fn) -> fn a
|
|
| _ -> !_sx_trampoline_fn (!_sx_call_fn f a)
|
|
in
|
|
match args with
|
|
| [f; (List a | ListRef { contents = a })] -> call f a
|
|
| [f; Nil] -> call f []
|
|
| _ -> raise (Eval_error "apply: function and list"));
|
|
register "identical?" (fun args ->
|
|
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args"));
|
|
register "make-spread" (fun args ->
|
|
match args with
|
|
| [Dict d] ->
|
|
let pairs = Hashtbl.fold (fun k v acc -> (k, v) :: acc) d [] in
|
|
Spread pairs
|
|
| _ -> raise (Eval_error "make-spread: 1 dict"));
|
|
register "spread?" (fun args ->
|
|
match args with [Spread _] -> Bool true | [_] -> Bool false
|
|
| _ -> raise (Eval_error "spread?: 1 arg"));
|
|
register "spread-attrs" (fun args ->
|
|
match args with
|
|
| [Spread pairs] ->
|
|
let d = make_dict () in
|
|
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)
|
|
| [_; Nil] -> List []
|
|
| _ -> raise (Eval_error "map: expected (fn list)"));
|
|
register "map-indexed" (fun args ->
|
|
match args with
|
|
| [f; (List items | ListRef { contents = items })] ->
|
|
List (List.mapi (fun i x -> call_any f [Number (float_of_int i); x]) items)
|
|
| [_; Nil] -> List []
|
|
| _ -> raise (Eval_error "map-indexed: 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)
|
|
| [_; Nil] -> List []
|
|
| _ -> 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
|
|
| [_; Nil] -> Nil (* nil collection = no-op *)
|
|
| _ ->
|
|
let types = String.concat ", " (List.map (fun v -> type_of v) args) in
|
|
raise (Eval_error (Printf.sprintf "for-each: expected (fn list), got (%s) %d args" types (List.length args))));
|
|
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)"));
|
|
register "some" (fun args ->
|
|
match args with
|
|
| [f; (List items | ListRef { contents = items })] ->
|
|
let rec find = function
|
|
| [] -> Bool false
|
|
| x :: rest ->
|
|
let result = call_any f [x] in
|
|
if sx_truthy result then result else find rest
|
|
in find items
|
|
| [_; Nil] -> Bool false
|
|
| _ -> raise (Eval_error "some: expected (fn list)"));
|
|
register "every?" (fun args ->
|
|
match args with
|
|
| [f; (List items | ListRef { contents = items })] ->
|
|
Bool (List.for_all (fun x -> sx_truthy (call_any f [x])) items)
|
|
| [_; Nil] -> Bool true
|
|
| _ -> raise (Eval_error "every?: expected (fn list)"));
|
|
|
|
(* ---- VM stack primitives (vm.sx platform interface) ---- *)
|
|
register "make-vm-stack" (fun args ->
|
|
match args with
|
|
| [Number n] -> ListRef (ref (List.init (int_of_float n) (fun _ -> Nil)))
|
|
| _ -> raise (Eval_error "make-vm-stack: expected (size)"));
|
|
register "vm-stack-get" (fun args ->
|
|
match args with
|
|
| [ListRef r; Number n] -> List.nth !r (int_of_float n)
|
|
| _ -> raise (Eval_error "vm-stack-get: expected (stack idx)"));
|
|
register "vm-stack-set!" (fun args ->
|
|
match args with
|
|
| [ListRef r; Number n; v] ->
|
|
let i = int_of_float n in
|
|
r := List.mapi (fun j x -> if j = i then v else x) !r; Nil
|
|
| _ -> raise (Eval_error "vm-stack-set!: expected (stack idx val)"));
|
|
register "vm-stack-length" (fun args ->
|
|
match args with
|
|
| [ListRef r] -> Number (float_of_int (List.length !r))
|
|
| _ -> raise (Eval_error "vm-stack-length: expected (stack)"));
|
|
register "vm-stack-copy!" (fun args ->
|
|
match args with
|
|
| [ListRef src; ListRef dst; Number n] ->
|
|
let count = int_of_float n in
|
|
let src_items = !src in
|
|
dst := List.mapi (fun i x -> if i < count then List.nth src_items i else x) !dst; Nil
|
|
| _ -> raise (Eval_error "vm-stack-copy!: expected (src dst count)"));
|
|
register "primitive?" (fun args ->
|
|
match args with
|
|
| [String name] -> Bool (Hashtbl.mem primitives name)
|
|
| _ -> Bool false);
|
|
|
|
(* Scope stack primitives are registered by sx_server.ml / run_tests.ml
|
|
because they use a shared scope stacks table with collect!/collected. *)
|
|
|
|
(* ---- Predicates needed by adapter-html.sx ---- *)
|
|
register "lambda?" (fun args ->
|
|
match args with [Lambda _] -> Bool true | _ -> Bool false);
|
|
register "island?" (fun args ->
|
|
match args with [Island _] -> Bool true | _ -> Bool false);
|
|
|
|
(* R7RS records *)
|
|
register "record?" (fun args ->
|
|
match args with [v] -> record_p v | _ -> Bool false);
|
|
register "make-rtd" (fun args ->
|
|
match args with [name; fields; ctor_params] -> make_rtd name fields ctor_params
|
|
| _ -> raise (Eval_error "make-rtd: expected (name fields ctor-params)"));
|
|
register "make-record" (fun args ->
|
|
match args with [uid; arg_list] -> make_record uid arg_list
|
|
| _ -> raise (Eval_error "make-record: expected (uid args-list)"));
|
|
register "record-ref" (fun args ->
|
|
match args with [v; idx] -> record_ref v idx
|
|
| _ -> raise (Eval_error "record-ref: expected (record index)"));
|
|
register "record-set!" (fun args ->
|
|
match args with [v; idx; nv] -> record_set_b v idx nv
|
|
| _ -> raise (Eval_error "record-set!: expected (record index value)"));
|
|
register "record-type?" (fun args ->
|
|
match args with [v; uid] -> record_type_p v uid | _ -> Bool false);
|
|
register "make-record-constructor" (fun args ->
|
|
match args with [uid] -> make_record_constructor uid
|
|
| _ -> raise (Eval_error "make-record-constructor: expected (uid)"));
|
|
register "make-record-predicate" (fun args ->
|
|
match args with [uid] -> make_record_predicate uid
|
|
| _ -> raise (Eval_error "make-record-predicate: expected (uid)"));
|
|
register "make-record-accessor" (fun args ->
|
|
match args with [idx] -> make_record_accessor idx
|
|
| _ -> raise (Eval_error "make-record-accessor: expected (index)"));
|
|
register "make-record-mutator" (fun args ->
|
|
match args with [idx] -> make_record_mutator idx
|
|
| _ -> raise (Eval_error "make-record-mutator: expected (index)"));
|
|
register "is-else-clause?" (fun args ->
|
|
match args with
|
|
| [Keyword "else"] -> Bool true
|
|
| [Bool true] -> Bool true
|
|
| _ -> Bool false);
|
|
register "cond-scheme?" (fun args ->
|
|
match args with
|
|
| [List clauses] ->
|
|
Bool (List.for_all (fun c ->
|
|
match c with
|
|
| List l -> List.length l = 2
|
|
| _ -> false) clauses)
|
|
| _ -> Bool false);
|
|
register "component?" (fun args ->
|
|
match args with [Component _] -> Bool true | [Island _] -> Bool true | _ -> Bool false);
|
|
register "lambda-closure" (fun args ->
|
|
match args with [Lambda l] -> Env l.l_closure | _ -> Nil);
|
|
register "component-closure" (fun args ->
|
|
match args with
|
|
| [Component c] -> Env c.c_closure
|
|
| [Island i] -> Env i.i_closure
|
|
| _ -> Nil);
|
|
register "component-has-children?" (fun args ->
|
|
match args with
|
|
| [Component c] -> Bool c.c_has_children
|
|
| [Island i] -> Bool i.i_has_children
|
|
| _ -> Bool false);
|
|
register "component-name" (fun args ->
|
|
match args with
|
|
| [Component c] -> String c.c_name
|
|
| [Island i] -> String i.i_name
|
|
| _ -> Nil);
|
|
register "component-params" (fun args ->
|
|
match args with
|
|
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
|
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
|
| _ -> List []);
|
|
register "component-body" (fun args ->
|
|
match args with
|
|
| [Component c] -> c.c_body
|
|
| [Island i] -> i.i_body
|
|
| _ -> Nil);
|
|
register "component-file" (fun args ->
|
|
match args with [v] -> component_file v | _ -> Nil);
|
|
register "component-set-file!" (fun args ->
|
|
match args with [v; f] -> component_set_file v f | _ -> Nil);
|
|
register "macro?" (fun args ->
|
|
match args with [Macro _] -> Bool true | _ -> Bool false);
|
|
register "for-each-indexed" (fun args ->
|
|
match args with
|
|
| [f; (List items | ListRef { contents = items })] ->
|
|
List.iteri (fun i x -> ignore (call_any f [Number (float_of_int i); x])) items; Nil
|
|
| _ -> raise (Eval_error "for-each-indexed: expected (fn list)"));
|
|
register "lambda-params" (fun args ->
|
|
match args with
|
|
| [Lambda l] -> List (List.map (fun s -> String s) l.l_params)
|
|
| _ -> List []);
|
|
register "lambda-body" (fun args ->
|
|
match args with [Lambda l] -> l.l_body | _ -> Nil);
|
|
(* expand-macro is registered later by run_tests.ml / sx_server.ml
|
|
because it needs eval_expr which creates a dependency cycle *);
|
|
register "empty-dict?" (fun args ->
|
|
match args with
|
|
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
|
| _ -> Bool true);
|
|
register "make-raw-html" (fun args ->
|
|
match args with [String s] -> RawHTML s | _ -> Nil);
|
|
register "raw-html-content" (fun args ->
|
|
match args with [RawHTML s] -> String s | _ -> String "");
|
|
register "get-primitive" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
(match Hashtbl.find_opt primitives name with
|
|
| Some fn -> NativeFn (name, fn)
|
|
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
|
| _ -> raise (Eval_error "get-primitive: expected (name)"));
|
|
register "call-primitive" (fun args ->
|
|
match args with
|
|
| [String name; (List a | ListRef { contents = a })] ->
|
|
(match Hashtbl.find_opt primitives name with
|
|
| Some fn -> fn a
|
|
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
|
| [String name; Nil] ->
|
|
(match Hashtbl.find_opt primitives name with
|
|
| Some fn -> fn []
|
|
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
|
| _ -> raise (Eval_error "call-primitive: expected (name args-list)"));
|
|
();
|
|
|
|
(* ================================================================ *)
|
|
(* Scope stacks — dynamic scope for render-time effects. *)
|
|
(* Migrated from sx_scope.ml — Phase 1 of step 5.5 *)
|
|
(* ================================================================ *)
|
|
|
|
(* --- 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
|
|
if !_scope_trace then
|
|
_scope_log := Printf.sprintf "PUSH %s depth=%d->%d" name (List.length stack) (List.length stack + 1) :: !_scope_log;
|
|
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
|
|
if !_scope_trace then
|
|
_scope_log := Printf.sprintf "POP %s depth=%d->%d" name (List.length stack) (max 0 (List.length stack - 1)) :: !_scope_log;
|
|
(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
|
|
if !_scope_trace then
|
|
_scope_log := Printf.sprintf "PEEK %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
|
|
(match stack with v :: _ -> v | [] -> Nil)
|
|
| _ -> Nil);
|
|
|
|
(* --- Context (scope lookup with optional default) --- *)
|
|
|
|
register "context" (fun args ->
|
|
match args with
|
|
| (String name) :: rest ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
if !_scope_trace then
|
|
_scope_log := Printf.sprintf "CTX %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
|
|
(match stack with
|
|
| v :: _ -> v
|
|
| [] -> (match rest with default_val :: _ -> default_val | [] -> Nil))
|
|
| _ -> Nil);
|
|
|
|
register "context-debug" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
let all_keys = Hashtbl.fold (fun k _ acc -> k :: acc) _scope_stacks [] in
|
|
String (Printf.sprintf "name=%s stack_len=%d all_keys=[%s]"
|
|
name (List.length stack) (String.concat "," all_keys))
|
|
| _ -> String "bad args");
|
|
|
|
(* --- 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 --- *)
|
|
|
|
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 ->
|
|
match Hashtbl.find_opt primitives "scope-emit!" with
|
|
| Some fn -> fn args | None -> 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 Hashtbl.find_opt primitives "emitted" with
|
|
| Some fn -> fn args | None -> List []);
|
|
|
|
register "scope-collected" (fun args ->
|
|
match Hashtbl.find_opt primitives "collected" with
|
|
| Some fn -> fn args | None -> List []);
|
|
|
|
register "scope-clear-collected!" (fun args ->
|
|
match Hashtbl.find_opt primitives "clear-collected!" with
|
|
| Some fn -> fn args | None -> Nil);
|
|
|
|
(* --- Provide aliases --- *)
|
|
|
|
register "provide-push!" (fun args ->
|
|
match Hashtbl.find_opt primitives "scope-push!" with
|
|
| Some fn -> fn args | None -> Nil);
|
|
|
|
register "provide-pop!" (fun args ->
|
|
match Hashtbl.find_opt primitives "scope-pop!" with
|
|
| Some fn -> fn args | None -> Nil)
|