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

ocaml: numeric tower — Integer/Number distinction + float contagion

Browse Source 
Add `Integer of int` to sx_types.ml alongside `Number of float`. Parser
produces Integer for whole-number literals. Arithmetic primitives apply
float contagion (int op int → Integer, int op float → Number). Division
always returns Number. Rounding (floor/truncate/round) returns Integer.
Predicates: integer?, float?, exact?, inexact?, exact->inexact,
inexact->exact. run_tests.ml updated for json_of_value, value_of_json,
identical?, random-int mock, DOM accessors, and parser pattern matches.
New spec/tests/test-numeric-tower.sx — 92 tests, all pass (394 unchanged).

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-26 12:10:50 +00:00
parent 8f0fc4ce52
commit c70bbdeb36
6 changed files with 498 additions and 141 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
hosts/ocaml/bin/run_tests.ml
View File

@@ -37,7 +37,10 @@ let rec deep_equal a b =
match a, b with
| Nil, Nil -> true
| Bool a, Bool b -> a = b
| Integer a, Integer b -> a = b
| Number a, Number b -> a = b
| Integer a, Number b -> float_of_int a = b
| Number a, Integer b -> a = float_of_int b
| String a, String b -> a = b
| Symbol a, Symbol b -> a = b
| Keyword a, Keyword b -> a = b
@@ -226,7 +229,7 @@ let make_test_env () =
| [String s] ->
let parsed = Sx_parser.parse_all s in
(match parsed with
| [List (Symbol "sxbc" :: Number _ :: payload :: _)] -> payload
| [List (Symbol "sxbc" :: (Number _ | Integer _) :: payload :: _)] -> payload
| _ -> raise (Eval_error "bytecode-deserialize: invalid sxbc format"))
| _ -> raise (Eval_error "bytecode-deserialize: expected string"));
@@ -240,7 +243,7 @@ let make_test_env () =
| [String s] ->
let parsed = Sx_parser.parse_all s in
(match parsed with
| [List (Symbol "cek-state" :: Number _ :: payload :: _)] -> payload
| [List (Symbol "cek-state" :: (Number _ | Integer _) :: payload :: _)] -> payload
| _ -> raise (Eval_error "cek-deserialize: invalid cek-state format"))
| _ -> raise (Eval_error "cek-deserialize: expected string"));
@@ -320,7 +323,10 @@ let make_test_env () =
bind "identical?" (fun args ->
match args with
| [a; b] -> Bool (match a, b with
| Integer x, Integer y -> x = y
| Number x, Number y -> x = y
| Integer x, Number y -> float_of_int x = y
| Number x, Integer y -> x = float_of_int y
| String x, String y -> x = y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
@@ -366,11 +372,15 @@ let make_test_env () =
bind "append!" (fun args ->
match args with
| [ListRef r; v; Number n] when int_of_float n = 0 ->
| [ListRef r; v; (Number n)] when int_of_float n = 0 ->
r := v :: !r; ListRef r (* prepend *)
| [ListRef r; v; (Integer 0)] ->
r := v :: !r; ListRef r (* prepend Integer index *)
| [ListRef r; v] -> r := !r @ [v]; ListRef r (* append in place *)
| [List items; v; Number n] when int_of_float n = 0 ->
| [List items; v; (Number n)] when int_of_float n = 0 ->
List (v :: items) (* immutable prepend *)
| [List items; v; (Integer 0)] ->
List (v :: items) (* immutable prepend Integer index *)
| [List items; v] -> List (items @ [v]) (* immutable fallback *)
| _ -> raise (Eval_error "append!: expected list and value"));
@@ -546,7 +556,10 @@ let make_test_env () =
bind "batch-begin!" (fun _args -> Sx_ref.batch_begin_b ());
bind "batch-end!" (fun _args -> Sx_ref.batch_end_b ());
bind "now-ms" (fun _args -> Number 1000.0);
bind "random-int" (fun args -> match args with [Number lo; _] -> Number lo | _ -> Number 0.0);
bind "random-int" (fun args -> match args with
| [Number lo; _] -> Number lo
| [Integer lo; _] -> Integer lo
| _ -> Integer 0);
bind "try-rerender-page" (fun _args -> Nil);
bind "collect!" (fun args ->
match args with
@@ -1142,18 +1155,20 @@ let run_foundation_tests () =
in
Printf.printf "Suite: parser\n";
assert_eq "number" (Number 42.0) (List.hd (parse_all "42"));
assert_eq "number" (Integer 42) (List.hd (parse_all "42"));
assert_eq "string" (String "hello") (List.hd (parse_all "\"hello\""));
assert_eq "bool true" (Bool true) (List.hd (parse_all "true"));
assert_eq "nil" Nil (List.hd (parse_all "nil"));
assert_eq "keyword" (Keyword "class") (List.hd (parse_all ":class"));
assert_eq "symbol" (Symbol "foo") (List.hd (parse_all "foo"));
assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (List.hd (parse_all "(+ 1 2)"));
assert_eq "list" (List [Symbol "+"; Integer 1; Integer 2]) (List.hd (parse_all "(+ 1 2)"));
(match List.hd (parse_all "(div :class \"card\" (p \"hi\"))") with
| List [Symbol "div"; Keyword "class"; String "card"; List [Symbol "p"; String "hi"]] ->
incr pass_count; Printf.printf " PASS: nested list\n"
| v -> incr fail_count; Printf.printf " FAIL: nested list — got %s\n" (Sx_types.inspect v));
(match List.hd (parse_all "'(1 2 3)") with
| List [Symbol "quote"; List [Integer 1; Integer 2; Integer 3]] ->
incr pass_count; Printf.printf " PASS: quote sugar\n"
| List [Symbol "quote"; List [Number 1.0; Number 2.0; Number 3.0]] ->
incr pass_count; Printf.printf " PASS: quote sugar\n"
| v -> incr fail_count; Printf.printf " FAIL: quote sugar — got %s\n" (Sx_types.inspect v));
@@ -1161,7 +1176,7 @@ let run_foundation_tests () =
| Dict d when dict_has d "a" && dict_has d "b" ->
incr pass_count; Printf.printf " PASS: dict literal\n"
| v -> incr fail_count; Printf.printf " FAIL: dict literal — got %s\n" (Sx_types.inspect v));
assert_eq "comment" (Number 42.0) (List.hd (parse_all ";; comment\n42"));
assert_eq "comment" (Integer 42) (List.hd (parse_all ";; comment\n42"));
assert_eq "string escape" (String "hello\nworld") (List.hd (parse_all "\"hello\\nworld\""));
assert_eq "multiple exprs" (Number 2.0) (Number (float_of_int (List.length (parse_all "(1 2 3) (4 5)"))));
@@ -1978,6 +1993,10 @@ let run_spec_tests env test_files =
(match Hashtbl.find_opt d "children" with
| Some (List l) when i >= 0 && i < List.length l -> List.nth l i
| _ -> (match Hashtbl.find_opt d (string_of_int i) with Some v -> v | None -> Nil))
| [Dict d; Integer n] ->
(match Hashtbl.find_opt d "children" with
| Some (List l) when n >= 0 && n < List.length l -> List.nth l n
| _ -> (match Hashtbl.find_opt d (string_of_int n) with Some v -> v | None -> Nil))
| _ -> Nil);
(* Stringify a value for DOM string properties *)
@@ -2052,8 +2071,8 @@ let run_spec_tests env test_files =
Hashtbl.replace d "childNodes" (List [])
| _ -> ());
stored
| [ListRef r; Number n; value] ->
let idx = int_of_float n in
| [ListRef r; idx_v; value] when (match idx_v with Number _ | Integer _ -> true | _ -> false) ->
let idx = match idx_v with Number n -> int_of_float n | Integer n -> n | _ -> 0 in
let lst = !r in
if idx >= 0 && idx < List.length lst then
r := List.mapi (fun i v -> if i = idx then value else v) lst
@@ -2190,7 +2209,7 @@ let run_spec_tests env test_files =
| [String name; value] ->
let attrs = match Hashtbl.find_opt d "attributes" with Some (Dict a) -> a | _ ->
let a = Hashtbl.create 4 in Hashtbl.replace d "attributes" (Dict a); a in
let sv = match value with String s -> s | Number n ->
let sv = match value with String s -> s | Integer n -> string_of_int n | Number n ->
let i = int_of_float n in if float_of_int i = n then string_of_int i
else string_of_float n | _ -> Sx_types.inspect value in
Hashtbl.replace attrs name (String sv);
@@ -2632,6 +2651,7 @@ let run_spec_tests env test_files =
let rec json_of_value = function
| Nil -> `Null
| Bool b -> `Bool b
| Integer n -> `Int n
| Number n ->
if Float.is_integer n && Float.abs n < 1e16
then `Int (int_of_float n) else `Float n
@@ -2647,8 +2667,8 @@ let run_spec_tests env test_files =
let rec value_of_json = function
| `Null -> Nil
| `Bool b -> Bool b
| `Int i -> Number (float_of_int i)
| `Intlit s -> (try Number (float_of_string s) with _ -> String s)
| `Int i -> Integer i
| `Intlit s -> (try Integer (int_of_string s) with _ -> try Number (float_of_string s) with _ -> String s)
| `Float f -> Number f
| `String s -> String s
| `List xs -> List (List.map value_of_json xs)

