giles
6ef9688bd2
primitive? in make_server_env was checking env bindings only (NativeFn), missing all 132 primitives in the Sx_primitives hashtable. Now checks both primitives table and env. get-primitive similarly fixed. replace primitive now coerces SxExpr/Thunk/RawHTML/etc to strings instead of crashing with "replace: 3 string args" — fixes aser JIT DISABLED. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
814 lines
34 KiB
OCaml
814 lines
34 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 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 --- *)
|
|
|
|
let 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)
|
|
| 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 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
|
|
| 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 ->
|
|
match args with
|
|
| [String s] -> (match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> Nil)
|
|
| [String s; default_val] ->
|
|
(match int_of_string_opt 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 === *)
|
|
(* Normalize ListRef to List for structural equality *)
|
|
let rec normalize_for_eq = function
|
|
| ListRef { contents = items } -> List (List.map normalize_for_eq items)
|
|
| List items -> List (List.map normalize_for_eq items)
|
|
| v -> v
|
|
in
|
|
register "=" (fun args ->
|
|
match args with
|
|
| [a; b] -> Bool (normalize_for_eq a = normalize_for_eq b)
|
|
| _ -> raise (Eval_error "=: 2 args"));
|
|
register "!=" (fun args ->
|
|
match args with
|
|
| [a; b] -> Bool (normalize_for_eq a <> normalize_for_eq 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 "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
|
|
| _ -> raise (Eval_error "index-of: 2 string args"));
|
|
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 "first" (fun args ->
|
|
match args with
|
|
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
|
|
| [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil
|
|
| _ -> 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 "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] -> Bool (List.mem 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
|
|
| [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 "apply" (fun args ->
|
|
match args with
|
|
| [NativeFn (_, f); (List a | ListRef { contents = a })] -> f a
|
|
| [NativeFn (_, f); Nil] -> 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 })] ->
|
|
(try List.find (fun x -> sx_truthy (call_any f [x])) items
|
|
with Not_found -> Bool false)
|
|
| [_; 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);
|
|
register "is-else-clause?" (fun args ->
|
|
match args with
|
|
| [Keyword "else"] -> Bool true
|
|
| [Bool true] -> Bool true
|
|
| _ -> 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 "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)"));
|
|
()
|