coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
818e5d53f0973c67304256b5d5317e39a95064b9
rose-ash/hosts/ocaml/lib/sx_primitives.ml
giles 818e5d53f0 OCaml bootstrapper: transpiler compiles full CEK evaluator (61/61 tests) 
SX-to-OCaml transpiler (transpiler.sx) generates sx_ref.ml (~90KB, ~135
mutually recursive functions) from the spec evaluator. Foundation tests
all pass: parser, primitives, env operations, type system.

Key design decisions:
- Env variant added to value type for CEK state dict storage
- Continuation carries optional data dict for captured frames
- Dynamic var tracking distinguishes OCaml fn calls from SX value dispatch
- Single let rec...and block for forward references between all defines
- Unused ref pre-declarations eliminated via let-bound name detection

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-15 20:51:59 +00:00

525 lines
21 KiB
OCaml
Raw Blame History

(** 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
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
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
let as_string = function
| String s -> s
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
let as_list = function
| List l -> l
| 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 (Float.of_int (int_of_float (Float.round (as_number a -. 0.5))))
| _ -> raise (Eval_error "floor: 1 arg"));
register "ceil" (fun args ->
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a +. 0.5))))
| _ -> 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)
| [Number n] -> Number (float_of_int (int_of_float n))
| _ -> 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 === *)
register "=" (fun args ->
match args with [a; b] -> Bool (a = b) | _ -> raise (Eval_error "=: 2 args"));
register "!=" (fun args ->
match args with [a; b] -> Bool (a <> b) | _ -> raise (Eval_error "!=: 2 args"));
register "<" (fun args ->
match args with [a; b] -> Bool (as_number a < as_number b) | _ -> raise (Eval_error "<: 2 args"));
register ">" (fun args ->
match args with [a; b] -> Bool (as_number a > as_number b) | _ -> raise (Eval_error ">: 2 args"));
register "<=" (fun args ->
match args with [a; b] -> Bool (as_number a <= as_number b) | _ -> raise (Eval_error "<=: 2 args"));
register ">=" (fun args ->
match args with [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 _] -> 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 []] -> Bool true | [List _] -> 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] -> String (String.concat sep (List.map to_string items))
| _ -> raise (Eval_error "join: 2 args"));
register "replace" (fun args ->
match args with
| [String s; String old_s; String new_s] ->
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 -> List args);
register "len" (fun args ->
match args with
| [List 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))
| _ -> raise (Eval_error "len: 1 arg"));
register "first" (fun args ->
match args with
| [List (x :: _)] -> x | [List []] -> Nil
| _ -> raise (Eval_error "first: 1 list arg"));
register "rest" (fun args ->
match args with
| [List (_ :: xs)] -> List xs | [List []] -> List []
| _ -> raise (Eval_error "rest: 1 list arg"));
register "last" (fun args ->
match args with
| [List l] -> (match List.rev l with x :: _ -> x | [] -> Nil)
| _ -> raise (Eval_error "last: 1 list arg"));
register "nth" (fun args ->
match args with
| [List l; Number n] -> (try List.nth l (int_of_float n) with _ -> Nil)
| _ -> raise (Eval_error "nth: list and number"));
register "cons" (fun args ->
match args with
| [x; List l] -> List (x :: l)
| _ -> raise (Eval_error "cons: value and list"));
register "append" (fun args ->
let all = List.concat_map (fun a -> as_list a) args in
List all);
register "reverse" (fun args ->
match args with [List l] -> List (List.rev l) | _ -> raise (Eval_error "reverse: 1 list"));
register "flatten" (fun args ->
let rec flat = function
| List items -> List.concat_map flat items
| x -> [x]
in
match args with [List 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] -> 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))))
| _ -> raise (Eval_error "range: 1-2 args"));
register "slice" (fun args ->
match args with
| [List 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; 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] -> List (List.sort compare l)
| _ -> raise (Eval_error "sort: 1 list"));
register "zip" (fun args ->
match args with
| [List a; List b] ->
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 a b [])
| _ -> raise (Eval_error "zip: 2 lists"));
register "zip-pairs" (fun args ->
match args with
| [List l] ->
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; 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; 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; 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] ->
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] -> (try List.nth l (int_of_float n) with _ -> Nil)
| _ -> raise (Eval_error "get: dict+key or list+index"));
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 "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 "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] -> f a
| _ -> 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"));
()
Reference in New Issue View Git Blame Copy Permalink