18
hosts/ocaml/lib/sx_parser.ml
View File

@@ -90,9 +90,21 @@ let read_symbol s =
String.sub s.src start (s.pos - start)
let try_number str =
match float_of_string_opt str with
| Some n -> Some (Number n)
| None -> None
(* Integers (no '.' or 'e'/'E') → exact Integer; floats → inexact Number *)
let has_dec = String.contains str '.' in
let has_exp = String.contains str 'e' || String.contains str 'E' in
if has_dec || has_exp then
match float_of_string_opt str with
| Some n -> Some (Number n)
| None -> None
else
match int_of_string_opt str with
| Some n -> Some (Integer n)
| None ->
(* handles "nan", "inf", "-inf" *)
match float_of_string_opt str with
| Some n -> Some (Number n)
| None -> None
let rec read_value s : value =
skip_whitespace_and_comments s;

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

@@ -51,7 +51,15 @@ let get_primitive name =
(* Trampoline hook — set by sx_ref after initialization to break circular dep *)
let trampoline_hook : (value -> value) ref = ref (fun v -> v)
let as_int = function
| Integer n -> n
| Number n -> int_of_float n
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
let all_ints = List.for_all (function Integer _ -> true | _ -> false)
let rec as_number = function
| Integer n -> float_of_int n
| Number n -> n
| Bool true -> 1.0
| Bool false -> 0.0
@@ -79,6 +87,7 @@ let as_bool = function
let rec to_string = function
| String s -> s
| Integer n -> string_of_int n
| Number n -> Sx_types.format_number n
| Bool true -> "true"
| Bool false -> "false"
@@ -93,49 +102,81 @@ let rec to_string = function
let () =
(* === Arithmetic === *)
register "+" (fun args ->
Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args));
if all_ints args then
Integer (List.fold_left (fun acc a -> match a with Integer n -> acc + n | _ -> acc) 0 args)
else
Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args));
register "-" (fun args ->
match args with
| [] -> Number 0.0
| [] -> Integer 0
| [Integer n] -> Integer (-n)
| [a] -> Number (-. (as_number a))
| a :: rest -> Number (List.fold_left (fun acc x -> acc -. as_number x) (as_number a) rest));
| _ when all_ints args ->
(match args with
| Integer h :: tl ->
Integer (List.fold_left (fun acc a -> match a with Integer n -> acc - n | _ -> acc) h tl)
| _ -> Number 0.0)
| 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));
if all_ints args then
Integer (List.fold_left (fun acc a -> match a with Integer n -> acc * n | _ -> acc) 1 args)
else
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
| [Integer a; Integer b] -> Integer (a mod b)
| [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"));
match args with
| [Integer n] -> Integer (n + 1)
| [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"));
match args with
| [Integer n] -> Integer (n - 1)
| [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"));
match args with
| [Integer n] -> Integer (abs n)
| [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))
match args with
| [Integer n] -> Integer n
| [a] -> Integer (int_of_float (floor (as_number a)))
| _ -> raise (Eval_error "floor: 1 arg"));
register "ceil" (fun args ->
match args with [a] -> Number (ceil (as_number a))
match args with
| [Integer n] -> Integer n
| [a] -> Integer (int_of_float (ceil (as_number a)))
| _ -> raise (Eval_error "ceil: 1 arg"));
register "round" (fun args ->
match args with
| [a] -> Number (Float.round (as_number a))
| [Integer n] -> Integer n
| [a] -> Integer (int_of_float (Float.round (as_number a)))
| [a; b] ->
let n = as_number a and places = int_of_float (as_number b) in
let n = as_number a and places = as_int 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")
| _ when all_ints args ->
Integer (List.fold_left (fun acc a -> match a with Integer n -> min acc n | _ -> acc) max_int args)
| _ -> 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")
| _ when all_ints args ->
Integer (List.fold_left (fun acc a -> match a with Integer n -> max acc n | _ -> acc) min_int args)
| _ -> 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"));
@@ -189,6 +230,7 @@ let () =
Number (Float.sqrt sum));
register "sign" (fun args ->
match args with
| [Integer n] -> Integer (if n > 0 then 1 else if n < 0 then -1 else 0)
| [a] ->
let n = as_number a in
Number (if Float.is_nan n then Float.nan
@@ -234,32 +276,47 @@ let () =
| _ -> raise (Eval_error "clamp: 3 args"));
register "truncate" (fun args ->
match args with
| [a] -> let n = as_number a in Number (if n >= 0.0 then floor n else ceil n)
| [Integer n] -> Integer n
| [a] -> let n = as_number a in Integer (int_of_float (if n >= 0.0 then floor n else ceil n))
| _ -> raise (Eval_error "truncate: 1 arg"));
register "remainder" (fun args ->
match args with
| [Integer a; Integer b] -> Integer (a mod b)
| [a; b] -> Number (Float.rem (as_number a) (as_number b))
| _ -> raise (Eval_error "remainder: 2 args"));
register "modulo" (fun args ->
match args with
| [Integer a; Integer b] ->
let r = a mod b in
Integer (if r = 0 || (r > 0) = (b > 0) then r else r + b)
| [a; b] ->
let a = as_number a and b = as_number b in
let r = Float.rem a b in
Number (if r = 0.0 || (r > 0.0) = (b > 0.0) then r else r +. b)
| _ -> raise (Eval_error "modulo: 2 args"));
register "exact?" (fun args ->
match args with [Number f] -> Bool (Float.is_integer f) | [_] -> Bool false
match args with
| [Integer _] -> Bool true
| [Number _] -> Bool false
| [_] -> Bool false
| _ -> raise (Eval_error "exact?: 1 arg"));
register "inexact?" (fun args ->
match args with [Number f] -> Bool (not (Float.is_integer f)) | [_] -> Bool false
match args with
| [Number _] -> Bool true
| [Integer _] -> Bool false
| [_] -> Bool false
| _ -> raise (Eval_error "inexact?: 1 arg"));
register "exact->inexact" (fun args ->
match args with [Number n] -> Number n | [a] -> Number (as_number a)
match args with
| [Integer n] -> Number (float_of_int n)
| [Number n] -> Number n
| [a] -> Number (as_number a)
| _ -> raise (Eval_error "exact->inexact: 1 arg"));
register "inexact->exact" (fun args ->
match args with
| [Number n] -> if Float.is_integer n then Number n else Number (Float.round n)
| [a] -> Number (Float.round (as_number a))
| [Integer n] -> Integer n
| [Number n] -> Integer (int_of_float (Float.round n))
| [a] -> Integer (int_of_float (Float.round (as_number a)))
| _ -> raise (Eval_error "inexact->exact: 1 arg"));
register "parse-int" (fun args ->
let parse_leading_int s =
@@ -276,10 +333,11 @@ let () =
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] -> (match parse_leading_int s with Some n -> Integer 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))
(match parse_leading_int s with Some n -> Integer n | None -> default_val)
| [Integer n] | [Integer n; _] -> Integer n
| [Number n] | [Number n; _] -> Integer (int_of_float n)
| [_; default_val] -> default_val
| _ -> Nil);
register "parse-float" (fun args ->
@@ -296,7 +354,10 @@ let () =
let rec safe_eq a b =
if a == b then true (* physical equality fast path *)
else match a, b with
| Integer x, Integer y -> x = y
| Number x, Number y -> x = y
| Integer x, Number y -> float_of_int x = y
| Number x, Integer y -> x = float_of_int y
| String x, String y -> x = y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
@@ -368,9 +429,21 @@ let () =
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"));
match args with
| [Integer _] | [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"));
match args with
| [Integer _] -> Bool true
| [Number f] -> Bool (Float.is_integer f)
| [_] -> Bool false
| _ -> raise (Eval_error "integer?: 1 arg"));
register "float?" (fun args ->
match args with
| [Number _] -> Bool true
| [_] -> Bool false
| _ -> raise (Eval_error "float?: 1 arg"));
register "string?" (fun args ->
match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg"));
register "boolean?" (fun args ->
@@ -412,7 +485,7 @@ let () =
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)))
match args with [a] -> Integer (String.length (as_string a))
| _ -> raise (Eval_error "string-length: 1 arg"));
register "string-contains?" (fun args ->
match args with
@@ -446,7 +519,11 @@ let () =
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
| Integer x, Integer y -> x = y
| Number x, Number y -> x = y
| Integer x, Number y -> float_of_int x = y
| Number x, Integer y -> x = float_of_int y
| String x, String 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
@@ -457,22 +534,22 @@ let () =
| _ -> 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
| [String s; start_v; end_v] ->
let i = as_int start_v and j = as_int end_v 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
| [String s; start_v; len_v] ->
let i = as_int start_v and n = as_int len_v 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
| [String s; start_v] ->
let i = as_int start_v in
let sl = String.length s in
let i = max 0 (min i sl) in
String (String.sub s i (sl - i))
@@ -497,6 +574,7 @@ let () =
| String s -> s | SxExpr s -> s | RawHTML s -> s
| Keyword k -> k | Symbol s -> s
| Nil -> "" | Bool true -> "true" | Bool false -> "false"
| Integer n -> string_of_int n
| 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
@@ -523,28 +601,35 @@ let () =
| _ -> raise (Eval_error "replace: 3 string args"));
register "char-from-code" (fun args ->
match args with
| [Number n] ->
| [a] ->
let n = as_int a in
let buf = Buffer.create 4 in
Buffer.add_utf_8_uchar buf (Uchar.of_int (int_of_float n));
Buffer.add_utf_8_uchar buf (Uchar.of_int n);
String (Buffer.contents buf)
| _ -> raise (Eval_error "char-from-code: 1 arg"));
register "char-at" (fun args ->
match args with
| [String s; Number n] ->
let i = int_of_float n in
| [String s; n] ->
let i = as_int n in
if i >= 0 && i < String.length s then
String (String.make 1 s.[i])
else Nil
| _ -> raise (Eval_error "char-at: string and index"));
register "char-code" (fun args ->
match args with
| [String s] when String.length s > 0 -> Number (float_of_int (Char.code s.[0]))
| [String s] when String.length s > 0 -> Integer (Char.code s.[0])
| _ -> raise (Eval_error "char-code: 1 non-empty string arg"));
register "parse-number" (fun args ->
match args with
| [String s] ->
(try Number (float_of_string s)
with Failure _ -> Nil)
let has_dec = String.contains s '.' in
let has_exp = String.contains s 'e' || String.contains s 'E' in
if has_dec || has_exp then
(try Number (float_of_string s) with Failure _ -> Nil)
else
(match int_of_string_opt s with
| Some n -> Integer n
| None -> (try Number (float_of_string s) with Failure _ -> Nil))
| _ -> raise (Eval_error "parse-number: 1 string arg"));
(* === Regex (PCRE-compatible — same syntax as JS RegExp) === *)
@@ -621,17 +706,17 @@ let () =
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))
| [List l] | [ListRef { contents = l }] -> Integer (List.length l)
| [String s] -> Integer (String.length s)
| [Dict d] -> Integer (Hashtbl.length d)
| [Nil] | [Bool false] -> Integer 0
| [Bool true] -> Integer 1
| [Number _] | [Integer _] -> Integer 1
| [RawHTML s] -> Integer (String.length s)
| [SxExpr s] -> Integer (String.length s)
| [Spread pairs] -> Integer (List.length pairs)
| [Component _] | [Island _] | [Lambda _] | [NativeFn _]
| [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Number 0.0
| [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Integer 0
| _ -> raise (Eval_error (Printf.sprintf "len: %d args"
(List.length args))));
register "length" (Hashtbl.find primitives "len");
@@ -658,10 +743,10 @@ let () =
| _ -> 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
| [List l; n] | [ListRef { contents = l }; n] ->
(try List.nth l (as_int n) with _ -> Nil)
| [String s; n] ->
let i = as_int 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"));
@@ -707,7 +792,10 @@ let () =
let safe_eq a b =
a == b ||
(match a, b with
| Integer x, Integer y -> x = y
| Number x, Number y -> x = y
| Integer x, Number y -> float_of_int x = y
| Number x, Integer y -> x = float_of_int y
| String x, String y -> x = y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
@@ -729,33 +817,45 @@ let () =
| _ -> 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
| [stop_v] ->
let n = as_int stop_v in
List (List.init (max 0 n) (fun i -> Integer i))
| [start_v; stop_v] ->
let s = as_int start_v and e = as_int stop_v 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)
List (List.init len (fun i -> Integer (s + i)))
| [start_v; stop_v; step_v] ->
(match start_v, stop_v, step_v with
| Integer s, Integer e, Integer st ->
if st = 0 then List []
else
let items = ref [] in
let i = ref s in
if st > 0 then
(while !i < e do items := Integer !i :: !items; i := !i + st done)
else
(while !i > e do items := Integer !i :: !items; i := !i + st done);
List (List.rev !items)
| _ ->
let s = as_number start_v and e = as_number stop_v and st = as_number step_v 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
| [(List l | ListRef { contents = l }); start_v] ->
let i = max 0 (as_int start_v) 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
| [(List l | ListRef { contents = l }); start_v; end_v] ->
let i = max 0 (as_int start_v) and j = as_int end_v in
let len = List.length l in
let j = min j len in
let rec take_range idx = function
@@ -765,11 +865,11 @@ let () =
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 s; start_v] ->
let i = max 0 (as_int start_v) 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
| [String s; start_v; end_v] ->
let i = max 0 (as_int start_v) and j = as_int end_v in
let sl = String.length s in
let j = min j sl in
String (String.sub s i (max 0 (j - i)))
@@ -798,24 +898,24 @@ let () =
| _ -> raise (Eval_error "zip-pairs: 1 list"));
register "take" (fun args ->
match args with
| [(List l | ListRef { contents = l }); Number n] ->
| [(List l | ListRef { contents = l }); 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)
in List (take_n (as_int n) l)
| _ -> raise (Eval_error "take: list and number"));
register "drop" (fun args ->
match args with
| [(List l | ListRef { contents = l }); Number n] ->
| [(List l | ListRef { contents = l }); 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)
in List (drop_n (as_int 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
| [(List l | ListRef { contents = l }); n] ->
let size = as_int n in
let rec go = function
| [] -> []
| l ->
@@ -855,8 +955,9 @@ let () =
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)
| [List l; n] | [ListRef { contents = l }; n]
when (match n with Number _ | Integer _ -> true | _ -> false) ->
(try List.nth l (as_int n) with _ -> Nil)
| [Nil; _] -> Nil (* nil.anything → nil *)
| [_; _] -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
| _ -> Nil);
@@ -897,8 +998,8 @@ let () =
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
| [ListRef r; idx; v] ->
let i = as_int idx in
let l = !r in
r := List.mapi (fun j x -> if j = i then v else x) l;
Nil
@@ -1025,15 +1126,15 @@ let () =
register "identical?" (fun args ->
match args with
| [a; b] ->
(* Physical identity for reference types, structural for values.
Numbers/strings/booleans from different constant pools must
compare equal when their values match. *)
let identical = match a, b with
| Integer x, Integer y -> x = y
| Number x, Number y -> x = y
| String x, String y -> x = y (* String.equal *)
| Integer x, Number y -> float_of_int x = y
| Number x, Integer y -> x = float_of_int y
| String x, String y -> x = y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
| _ -> a == b (* reference identity for dicts, lists, etc. *)
| _ -> a == b
in Bool identical
| _ -> raise (Eval_error "identical?: 2 args"));
register "make-spread" (fun args ->
@@ -1071,7 +1172,7 @@ let () =
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)
List (List.mapi (fun i x -> call_any f [Integer i; x]) items)
| [_; Nil] -> List []
| _ -> raise (Eval_error "map-indexed: expected (fn list)"));
register "filter" (fun args ->
@@ -1114,26 +1215,26 @@ let () =
(* ---- 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)))
| [n] -> ListRef (ref (List.init (as_int 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)
| [ListRef r; n] -> List.nth !r (as_int 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
| [ListRef r; n; v] ->
let i = as_int 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))
| [ListRef r] -> Integer (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
| [ListRef src; ListRef dst; n] ->
let count = as_int 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)"));
@@ -1215,28 +1316,28 @@ let () =
(* R7RS vectors — mutable fixed-size arrays *)
register "make-vector" (fun args ->
match args with
| [Number n] -> Vector (Array.make (int_of_float n) Nil)
| [Number n; fill] -> Vector (Array.make (int_of_float n) fill)
| [n] -> Vector (Array.make (as_int n) Nil)
| [n; fill] -> Vector (Array.make (as_int n) fill)
| _ -> raise (Eval_error "make-vector: expected (length) or (length fill)"));
register "vector" (fun args -> Vector (Array.of_list args));
register "vector?" (fun args ->
match args with [Vector _] -> Bool true | [_] -> Bool false
| _ -> raise (Eval_error "vector?: 1 arg"));
register "vector-length" (fun args ->
match args with [Vector arr] -> Number (float_of_int (Array.length arr))
match args with [Vector arr] -> Integer (Array.length arr)
| _ -> raise (Eval_error "vector-length: expected vector"));
register "vector-ref" (fun args ->
match args with
| [Vector arr; Number n] ->
let i = int_of_float n in
| [Vector arr; n] ->
let i = as_int n in
if i < 0 || i >= Array.length arr then
raise (Eval_error (Printf.sprintf "vector-ref: index %d out of bounds (length %d)" i (Array.length arr)));
arr.(i)
| _ -> raise (Eval_error "vector-ref: expected (vector index)"));
register "vector-set!" (fun args ->
match args with
| [Vector arr; Number n; v] ->
let i = int_of_float n in
| [Vector arr; n; v] ->
let i = as_int n in
if i < 0 || i >= Array.length arr then
raise (Eval_error (Printf.sprintf "vector-set!: index %d out of bounds (length %d)" i (Array.length arr)));
arr.(i) <- v; Nil
@@ -1256,13 +1357,13 @@ let () =
register "vector-copy" (fun args ->
match args with
| [Vector arr] -> Vector (Array.copy arr)
| [Vector arr; Number s] ->
let start = int_of_float s in
| [Vector arr; s] ->
let start = as_int s in
let len = Array.length arr - start in
if len <= 0 then Vector [||] else Vector (Array.sub arr start len)
| [Vector arr; Number s; Number e] ->
let start = int_of_float s in
let stop = min (int_of_float e) (Array.length arr) in
| [Vector arr; s; e] ->
let start = as_int s in
let stop = min (as_int e) (Array.length arr) in
let len = stop - start in
if len <= 0 then Vector [||] else Vector (Array.sub arr start len)
| _ -> raise (Eval_error "vector-copy: expected (vector) or (vector start) or (vector start end)"));

11
hosts/ocaml/lib/sx_types.ml
View File

@@ -43,9 +43,10 @@ type env = {
and value =
| Nil
| Bool of bool
| Number of float
| String of string
| Bool of bool
| Integer of int (** Exact integer — distinct from inexact float. *)
| Number of float (** Inexact float. *)
| String of string
| Symbol of string
| Keyword of string
| List of value list
@@ -392,6 +393,7 @@ let format_number n =
let value_to_string = function
| String s -> s | Symbol s -> s | Keyword k -> k
| Integer n -> string_of_int n
| Number n -> format_number n
| Bool true -> "true" | Bool false -> "false"
| Nil -> "" | _ -> "<value>"
@@ -461,6 +463,7 @@ let make_keyword name = Keyword (value_to_string name)
let type_of = function
| Nil -> "nil"
| Bool _ -> "boolean"
| Integer _ -> "number"
| Number _ -> "number"
| String _ -> "string"
| Symbol _ -> "symbol"
@@ -616,6 +619,7 @@ let thunk_env = function
(** {1 Record operations} *)
let val_to_int = function
| Integer n -> n
| Number n -> int_of_float n
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
@@ -777,6 +781,7 @@ let rec inspect = function
| Nil -> "nil"
| Bool true -> "true"
| Bool false -> "false"
| Integer n -> string_of_int n
| Number n -> format_number n
| String s ->
let buf = Buffer.create (String.length s + 2) in

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

@@ -185,7 +185,8 @@ let code_from_value v =
| Some _ as r -> r | None -> Hashtbl.find_opt d k2 in
let bc_list = match find2 "bytecode" "vc-bytecode" with
| Some (List l | ListRef { contents = l }) ->
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
Array.of_list (List.map (fun x -> match x with
| Integer n -> n | Number n -> int_of_float n | _ -> 0) l)
| _ -> [||]
in
let entries = match find2 "constants" "vc-constants" with
@@ -198,10 +199,10 @@ let code_from_value v =
| _ -> entry
) entries in
let arity = match find2 "arity" "vc-arity" with
| Some (Number n) -> int_of_float n | _ -> 0
| Some (Integer n) -> n | Some (Number n) -> int_of_float n | _ -> 0
in
let rest_arity = match find2 "rest-arity" "vc-rest-arity" with
| Some (Number n) -> int_of_float n | _ -> -1
| Some (Integer n) -> n | Some (Number n) -> int_of_float n | _ -> -1
in
(* Compute locals from bytecode: scan for highest LOCAL_GET/LOCAL_SET slot.
The compiler's arity may undercount when nested lets add many locals. *)
@@ -749,10 +750,7 @@ and run vm =
| _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
| 164 (* OP_EQ *) ->
let b = pop vm and a = pop vm in
let rec norm = function
| ListRef { contents = l } -> List (List.map norm l)
| List l -> List (List.map norm l) | v -> v in
push vm (Bool (norm a = norm b))
push vm ((Hashtbl.find Sx_primitives.primitives "=") [a; b])
| 165 (* OP_LT *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
@@ -771,10 +769,10 @@ and run vm =
| 168 (* OP_LEN *) ->
let v = pop vm in
push vm (match v 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 -> Number 0.0
| List l | ListRef { contents = l } -> Integer (List.length l)
| String s -> Integer (String.length s)
| Dict d -> Integer (Hashtbl.length d)
| Nil -> Integer 0
| _ -> (Hashtbl.find Sx_primitives.primitives "len") [v])
| 169 (* OP_FIRST *) ->
let v = pop vm in