Compare commits

..

3 Commits

Author SHA1 Message Date
fa3274c394 briefing: push to origin/loops/ruby after each commit
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
2026-05-06 06:47:27 +00:00
15eb133311 ruby: Phase 1 parser (+83 tests, 190 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 11s
2026-04-25 18:50:49 +00:00
96019e9fe8 ruby: Phase 1 tokenizer (+107 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
lib/ruby/tokenizer.sx — rb-tokenize: keywords, identifiers (@/@~/$/const),
numbers (dec/hex/oct/bin/float), strings (dq with raw interpolation, sq),
symbols, %w/%i, operators (all compound forms), punctuation, comments,
line/col tracking. Plus test runner test.sh and 107 passing tests.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 18:13:05 +00:00
88 changed files with 4256 additions and 18480 deletions

File diff suppressed because it is too large Load Diff

View File

@@ -293,8 +293,6 @@ env["pop-suite"] = function() {
return null;
};
env["test-allowed?"] = function(name) { return true; };
// Load test framework
const projectDir = path.join(__dirname, "..", "..");
const specTests = path.join(projectDir, "spec", "tests");
@@ -343,20 +341,6 @@ if (fs.existsSync(swapPath)) {
}
}
// Load spec library files (define-library modules imported by tests)
for (const libFile of ["stdlib.sx", "signals.sx", "coroutines.sx"]) {
const libPath = path.join(projectDir, "spec", libFile);
if (fs.existsSync(libPath)) {
const libSrc = fs.readFileSync(libPath, "utf8");
const libExprs = Sx.parse(libSrc);
for (const expr of libExprs) {
try { Sx.eval(expr, env); } catch (e) {
console.error(`Error loading spec/${libFile}: ${e.message}`);
}
}
}
}
// Load tw system (needed by spec/tests/test-tw.sx)
const twDir = path.join(projectDir, "shared", "sx", "templates");
for (const twFile of ["tw-type.sx", "tw-layout.sx", "tw.sx"]) {

File diff suppressed because one or more lines are too long

View File

@@ -37,10 +37,7 @@ 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
@@ -229,7 +226,7 @@ let make_test_env () =
| [String s] ->
let parsed = Sx_parser.parse_all s in
(match parsed with
| [List (Symbol "sxbc" :: (Number _ | Integer _) :: payload :: _)] -> payload
| [List (Symbol "sxbc" :: Number _ :: payload :: _)] -> payload
| _ -> raise (Eval_error "bytecode-deserialize: invalid sxbc format"))
| _ -> raise (Eval_error "bytecode-deserialize: expected string"));
@@ -243,7 +240,7 @@ let make_test_env () =
| [String s] ->
let parsed = Sx_parser.parse_all s in
(match parsed with
| [List (Symbol "cek-state" :: (Number _ | Integer _) :: payload :: _)] -> payload
| [List (Symbol "cek-state" :: Number _ :: payload :: _)] -> payload
| _ -> raise (Eval_error "cek-deserialize: invalid cek-state format"))
| _ -> raise (Eval_error "cek-deserialize: expected string"));
@@ -323,10 +320,7 @@ 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
@@ -372,15 +366,11 @@ 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"));
@@ -556,10 +546,7 @@ 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
| [Integer lo; _] -> Integer lo
| _ -> Integer 0);
bind "random-int" (fun args -> match args with [Number lo; _] -> Number lo | _ -> Number 0.0);
bind "try-rerender-page" (fun _args -> Nil);
bind "collect!" (fun args ->
match args with
@@ -1120,47 +1107,6 @@ let make_test_env () =
| _ :: _ -> String "confirmed"
| _ -> Nil);
bind "values" (fun args ->
match args with
| [v] -> v
| vs ->
let d = Hashtbl.create 2 in
Hashtbl.replace d "_values" (Bool true);
Hashtbl.replace d "_list" (List vs);
Dict d);
bind "call-with-values" (fun args ->
match args with
| [producer; consumer] ->
let result = Sx_ref.cek_call producer (List []) in
let spread = (match result with
| Dict d when (match Hashtbl.find_opt d "_values" with Some (Bool true) -> true | _ -> false) ->
(match Hashtbl.find_opt d "_list" with Some (List l) -> l | _ -> [result])
| _ -> [result])
in
Sx_ref.cek_call consumer (List spread)
| _ -> raise (Eval_error "call-with-values: expected 2 args"));
bind "promise?" (fun args ->
match args with
| [v] -> Bool (Sx_ref.is_promise v)
| _ -> Bool false);
bind "make-promise" (fun args ->
match args with
| [v] ->
let d = Hashtbl.create 4 in
Hashtbl.replace d "_promise" (Bool true);
Hashtbl.replace d "forced" (Bool true);
Hashtbl.replace d "value" v;
Dict d
| _ -> Nil);
bind "force" (fun args ->
match args with
| [p] -> Sx_ref.force_promise p
| _ -> Nil);
env
(* ====================================================================== *)
@@ -1196,20 +1142,18 @@ let run_foundation_tests () =
in
Printf.printf "Suite: parser\n";
assert_eq "number" (Integer 42) (List.hd (parse_all "42"));
assert_eq "number" (Number 42.0) (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 "+"; Integer 1; Integer 2]) (List.hd (parse_all "(+ 1 2)"));
assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (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));
@@ -1217,7 +1161,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" (Integer 42) (List.hd (parse_all ";; comment\n42"));
assert_eq "comment" (Number 42.0) (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)"))));
@@ -2034,10 +1978,6 @@ 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 *)
@@ -2112,8 +2052,8 @@ let run_spec_tests env test_files =
Hashtbl.replace d "childNodes" (List [])
| _ -> ());
stored
| [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
| [ListRef r; Number n; value] ->
let idx = int_of_float n 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
@@ -2250,7 +2190,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 | Integer n -> string_of_int n | Number n ->
let sv = match value with String s -> s | 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);
@@ -2692,7 +2632,6 @@ 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
@@ -2708,8 +2647,8 @@ let run_spec_tests env test_files =
let rec value_of_json = function
| `Null -> Nil
| `Bool b -> Bool b
| `Int i -> Integer i
| `Intlit s -> (try Integer (int_of_string s) with _ -> try Number (float_of_string s) with _ -> String s)
| `Int i -> Number (float_of_int i)
| `Intlit s -> (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)
@@ -2872,7 +2811,6 @@ let run_spec_tests env test_files =
match sx_vm_execute with
| Some fn -> Sx_ref.cek_call fn (List args)
| None -> Nil)));
load_module "stdlib.sx" spec_dir; (* pure SX stdlib: format etc. *)
load_module "signals.sx" spec_dir; (* core reactive primitives *)
load_module "signals.sx" web_dir; (* web extensions *)
load_module "freeze.sx" lib_dir;

View File

@@ -296,10 +296,6 @@ let read_blob () =
(* consume trailing newline *)
(try ignore (input_line stdin) with End_of_file -> ());
data
| [List [Symbol "blob"; Integer n]] ->
let data = read_exact_bytes n in
(try ignore (input_line stdin) with End_of_file -> ());
data
| _ -> raise (Eval_error ("read_blob: expected (blob N), got: " ^ line))
(** Batch IO mode — collect requests during aser-slot, resolve after. *)
@@ -361,11 +357,6 @@ let rec read_io_response () =
| [List (Symbol "io-response" :: Number n :: values)]
when int_of_float n = !current_epoch ->
(match values with [v] -> v | _ -> List values)
| [List [Symbol "io-response"; Integer n; value]]
when n = !current_epoch -> value
| [List (Symbol "io-response" :: Integer n :: values)]
when n = !current_epoch ->
(match values with [v] -> v | _ -> List values)
(* Legacy untagged: (io-response value) — accept for backwards compat *)
| [List [Symbol "io-response"; value]] -> value
| [List (Symbol "io-response" :: values)] ->
@@ -405,12 +396,6 @@ let read_batched_io_response () =
when int_of_float n = !current_epoch -> s
| [List [Symbol "io-response"; Number n; v]]
when int_of_float n = !current_epoch -> serialize_value v
| [List [Symbol "io-response"; Integer n; String s]]
when n = !current_epoch -> s
| [List [Symbol "io-response"; Integer n; SxExpr s]]
when n = !current_epoch -> s
| [List [Symbol "io-response"; Integer n; v]]
when n = !current_epoch -> serialize_value v
(* Legacy untagged *)
| [List [Symbol "io-response"; String s]]
| [List [Symbol "io-response"; SxExpr s]] -> s
@@ -974,7 +959,6 @@ let setup_io_bridges env =
bind "sleep" (fun args -> io_request "sleep" args);
bind "set-response-status" (fun args -> match args with
| [Number n] -> _pending_response_status := int_of_float n; Nil
| [Integer n] -> _pending_response_status := n; Nil
| _ -> Nil);
bind "set-response-header" (fun args -> io_request "set-response-header" args)
@@ -1377,7 +1361,6 @@ let rec dispatch env cmd =
| Bool true -> "true"
| Bool false -> "false"
| Number n -> Sx_types.format_number n
| Integer n -> string_of_int n
| String s -> "\"" ^ escape_sx_string s ^ "\""
| Symbol s -> s
| Keyword k -> ":" ^ k
@@ -1391,10 +1374,6 @@ let rec dispatch env cmd =
| Island i -> "~" ^ i.i_name
| SxExpr s -> s
| RawHTML s -> "\"" ^ escape_sx_string s ^ "\""
| Char n -> Sx_types.inspect (Char n)
| Eof -> Sx_types.inspect Eof
| Port _ -> Sx_types.inspect result
| Rational (n, d) -> Printf.sprintf "%d/%d" n d
| _ -> "nil"
in
send_ok_raw (raw_serialize result)
@@ -4471,8 +4450,6 @@ let site_mode () =
match exprs with
| [List [Symbol "epoch"; Number n]] ->
current_epoch := int_of_float n
| [List [Symbol "epoch"; Integer n]] ->
current_epoch := n
(* render-page: full SSR pipeline — URL → complete HTML *)
| [List [Symbol "render-page"; String path]] ->
(try match http_render_page env path [] with
@@ -4530,8 +4507,6 @@ let () =
(* Epoch marker: (epoch N) — set current epoch, read next command *)
| [List [Symbol "epoch"; Number n]] ->
current_epoch := int_of_float n
| [List [Symbol "epoch"; Integer n]] ->
current_epoch := n
| [cmd] -> dispatch env cmd
| _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs))
end

View File

@@ -47,9 +47,7 @@ open Sx_runtime
let trampoline_fn : (value -> value) ref = ref (fun v -> v)
let trampoline v = !trampoline_fn v
(* Step limit for timeout detection — set to 0 to disable *)
let step_limit : int ref = ref 0
let step_count : int ref = ref 0
(* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *)
let _strict_ref = ref (Bool false)
@@ -128,90 +126,6 @@ let enhance_error_with_trace msg =
_last_error_kont_ref := Nil;
msg ^ (format_comp_trace trace)
(* Hand-written sf_define_type — skipped from transpile because the spec uses
&rest params and empty-dict literals that the transpiler can't emit cleanly.
Implements: (define-type Name (Ctor1 f1 f2) (Ctor2 f3) ...)
Creates constructor fns, Name?/Ctor? predicates, Ctor-field accessors,
and records ctors in *adt-registry*. *)
let sf_define_type args env_val =
let items = (match args with List l -> l | _ -> []) in
let type_sym = List.nth items 0 in
let type_name = value_to_string type_sym in
let ctor_specs = List.tl items in
let env_has_v k = sx_truthy (env_has env_val (String k)) in
let env_bind_v k v = ignore (env_bind env_val (String k) v) in
let env_get_v k = env_get env_val (String k) in
if not (env_has_v "*adt-registry*") then
env_bind_v "*adt-registry*" (Dict (Hashtbl.create 8));
let registry = env_get_v "*adt-registry*" in
let ctor_names = List.map (fun spec ->
(match spec with List (sym :: _) -> String (value_to_string sym) | _ -> Nil)
) ctor_specs in
(match registry with Dict d -> Hashtbl.replace d type_name (List ctor_names) | _ -> ());
env_bind_v (type_name ^ "?")
(NativeFn (type_name ^ "?", fun pargs ->
(match pargs with
| [v] ->
(match v with
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
(match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false))
| _ -> Bool false)
| _ -> Bool false)));
List.iter (fun spec ->
(match spec with
| List (sym :: fields) ->
let cn = value_to_string sym in
let field_names = List.map value_to_string fields in
let arity = List.length fields in
env_bind_v cn
(NativeFn (cn, fun ctor_args ->
if List.length ctor_args <> arity then
raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d"
cn arity (List.length ctor_args)))
else begin
let d = Hashtbl.create 4 in
Hashtbl.replace d "_adt" (Bool true);
Hashtbl.replace d "_type" (String type_name);
Hashtbl.replace d "_ctor" (String cn);
Hashtbl.replace d "_fields" (List ctor_args);
Dict d
end));
env_bind_v (cn ^ "?")
(NativeFn (cn ^ "?", fun pargs ->
(match pargs with
| [v] ->
(match v with
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
(match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false))
| _ -> Bool false)
| _ -> Bool false)));
List.iteri (fun idx fname ->
env_bind_v (cn ^ "-" ^ fname)
(NativeFn (cn ^ "-" ^ fname, fun pargs ->
(match pargs with
| [v] ->
(match v with
| Dict d ->
(match Hashtbl.find_opt d "_fields" with
| Some (List fs) ->
if idx < List.length fs then List.nth fs idx
else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict")))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg")))))
) field_names
| _ -> ())
) ctor_specs;
Nil
(* Register define-type via custom_special_forms so the CEK dispatch finds it.
The top-level (register-special-form! ...) in spec/evaluator.sx is not a
define and therefore is not transpiled; we wire it up here instead. *)
let () = ignore (register_special_form (String "define-type")
(NativeFn ("define-type", fun call_args ->
match call_args with
| [args; env] -> sf_define_type args env
| _ -> Nil)))
"""
@@ -257,10 +171,7 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
"debug-log", "debug_log", "range", "chunk-every", "zip-pairs",
"string-contains?", "starts-with?", "ends-with?",
"string-replace", "trim", "split", "index-of",
"pad-left", "pad-right", "char-at", "substring",
# sf-define-type uses &rest + empty-dict literals that the transpiler
# can't emit as valid OCaml; hand-written implementation in FIXUPS.
"sf-define-type"}
"pad-left", "pad-right", "char-at", "substring"}
defines = [(n, e) for n, e in defines if n not in skip]
# Deduplicate — keep last definition for each name (CEK overrides tree-walk)

View File

@@ -89,38 +89,10 @@ let read_symbol s =
while s.pos < s.len && is_symbol_char s.src.[s.pos] do advance s done;
String.sub s.src start (s.pos - start)
let gcd a b =
let rec g a b = if b = 0 then a else g b (a mod b) in g (abs a) (abs b)
let make_rat n d =
if d = 0 then raise (Parse_error "rational: division by zero");
let sign = if d < 0 then -1 else 1 in
let g = gcd (abs n) (abs d) in
let rn = sign * n / g and rd = sign * d / g in
if rd = 1 then Integer rn else Rational (rn, rd)
let try_number str =
(* Integers (no '.' or 'e'/'E') → exact Integer; rationals N/D; 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 String.split_on_char '/' str with
| [num_s; den_s] when num_s <> "" && den_s <> "" ->
(match int_of_string_opt num_s, int_of_string_opt den_s with
| Some n, Some d -> (try Some (make_rat n d) with _ -> None)
| _ -> None)
| _ ->
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
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;
@@ -136,34 +108,6 @@ let rec read_value s : value =
| '"' -> String (read_string s)
| '\'' -> advance s; List [Symbol "quote"; read_value s]
| '`' -> advance s; List [Symbol "quasiquote"; read_value s]
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\\' ->
(* Character literal: #\a, #\space, #\newline, etc. *)
advance s; advance s;
if at_end s then raise (Parse_error "Unexpected end of input after #\\");
let char_start = s.pos in
(* Read a name if starts with ident char, else single char *)
if is_ident_start s.src.[s.pos] then begin
while s.pos < s.len && is_ident_char s.src.[s.pos] do advance s done;
let name = String.sub s.src char_start (s.pos - char_start) in
let cp = match name with
| "space" -> 32 | "newline" -> 10 | "tab" -> 9
| "return" -> 13 | "nul" -> 0 | "null" -> 0
| "escape" -> 27 | "delete" -> 127 | "backspace" -> 8
| "altmode" -> 27 | "rubout" -> 127
| _ -> Char.code name.[0] (* single letter like #\a *)
in Char cp
end else begin
let c = s.src.[s.pos] in
advance s;
Char (Char.code c)
end
| '#' when s.pos + 1 < s.len &&
(s.src.[s.pos + 1] = 't' || s.src.[s.pos + 1] = 'f') &&
(s.pos + 2 >= s.len || not (is_ident_char s.src.[s.pos + 2])) ->
(* #t / #f — boolean literals (R7RS shorthand) *)
let b = s.src.[s.pos + 1] = 't' in
advance s; advance s;
Bool b
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' ->
(* Datum comment: #; discards next expression *)
advance s; advance s;

File diff suppressed because it is too large Load Diff

File diff suppressed because one or more lines are too long

View File

@@ -46,7 +46,7 @@ let sx_call f args =
!Sx_types._cek_eval_lambda_ref f args
| Continuation (k, _) ->
k (match args with x :: _ -> x | [] -> Nil)
| CallccContinuation (_, _) ->
| CallccContinuation _ ->
raise (Eval_error "callcc continuations must be invoked through the CEK machine")
| _ ->
let nargs = List.length args in
@@ -156,9 +156,6 @@ let get_val container key =
| "extra" -> f.cf_extra | "extra2" -> f.cf_extra2
| "subscribers" -> f.cf_results
| "prev-tracking" -> f.cf_extra
| "after-thunk" -> f.cf_f (* wind-after frame *)
| "winders-len" -> f.cf_extra (* wind-after frame *)
| "body-result" -> f.cf_name (* wind-return frame *)
| _ -> Nil)
| VmFrame f, String k ->
(match k with
@@ -211,8 +208,6 @@ let get_val container key =
| Dict d, Keyword k -> dict_get d k
| (List l | ListRef { contents = l }), Number n ->
(try List.nth l (int_of_float n) with _ -> Nil)
| (List l | ListRef { contents = l }), Integer n ->
(try List.nth l n with _ -> Nil)
| Nil, _ -> Nil (* nil.anything → nil *)
| _, _ -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
@@ -386,20 +381,15 @@ let continuation_data v = match v with
| _ -> raise (Eval_error "not a continuation")
(* Callcc (undelimited) continuation support *)
let callcc_continuation_p v = match v with CallccContinuation (_, _) -> Bool true | _ -> Bool false
let callcc_continuation_p v = match v with CallccContinuation _ -> Bool true | _ -> Bool false
let make_callcc_continuation captured winders_len =
let n = match winders_len with Number f -> int_of_float f | Integer n -> n | _ -> 0 in
CallccContinuation (sx_to_list captured, n)
let make_callcc_continuation captured =
CallccContinuation (sx_to_list captured)
let callcc_continuation_data v = match v with
| CallccContinuation (frames, _) -> List frames
| CallccContinuation frames -> List frames
| _ -> raise (Eval_error "not a callcc continuation")
let callcc_continuation_winders_len v = match v with
| CallccContinuation (_, n) -> Number (float_of_int n)
| _ -> Number 0.0
(* Dynamic wind — simplified for OCaml (no async) *)
let host_error msg =
raise (Eval_error (value_to_str msg))

View File

@@ -43,10 +43,9 @@ type env = {
and value =
| Nil
| Bool of bool
| Integer of int (** Exact integer — distinct from inexact float. *)
| Number of float (** Inexact float. *)
| String of string
| Bool of bool
| Number of float
| String of string
| Symbol of string
| Keyword of string
| List of value list
@@ -57,7 +56,7 @@ and value =
| Macro of macro
| Thunk of value * env
| Continuation of (value -> value) * dict option
| CallccContinuation of value list * int (** Undelimited continuation — captured kont frames + winders depth at capture *)
| CallccContinuation of value list (** Undelimited continuation — captured kont frames *)
| NativeFn of string * (value list -> value)
| Signal of signal
| RawHTML of string
@@ -73,25 +72,6 @@ and value =
| Record of record (** R7RS record — opaque, generative, field-indexed. *)
| Parameter of parameter (** R7RS parameter — dynamic binding via kont-stack provide frames. *)
| Vector of value array (** R7RS vector — mutable fixed-size array. *)
| StringBuffer of Buffer.t (** Mutable string buffer — O(1) amortized append. *)
| HashTable of (value, value) Hashtbl.t (** Mutable hash table with arbitrary keys. *)
| Char of int (** Unicode codepoint — R7RS char type. *)
| Eof (** EOF sentinel — returned by read-char etc. at end of input. *)
| Port of sx_port (** String port — input (string cursor) or output (buffer). *)
| Rational of int * int (** Exact rational: numerator, denominator (reduced, denom>0). *)
| SxSet of (string, value) Hashtbl.t (** Mutable set keyed by inspect(value). *)
| SxRegexp of string * string * Re.re (** Regexp: source, flags, compiled. *)
| SxBytevector of bytes (** Mutable bytevector — R7RS bytevector type. *)
(** String input port: source string + mutable cursor position. *)
and sx_port_kind =
| PortInput of string * int ref
| PortOutput of Buffer.t
and sx_port = {
mutable sp_closed : bool;
sp_kind : sx_port_kind;
}
(** CEK machine state — record instead of Dict for performance.
5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *)
@@ -412,7 +392,6 @@ 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>"
@@ -482,7 +461,6 @@ 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"
@@ -495,7 +473,7 @@ let type_of = function
| Macro _ -> "macro"
| Thunk _ -> "thunk"
| Continuation (_, _) -> "continuation"
| CallccContinuation (_, _) -> "continuation"
| CallccContinuation _ -> "continuation"
| NativeFn _ -> "function"
| Signal _ -> "signal"
| RawHTML _ -> "raw-html"
@@ -510,16 +488,6 @@ let type_of = function
| Record r -> r.r_type.rt_name
| Parameter _ -> "parameter"
| Vector _ -> "vector"
| StringBuffer _ -> "string-buffer"
| HashTable _ -> "hash-table"
| Char _ -> "char"
| Eof -> "eof-object"
| Port { sp_kind = PortInput _; _ } -> "input-port"
| Port { sp_kind = PortOutput _; _ } -> "output-port"
| Rational _ -> "rational"
| SxSet _ -> "set"
| SxRegexp _ -> "regexp"
| SxBytevector _ -> "bytevector"
let is_nil = function Nil -> true | _ -> false
let is_lambda = function Lambda _ -> true | _ -> false
@@ -535,7 +503,7 @@ let is_signal = function
let is_record = function Record _ -> true | _ -> false
let is_callable = function
| Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation (_, _) | VmClosure _ -> true
| Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation _ | VmClosure _ -> true
| _ -> false
@@ -648,7 +616,6 @@ 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))
@@ -810,7 +777,6 @@ 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
@@ -844,7 +810,7 @@ let rec inspect = function
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
| Thunk _ -> "<thunk>"
| Continuation (_, _) -> "<continuation>"
| CallccContinuation (_, _) -> "<callcc-continuation>"
| CallccContinuation _ -> "<callcc-continuation>"
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
| Signal _ -> "<signal>"
| RawHTML s -> Printf.sprintf "\"<raw-html:%d>\"" (String.length s)
@@ -865,23 +831,3 @@ let rec inspect = function
Printf.sprintf "#(%s)" (String.concat " " elts)
| VmFrame f -> Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base
| VmMachine m -> Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames)
| StringBuffer buf -> Printf.sprintf "<string-buffer:%d>" (Buffer.length buf)
| HashTable ht -> Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht)
| Char n ->
let name = match n with
| 32 -> "space" | 10 -> "newline" | 9 -> "tab"
| 13 -> "return" | 0 -> "nul" | 27 -> "escape"
| 127 -> "delete" | 8 -> "backspace"
| _ -> let buf = Buffer.create 1 in
Buffer.add_utf_8_uchar buf (Uchar.of_int n);
Buffer.contents buf
in "#\\" ^ name
| Eof -> "#!eof"
| Port { sp_kind = PortInput (_, pos); sp_closed } ->
Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else "")
| Port { sp_kind = PortOutput buf; sp_closed } ->
Printf.sprintf "<output-port:len=%d%s>" (Buffer.length buf) (if sp_closed then ":closed" else "")
| Rational (n, d) -> Printf.sprintf "%d/%d" n d
| SxSet ht -> Printf.sprintf "<set:%d>" (Hashtbl.length ht)
| SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags
| SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i)))))

View File

@@ -185,8 +185,7 @@ 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
| Integer n -> n | Number n -> int_of_float n | _ -> 0) l)
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
| _ -> [||]
in
let entries = match find2 "constants" "vc-constants" with
@@ -199,10 +198,10 @@ let code_from_value v =
| _ -> entry
) entries in
let arity = match find2 "arity" "vc-arity" with
| Some (Integer n) -> n | Some (Number n) -> int_of_float n | _ -> 0
| Some (Number n) -> int_of_float n | _ -> 0
in
let rest_arity = match find2 "rest-arity" "vc-rest-arity" with
| Some (Integer n) -> n | Some (Number n) -> int_of_float n | _ -> -1
| 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. *)
@@ -750,7 +749,10 @@ and run vm =
| _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
| 164 (* OP_EQ *) ->
let b = pop vm and a = pop vm in
push vm ((Hashtbl.find Sx_primitives.primitives "=") [a; b])
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))
| 165 (* OP_LT *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
@@ -769,10 +771,10 @@ and run vm =
| 168 (* OP_LEN *) ->
let v = pop vm in
push vm (match v with
| List l | ListRef { contents = l } -> Integer (List.length l)
| String s -> Integer (String.length s)
| Dict d -> Integer (Hashtbl.length d)
| Nil -> Integer 0
| 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
| _ -> (Hashtbl.find Sx_primitives.primitives "len") [v])
| 169 (* OP_FIRST *) ->
let v = pop vm in

View File

@@ -256,7 +256,6 @@
"callcc-continuation?"
"callcc-continuation-data"
"make-callcc-continuation"
"callcc-continuation-winders-len"
"dynamic-wind-call"
"strip-prefix"
"component-set-param-types!"
@@ -296,8 +295,7 @@
"*bind-tracking*"
"*provide-batch-depth*"
"*provide-batch-queue*"
"*provide-subscribers*"
"*winders*"))
"*provide-subscribers*"))
(define
ml-is-mutable-global?
@@ -535,13 +533,13 @@
"; cf_env = "
(ef "env")
"; cf_name = "
(if (= frame-type "if") (ef "else") (cond (some (fn (k) (= k "body-result")) items) (ef "body-result") :else (ef "name")))
(if (= frame-type "if") (ef "else") (ef "name"))
"; cf_body = "
(if (= frame-type "if") (ef "then") (ef "body"))
"; cf_remaining = "
(ef "remaining")
"; cf_f = "
(cond (some (fn (k) (= k "after-thunk")) items) (ef "after-thunk") (some (fn (k) (= k "f")) items) (ef "f") :else "Nil")
(ef "f")
"; cf_args = "
(cond
(some (fn (k) (= k "evaled")) items)
@@ -584,8 +582,6 @@
(ef "prev-tracking")
(some (fn (k) (= k "extra")) items)
(ef "extra")
(some (fn (k) (= k "winders-len")) items)
(ef "winders-len")
:else "Nil")
"; cf_extra2 = "
(cond

View File

@@ -1,289 +0,0 @@
;; lib/apl/runtime.sx — APL primitives on SX
;;
;; APL vectors are represented as SX lists (functional, immutable results).
;; Operations are rank-polymorphic: scalar/vector arguments both accepted.
;; Index origin: 1 (traditional APL).
;;
;; Primitives used:
;; map (multi-arg, Phase 1)
;; bitwise-and/or/xor/not/arithmetic-shift (Phase 7)
;; make-set/set-member?/set-add!/set->list (Phase 18)
;; ---------------------------------------------------------------------------
;; 1. Core vector constructors
;; ---------------------------------------------------------------------------
;; N — iota: generate integer vector 1, 2, ..., N
(define
(apl-iota n)
(letrec
((go (fn (i acc) (if (< i 1) acc (go (- i 1) (cons i acc))))))
(go n (list))))
;; A — shape (length of a vector)
(define (apl-rho v) (if (list? v) (len v) 1))
;; A[I] — 1-indexed access
(define (apl-at v i) (nth v (- i 1)))
;; Scalar predicate
(define (apl-scalar? v) (not (list? v)))
;; ---------------------------------------------------------------------------
;; 2. Rank-polymorphic helpers
;; dyadic: scalar/vector × scalar/vector → scalar/vector
;; monadic: scalar/vector → scalar/vector
;; ---------------------------------------------------------------------------
(define
(apl-dyadic op a b)
(cond
((and (list? a) (list? b)) (map op a b))
((list? a) (map (fn (x) (op x b)) a))
((list? b) (map (fn (y) (op a y)) b))
(else (op a b))))
(define (apl-monadic op a) (if (list? a) (map op a) (op a)))
;; ---------------------------------------------------------------------------
;; 3. Arithmetic (element-wise, rank-polymorphic)
;; ---------------------------------------------------------------------------
(define (apl-add a b) (apl-dyadic + a b))
(define (apl-sub a b) (apl-dyadic - a b))
(define (apl-mul a b) (apl-dyadic * a b))
(define (apl-div a b) (apl-dyadic / a b))
(define (apl-mod a b) (apl-dyadic modulo a b))
(define (apl-pow a b) (apl-dyadic pow a b))
(define (apl-max a b) (apl-dyadic (fn (x y) (if (> x y) x y)) a b))
(define (apl-min a b) (apl-dyadic (fn (x y) (if (< x y) x y)) a b))
(define (apl-neg a) (apl-monadic (fn (x) (- 0 x)) a))
(define (apl-abs a) (apl-monadic abs a))
(define (apl-floor a) (apl-monadic floor a))
(define (apl-ceil a) (apl-monadic ceil a))
(define (apl-sqrt a) (apl-monadic sqrt a))
(define (apl-exp a) (apl-monadic exp a))
(define (apl-log a) (apl-monadic log a))
;; ---------------------------------------------------------------------------
;; 4. Comparison (element-wise, returns 0/1 booleans)
;; ---------------------------------------------------------------------------
(define (apl-bool v) (if v 1 0))
(define (apl-eq a b) (apl-dyadic (fn (x y) (apl-bool (= x y))) a b))
(define
(apl-neq a b)
(apl-dyadic (fn (x y) (apl-bool (not (= x y)))) a b))
(define (apl-lt a b) (apl-dyadic (fn (x y) (apl-bool (< x y))) a b))
(define (apl-le a b) (apl-dyadic (fn (x y) (apl-bool (<= x y))) a b))
(define (apl-gt a b) (apl-dyadic (fn (x y) (apl-bool (> x y))) a b))
(define (apl-ge a b) (apl-dyadic (fn (x y) (apl-bool (>= x y))) a b))
;; Boolean logic (0/1 vectors)
(define
(apl-and a b)
(apl-dyadic
(fn
(x y)
(if
(and (not (= x 0)) (not (= y 0)))
1
0))
a
b))
(define
(apl-or a b)
(apl-dyadic
(fn
(x y)
(if
(or (not (= x 0)) (not (= y 0)))
1
0))
a
b))
(define
(apl-not a)
(apl-monadic (fn (x) (if (= x 0) 1 0)) a))
;; ---------------------------------------------------------------------------
;; 5. Bitwise operations (element-wise)
;; ---------------------------------------------------------------------------
(define (apl-bitand a b) (apl-dyadic bitwise-and a b))
(define (apl-bitor a b) (apl-dyadic bitwise-or a b))
(define (apl-bitxor a b) (apl-dyadic bitwise-xor a b))
(define (apl-bitnot a) (apl-monadic bitwise-not a))
(define
(apl-lshift a b)
(apl-dyadic (fn (x n) (arithmetic-shift x n)) a b))
(define
(apl-rshift a b)
(apl-dyadic (fn (x n) (arithmetic-shift x (- 0 n))) a b))
;; ---------------------------------------------------------------------------
;; 6. Reduction (fold) and scan
;; ---------------------------------------------------------------------------
(define (apl-reduce-add v) (reduce + 0 v))
(define (apl-reduce-mul v) (reduce * 1 v))
(define
(apl-reduce-max v)
(reduce (fn (acc x) (if (> acc x) acc x)) (first v) (rest v)))
(define
(apl-reduce-min v)
(reduce (fn (acc x) (if (< acc x) acc x)) (first v) (rest v)))
(define
(apl-reduce-and v)
(reduce
(fn
(acc x)
(if
(and (not (= acc 0)) (not (= x 0)))
1
0))
1
v))
(define
(apl-reduce-or v)
(reduce
(fn
(acc x)
(if
(or (not (= acc 0)) (not (= x 0)))
1
0))
0
v))
;; Scan: prefix reduction (yields a vector of running totals)
(define
(apl-scan op v)
(if
(= (len v) 0)
(list)
(letrec
((go (fn (xs acc result) (if (= (len xs) 0) (reverse result) (let ((next (op acc (first xs)))) (go (rest xs) next (cons next result)))))))
(go (rest v) (first v) (list (first v))))))
(define (apl-scan-add v) (apl-scan + v))
(define (apl-scan-mul v) (apl-scan * v))
;; ---------------------------------------------------------------------------
;; 7. Vector manipulation
;; ---------------------------------------------------------------------------
;; ⌽A — reverse
(define (apl-reverse v) (reverse v))
;; A,B — catenate
(define
(apl-cat a b)
(cond
((and (list? a) (list? b)) (append a b))
((list? a) (append a (list b)))
((list? b) (cons a b))
(else (list a b))))
;; ↑N A — take first N elements (negative: take last N)
(define
(apl-take n v)
(if
(>= n 0)
(letrec
((go (fn (xs i) (if (or (= i 0) (= (len xs) 0)) (list) (cons (first xs) (go (rest xs) (- i 1)))))))
(go v n))
(apl-reverse (apl-take (- 0 n) (apl-reverse v)))))
;; ↓N A — drop first N elements
(define
(apl-drop n v)
(if
(>= n 0)
(letrec
((go (fn (xs i) (if (or (= i 0) (= (len xs) 0)) xs (go (rest xs) (- i 1))))))
(go v n))
(apl-reverse (apl-drop (- 0 n) (apl-reverse v)))))
;; Rotate left by n positions
(define
(apl-rotate n v)
(let ((m (modulo n (len v)))) (append (apl-drop m v) (apl-take m v))))
;; Compression: A/B — select elements of B where A is 1
(define
(apl-compress mask v)
(if
(= (len mask) 0)
(list)
(let
((rest-result (apl-compress (rest mask) (rest v))))
(if
(not (= (first mask) 0))
(cons (first v) rest-result)
rest-result))))
;; Indexing: A[B] — select elements at indices B (1-indexed)
(define (apl-index v indices) (map (fn (i) (apl-at v i)) indices))
;; Grade up: indices that would sort the vector ascending
(define
(apl-grade-up v)
(let
((indexed (map (fn (x i) (list x i)) v (apl-iota (len v)))))
(map (fn (p) (nth p 1)) (sort indexed))))
;; ---------------------------------------------------------------------------
;; 8. Set operations (∊ ∩ ~)
;; ---------------------------------------------------------------------------
;; Membership ∊: for each element in A, is it in B? → 0/1 vector
(define
(apl-member a b)
(let
((bset (let ((s (make-set))) (for-each (fn (x) (set-add! s x)) b) s)))
(if
(list? a)
(map (fn (x) (apl-bool (set-member? bset x))) a)
(apl-bool (set-member? bset a)))))
;; Nub A — unique elements, preserving order
(define
(apl-nub v)
(let
((seen (make-set)))
(letrec
((go (fn (xs acc) (if (= (len xs) 0) (reverse acc) (if (set-member? seen (first xs)) (go (rest xs) acc) (begin (set-add! seen (first xs)) (go (rest xs) (cons (first xs) acc))))))))
(go v (list)))))
;; Union AB — nub of concatenation
(define (apl-union a b) (apl-nub (apl-cat a b)))
;; Intersection A∩B
(define
(apl-intersect a b)
(let
((bset (let ((s (make-set))) (for-each (fn (x) (set-add! s x)) b) s)))
(filter (fn (x) (set-member? bset x)) a)))
;; Without A~B
(define
(apl-without a b)
(let
((bset (let ((s (make-set))) (for-each (fn (x) (set-add! s x)) b) s)))
(filter (fn (x) (not (set-member? bset x))) a)))
;; ---------------------------------------------------------------------------
;; 9. Format (⍕) — APL-style display
;; ---------------------------------------------------------------------------
(define
(apl-format v)
(if
(list? v)
(letrec
((go (fn (xs acc) (if (= (len xs) 0) acc (go (rest xs) (str acc (if (= acc "") "" " ") (str (first xs))))))))
(go v ""))
(str v)))

View File

@@ -1,51 +0,0 @@
#!/usr/bin/env bash
# lib/apl/test.sh — smoke-test the APL runtime layer.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found."
exit 1
fi
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/apl/runtime.sx")
(epoch 2)
(load "lib/apl/tests/runtime.sx")
(epoch 3)
(eval "(list apl-test-pass apl-test-fail)")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"
echo "$OUTPUT" | tail -10
exit 1
fi
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
TOTAL=$((P + F))
if [ "$F" -eq 0 ]; then
echo "ok $P/$TOTAL lib/apl tests passed"
else
echo "FAIL $P/$TOTAL passed, $F failed"
fi
[ "$F" -eq 0 ]

View File

@@ -1,327 +0,0 @@
;; lib/apl/tests/runtime.sx — Tests for lib/apl/runtime.sx
;; --- Test framework ---
(define apl-test-pass 0)
(define apl-test-fail 0)
(define apl-test-fails (list))
(define
(apl-test name got expected)
(if
(= got expected)
(set! apl-test-pass (+ apl-test-pass 1))
(begin
(set! apl-test-fail (+ apl-test-fail 1))
(set! apl-test-fails (append apl-test-fails (list {:got got :expected expected :name name}))))))
;; ---------------------------------------------------------------------------
;; 1. Core vector constructors
;; ---------------------------------------------------------------------------
(apl-test
"iota 5"
(apl-iota 5)
(list 1 2 3 4 5))
(apl-test "iota 1" (apl-iota 1) (list 1))
(apl-test "iota 0" (apl-iota 0) (list))
(apl-test
"rho list"
(apl-rho (list 1 2 3))
3)
(apl-test "rho scalar" (apl-rho 42) 1)
(apl-test
"at 1"
(apl-at (list 10 20 30) 1)
10)
(apl-test
"at 3"
(apl-at (list 10 20 30) 3)
30)
;; ---------------------------------------------------------------------------
;; 2. Arithmetic — element-wise and rank-polymorphic
;; ---------------------------------------------------------------------------
(apl-test
"add v+v"
(apl-add
(list 1 2 3)
(list 10 20 30))
(list 11 22 33))
(apl-test
"add s+v"
(apl-add 10 (list 1 2 3))
(list 11 12 13))
(apl-test
"add v+s"
(apl-add (list 1 2 3) 100)
(list 101 102 103))
(apl-test "add s+s" (apl-add 3 4) 7)
(apl-test
"sub v-v"
(apl-sub
(list 5 4 3)
(list 1 2 3))
(list 4 2 0))
(apl-test
"mul v*s"
(apl-mul (list 1 2 3) 3)
(list 3 6 9))
(apl-test
"neg -v"
(apl-neg (list 1 -2 3))
(list -1 2 -3))
(apl-test
"abs v"
(apl-abs (list -1 2 -3))
(list 1 2 3))
(apl-test
"floor v"
(apl-floor (list 1.7 2.2 3.9))
(list 1 2 3))
(apl-test
"ceil v"
(apl-ceil (list 1.1 2.5 3))
(list 2 3 3))
(apl-test
"max v v"
(apl-max
(list 1 5 3)
(list 4 2 6))
(list 4 5 6))
(apl-test
"min v v"
(apl-min
(list 1 5 3)
(list 4 2 6))
(list 1 2 3))
;; ---------------------------------------------------------------------------
;; 3. Comparison (returns 0/1)
;; ---------------------------------------------------------------------------
(apl-test "eq 3 3" (apl-eq 3 3) 1)
(apl-test "eq 3 4" (apl-eq 3 4) 0)
(apl-test
"gt v>s"
(apl-gt (list 1 5 3 7) 4)
(list 0 1 0 1))
(apl-test
"lt v<v"
(apl-lt
(list 1 2 3)
(list 3 2 1))
(list 1 0 0))
(apl-test
"le v<=s"
(apl-le (list 3 4 5) 4)
(list 1 1 0))
(apl-test
"ge v>=s"
(apl-ge (list 3 4 5) 4)
(list 0 1 1))
(apl-test
"neq v!=s"
(apl-neq (list 1 2 3) 2)
(list 1 0 1))
;; ---------------------------------------------------------------------------
;; 4. Boolean logic (0/1 values)
;; ---------------------------------------------------------------------------
(apl-test "and 1 1" (apl-and 1 1) 1)
(apl-test "and 1 0" (apl-and 1 0) 0)
(apl-test "or 0 1" (apl-or 0 1) 1)
(apl-test "or 0 0" (apl-or 0 0) 0)
(apl-test "not 0" (apl-not 0) 1)
(apl-test "not 1" (apl-not 1) 0)
(apl-test
"not vec"
(apl-not (list 1 0 1 0))
(list 0 1 0 1))
;; ---------------------------------------------------------------------------
;; 5. Bitwise operations
;; ---------------------------------------------------------------------------
(apl-test "bitand s" (apl-bitand 5 3) 1)
(apl-test "bitor s" (apl-bitor 5 3) 7)
(apl-test "bitxor s" (apl-bitxor 5 3) 6)
(apl-test "bitnot 0" (apl-bitnot 0) -1)
(apl-test "lshift 1 4" (apl-lshift 1 4) 16)
(apl-test "rshift 16 2" (apl-rshift 16 2) 4)
(apl-test
"bitand vec"
(apl-bitand (list 5 6) (list 3 7))
(list 1 6))
(apl-test
"bitor vec"
(apl-bitor (list 5 6) (list 3 7))
(list 7 7))
;; ---------------------------------------------------------------------------
;; 6. Reduction and scan
;; ---------------------------------------------------------------------------
(apl-test
"reduce-add"
(apl-reduce-add
(list 1 2 3 4 5))
15)
(apl-test
"reduce-mul"
(apl-reduce-mul (list 1 2 3 4))
24)
(apl-test
"reduce-max"
(apl-reduce-max
(list 3 1 4 1 5))
5)
(apl-test
"reduce-min"
(apl-reduce-min
(list 3 1 4 1 5))
1)
(apl-test
"reduce-and"
(apl-reduce-and (list 1 1 1))
1)
(apl-test
"reduce-and0"
(apl-reduce-and (list 1 0 1))
0)
(apl-test
"reduce-or"
(apl-reduce-or (list 0 1 0))
1)
(apl-test
"scan-add"
(apl-scan-add (list 1 2 3 4))
(list 1 3 6 10))
(apl-test
"scan-mul"
(apl-scan-mul (list 1 2 3 4))
(list 1 2 6 24))
;; ---------------------------------------------------------------------------
;; 7. Vector manipulation
;; ---------------------------------------------------------------------------
(apl-test
"reverse"
(apl-reverse (list 1 2 3 4))
(list 4 3 2 1))
(apl-test
"cat v v"
(apl-cat (list 1 2) (list 3 4))
(list 1 2 3 4))
(apl-test
"cat v s"
(apl-cat (list 1 2) 3)
(list 1 2 3))
(apl-test
"cat s v"
(apl-cat 1 (list 2 3))
(list 1 2 3))
(apl-test
"cat s s"
(apl-cat 1 2)
(list 1 2))
(apl-test
"take 3"
(apl-take
3
(list 10 20 30 40 50))
(list 10 20 30))
(apl-test
"take 0"
(apl-take 0 (list 1 2 3))
(list))
(apl-test
"take neg"
(apl-take -2 (list 10 20 30))
(list 20 30))
(apl-test
"drop 2"
(apl-drop 2 (list 10 20 30 40))
(list 30 40))
(apl-test
"drop neg"
(apl-drop -1 (list 10 20 30))
(list 10 20))
(apl-test
"rotate 2"
(apl-rotate
2
(list 1 2 3 4 5))
(list 3 4 5 1 2))
(apl-test
"compress"
(apl-compress
(list 1 0 1 0)
(list 10 20 30 40))
(list 10 30))
(apl-test
"index"
(apl-index
(list 10 20 30 40)
(list 2 4))
(list 20 40))
;; ---------------------------------------------------------------------------
;; 8. Set operations
;; ---------------------------------------------------------------------------
(apl-test
"member yes"
(apl-member
(list 1 2 5)
(list 2 4 6))
(list 0 1 0))
(apl-test
"member s"
(apl-member 2 (list 1 2 3))
1)
(apl-test
"member no"
(apl-member 9 (list 1 2 3))
0)
(apl-test
"nub"
(apl-nub (list 1 2 1 3 2))
(list 1 2 3))
(apl-test
"union"
(apl-union
(list 1 2 3)
(list 2 3 4))
(list 1 2 3 4))
(apl-test
"intersect"
(apl-intersect
(list 1 2 3 4)
(list 2 4 6))
(list 2 4))
(apl-test
"without"
(apl-without
(list 1 2 3 4)
(list 2 4))
(list 1 3))
;; ---------------------------------------------------------------------------
;; 9. Format
;; ---------------------------------------------------------------------------
(apl-test
"format vec"
(apl-format (list 1 2 3))
"1 2 3")
(apl-test "format scalar" (apl-format 42) "42")
(apl-test "format empty" (apl-format (list)) "")
;; ---------------------------------------------------------------------------
;; Summary
;; ---------------------------------------------------------------------------
(list apl-test-pass apl-test-fail)

View File

@@ -1,306 +0,0 @@
;; lib/common-lisp/runtime.sx — CL built-ins using SX spec primitives
;;
;; Provides CL-specific wrappers and helpers. Deliberately thin: wherever
;; an SX spec primitive already does the job, we alias it rather than
;; reinventing it.
;;
;; Primitives used from spec:
;; char/char->integer/integer->char/char-upcase/char-downcase
;; format (Phase 21 — must be loaded before this file)
;; gensym (Phase 12)
;; rational/rational? (Phase 16)
;; make-set/set-member?/set-union/etc (Phase 18)
;; open-input-string/read-char/etc (Phase 14)
;; modulo/remainder/quotient/gcd/lcm/expt (Phase 2 / Phase 15)
;; number->string with radix (Phase 15)
;; ---------------------------------------------------------------------------
;; 1. Type predicates
;; ---------------------------------------------------------------------------
(define (cl-null? x) (= x nil))
(define (cl-consp? x) (and (list? x) (not (cl-empty? x))))
(define (cl-listp? x) (or (cl-empty? x) (list? x)))
(define (cl-atom? x) (not (cl-consp? x)))
(define
(cl-numberp? x)
(let ((t (type-of x))) (or (= t "number") (= t "rational"))))
(define cl-integerp? integer?)
(define cl-floatp? float?)
(define cl-rationalp? rational?)
(define (cl-realp? x) (or (integer? x) (float? x) (rational? x)))
(define cl-characterp? char?)
(define cl-stringp? (fn (x) (= (type-of x) "string")))
(define cl-symbolp? (fn (x) (= (type-of x) "symbol")))
(define cl-keywordp? (fn (x) (= (type-of x) "keyword")))
(define
(cl-functionp? x)
(let
((t (type-of x)))
(or
(= t "function")
(= t "lambda")
(= t "native-fn")
(= t "component"))))
(define cl-vectorp? vector?)
(define cl-arrayp? vector?)
;; sx_server: (rest (list x)) returns () not nil — cl-empty? handles both
(define
(cl-empty? x)
(or (nil? x) (and (list? x) (= (len x) 0))))
;; ---------------------------------------------------------------------------
;; 2. Arithmetic — thin aliases to spec primitives
;; ---------------------------------------------------------------------------
(define cl-mod modulo)
(define cl-rem remainder)
(define cl-gcd gcd)
(define cl-lcm lcm)
(define cl-expt expt)
(define cl-floor floor)
(define cl-ceiling ceil)
(define cl-truncate truncate)
(define cl-round round)
(define cl-abs (fn (x) (if (< x 0) (- 0 x) x)))
(define cl-min (fn (a b) (if (< a b) a b)))
(define cl-max (fn (a b) (if (> a b) a b)))
(define cl-quotient quotient)
(define
(cl-signum x)
(cond
((> x 0) 1)
((< x 0) -1)
(else 0)))
(define (cl-evenp? n) (= (modulo n 2) 0))
(define (cl-oddp? n) (= (modulo n 2) 1))
(define (cl-zerop? n) (= n 0))
(define (cl-plusp? n) (> n 0))
(define (cl-minusp? n) (< n 0))
;; ---------------------------------------------------------------------------
;; 3. Character functions — alias spec char primitives + CL name mapping
;; ---------------------------------------------------------------------------
(define cl-char->integer char->integer)
(define cl-integer->char integer->char)
(define cl-char-upcase char-upcase)
(define cl-char-downcase char-downcase)
(define cl-char-code char->integer)
(define cl-code-char integer->char)
(define cl-char=? char=?)
(define cl-char<? char<?)
(define cl-char>? char>?)
(define cl-char<=? char<=?)
(define cl-char>=? char>=?)
(define cl-char-ci=? char-ci=?)
(define cl-char-ci<? char-ci<?)
(define cl-char-ci>? char-ci>?)
;; Inline predicates — char-alphabetic?/char-numeric? unreliable in sx_server
(define
(cl-alpha-char-p c)
(let
((n (char->integer c)))
(or
(and (>= n 65) (<= n 90))
(and (>= n 97) (<= n 122)))))
(define
(cl-digit-char-p c)
(let ((n (char->integer c))) (and (>= n 48) (<= n 57))))
(define
(cl-alphanumericp c)
(let
((n (char->integer c)))
(or
(and (>= n 48) (<= n 57))
(and (>= n 65) (<= n 90))
(and (>= n 97) (<= n 122)))))
(define
(cl-upper-case-p c)
(let ((n (char->integer c))) (and (>= n 65) (<= n 90))))
(define
(cl-lower-case-p c)
(let ((n (char->integer c))) (and (>= n 97) (<= n 122))))
;; Named character constants
(define cl-char-space (integer->char 32))
(define cl-char-newline (integer->char 10))
(define cl-char-tab (integer->char 9))
(define cl-char-backspace (integer->char 8))
(define cl-char-return (integer->char 13))
(define cl-char-null (integer->char 0))
(define cl-char-escape (integer->char 27))
(define cl-char-delete (integer->char 127))
;; ---------------------------------------------------------------------------
;; 4. String + IO — use spec format and ports
;; ---------------------------------------------------------------------------
;; CL format: (cl-format nil "~a ~a" x y) — nil destination means return string
(define
(cl-format dest template &rest args)
(let ((s (apply format (cons template args)))) (if (= dest nil) s s)))
(define cl-write-to-string write-to-string)
(define cl-princ-to-string display-to-string)
;; CL read-from-string: parse value from a string using SX port
(define
(cl-read-from-string s)
(let ((p (open-input-string s))) (read p)))
;; String stream (output)
(define cl-make-string-output-stream open-output-string)
(define cl-get-output-stream-string get-output-string)
;; String stream (input)
(define cl-make-string-input-stream open-input-string)
;; ---------------------------------------------------------------------------
;; 5. Gensym
;; ---------------------------------------------------------------------------
(define cl-gensym gensym)
(define cl-gentemp gensym)
;; ---------------------------------------------------------------------------
;; 6. Multiple values (CL: values / nth-value)
;; ---------------------------------------------------------------------------
(define (cl-values &rest args) {:_values true :_list args})
(define
(cl-call-with-values producer consumer)
(let
((mv (producer)))
(if
(and (dict? mv) (get mv :_values))
(apply consumer (get mv :_list))
(consumer mv))))
(define
(cl-nth-value n mv)
(cond
((and (dict? mv) (get mv :_values))
(let
((lst (get mv :_list)))
(if (>= n (len lst)) nil (nth lst n))))
((= n 0) mv)
(else nil)))
;; ---------------------------------------------------------------------------
;; 7. Sets (CL: adjoin / member / union / intersection / set-difference)
;; ---------------------------------------------------------------------------
(define cl-make-set make-set)
(define cl-set? set?)
(define cl-set-add set-add!)
(define cl-set-memberp set-member?)
(define cl-set-remove set-remove!)
(define cl-set-union set-union)
(define cl-set-intersect set-intersection)
(define cl-set-difference set-difference)
(define cl-list->set list->set)
(define cl-set->list set->list)
;; CL: (member item list) — returns tail starting at item, or nil
(define
(cl-member item lst)
(cond
((cl-empty? lst) nil)
((equal? item (first lst)) lst)
(else (cl-member item (rest lst)))))
;; CL: (adjoin item list) — cons only if not already present
(define (cl-adjoin item lst) (if (cl-member item lst) lst (cons item lst)))
;; ---------------------------------------------------------------------------
;; 8. Radix formatting (CL: (write-to-string n :base radix))
;; ---------------------------------------------------------------------------
(define (cl-integer-to-string n radix) (number->string n radix))
(define (cl-string-to-integer s radix) (string->number s radix))
;; CL ~R directive helpers
(define (cl-format-binary n) (number->string n 2))
(define (cl-format-octal n) (number->string n 8))
(define (cl-format-hex n) (number->string n 16))
(define (cl-format-decimal n) (number->string n 10))
;; ---------------------------------------------------------------------------
;; 9. List utilities — cl-empty? guards against () from rest
;; ---------------------------------------------------------------------------
(define
(cl-last lst)
(cond
((cl-empty? lst) nil)
((cl-empty? (rest lst)) lst)
(else (cl-last (rest lst)))))
(define
(cl-butlast lst)
(if
(or (cl-empty? lst) (cl-empty? (rest lst)))
nil
(cons (first lst) (cl-butlast (rest lst)))))
(define
(cl-nthcdr n lst)
(if (= n 0) lst (cl-nthcdr (- n 1) (rest lst))))
(define (cl-nth n lst) (first (cl-nthcdr n lst)))
(define (cl-list-length lst) (len lst))
(define
(cl-copy-list lst)
(if (cl-empty? lst) nil (cons (first lst) (cl-copy-list (rest lst)))))
(define
(cl-flatten lst)
(cond
((cl-empty? lst) nil)
((list? (first lst))
(append (cl-flatten (first lst)) (cl-flatten (rest lst))))
(else (cons (first lst) (cl-flatten (rest lst))))))
;; CL: (assoc key alist) — returns matching pair or nil
(define
(cl-assoc key alist)
(cond
((cl-empty? alist) nil)
((equal? key (first (first alist))) (first alist))
(else (cl-assoc key (rest alist)))))
;; CL: (rassoc val alist) — reverse assoc (match on second element)
(define
(cl-rassoc val alist)
(cond
((cl-empty? alist) nil)
((equal? val (first (rest (first alist)))) (first alist))
(else (cl-rassoc val (rest alist)))))
;; CL: (getf plist key) — property list lookup
(define
(cl-getf plist key)
(cond
((or (cl-empty? plist) (cl-empty? (rest plist))) nil)
((equal? (first plist) key) (first (rest plist)))
(else (cl-getf (rest (rest plist)) key))))

View File

@@ -1,302 +0,0 @@
#!/usr/bin/env bash
# lib/common-lisp/test.sh — quick smoke-test the CL runtime layer.
# Uses sx_server.exe epoch protocol (same as lib/lua/test.sh).
#
# Usage:
# bash lib/common-lisp/test.sh
# bash lib/common-lisp/test.sh -v
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
exit 1
fi
VERBOSE="${1:-}"
PASS=0; FAIL=0; ERRORS=""
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/common-lisp/runtime.sx")
;; --- Type predicates ---
(epoch 10)
(eval "(cl-null? nil)")
(epoch 11)
(eval "(cl-null? false)")
(epoch 12)
(eval "(cl-consp? (list 1 2))")
(epoch 13)
(eval "(cl-consp? nil)")
(epoch 14)
(eval "(cl-listp? nil)")
(epoch 15)
(eval "(cl-listp? (list 1))")
(epoch 16)
(eval "(cl-atom? nil)")
(epoch 17)
(eval "(cl-atom? (list 1))")
(epoch 18)
(eval "(cl-integerp? 42)")
(epoch 19)
(eval "(cl-floatp? 3.14)")
(epoch 20)
(eval "(cl-characterp? (integer->char 65))")
(epoch 21)
(eval "(cl-stringp? \"hello\")")
;; --- Arithmetic ---
(epoch 30)
(eval "(cl-mod 10 3)")
(epoch 31)
(eval "(cl-rem 10 3)")
(epoch 32)
(eval "(cl-quotient 10 3)")
(epoch 33)
(eval "(cl-gcd 12 8)")
(epoch 34)
(eval "(cl-lcm 4 6)")
(epoch 35)
(eval "(cl-abs -5)")
(epoch 36)
(eval "(cl-abs 5)")
(epoch 37)
(eval "(cl-min 2 7)")
(epoch 38)
(eval "(cl-max 2 7)")
(epoch 39)
(eval "(cl-evenp? 4)")
(epoch 40)
(eval "(cl-evenp? 3)")
(epoch 41)
(eval "(cl-oddp? 7)")
(epoch 42)
(eval "(cl-zerop? 0)")
(epoch 43)
(eval "(cl-plusp? 1)")
(epoch 44)
(eval "(cl-minusp? -1)")
(epoch 45)
(eval "(cl-signum 42)")
(epoch 46)
(eval "(cl-signum -7)")
(epoch 47)
(eval "(cl-signum 0)")
;; --- Characters ---
(epoch 50)
(eval "(cl-char-code (integer->char 65))")
(epoch 51)
(eval "(char? (cl-code-char 65))")
(epoch 52)
(eval "(cl-char=? (integer->char 65) (integer->char 65))")
(epoch 53)
(eval "(cl-char<? (integer->char 65) (integer->char 90))")
(epoch 54)
(eval "(cl-char-code cl-char-space)")
(epoch 55)
(eval "(cl-char-code cl-char-newline)")
(epoch 56)
(eval "(cl-alpha-char-p (integer->char 65))")
(epoch 57)
(eval "(cl-digit-char-p (integer->char 48))")
;; --- Format ---
(epoch 60)
(eval "(cl-format nil \"hello\")")
(epoch 61)
(eval "(cl-format nil \"~a\" \"world\")")
(epoch 62)
(eval "(cl-format nil \"~d\" 42)")
(epoch 63)
(eval "(cl-format nil \"~x\" 255)")
(epoch 64)
(eval "(cl-format nil \"x=~d y=~d\" 3 4)")
;; --- Gensym ---
(epoch 70)
(eval "(= (type-of (cl-gensym)) \"symbol\")")
(epoch 71)
(eval "(not (= (cl-gensym) (cl-gensym)))")
;; --- Sets ---
(epoch 80)
(eval "(cl-set? (cl-make-set))")
(epoch 81)
(eval "(let ((s (cl-make-set))) (do (cl-set-add s 1) (cl-set-memberp s 1)))")
(epoch 82)
(eval "(cl-set-memberp (cl-make-set) 42)")
(epoch 83)
(eval "(cl-set-memberp (cl-list->set (list 1 2 3)) 2)")
;; --- Lists ---
(epoch 90)
(eval "(cl-nth 0 (list 1 2 3))")
(epoch 91)
(eval "(cl-nth 2 (list 1 2 3))")
(epoch 92)
(eval "(cl-last (list 1 2 3))")
(epoch 93)
(eval "(cl-butlast (list 1 2 3))")
(epoch 94)
(eval "(cl-nthcdr 1 (list 1 2 3))")
(epoch 95)
(eval "(cl-assoc \"b\" (list (list \"a\" 1) (list \"b\" 2)))")
(epoch 96)
(eval "(cl-assoc \"z\" (list (list \"a\" 1)))")
(epoch 97)
(eval "(cl-getf (list \"x\" 42 \"y\" 99) \"x\")")
(epoch 98)
(eval "(cl-adjoin 0 (list 1 2))")
(epoch 99)
(eval "(cl-adjoin 1 (list 1 2))")
(epoch 100)
(eval "(cl-member 2 (list 1 2 3))")
(epoch 101)
(eval "(cl-member 9 (list 1 2 3))")
(epoch 102)
(eval "(cl-flatten (list 1 (list 2 3) 4))")
;; --- Radix ---
(epoch 110)
(eval "(cl-format-binary 10)")
(epoch 111)
(eval "(cl-format-octal 15)")
(epoch 112)
(eval "(cl-format-hex 255)")
(epoch 113)
(eval "(cl-format-decimal 42)")
(epoch 114)
(eval "(cl-integer-to-string 31 16)")
(epoch 115)
(eval "(cl-string-to-integer \"1f\" 16)")
EPOCHS
OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
check() {
local epoch="$1" desc="$2" expected="$3"
local actual
# ok-len format: value appears on the line AFTER "(ok-len N length)"
actual=$(echo "$OUTPUT" | grep -A1 "^(ok-len $epoch " | tail -1 || true)
# strip any leading "(ok-len ...)" if grep -A1 returned it instead
if echo "$actual" | grep -q "^(ok-len"; then actual=""; fi
if [ -z "$actual" ]; then
actual=$(echo "$OUTPUT" | grep "^(ok $epoch " | head -1 || true)
fi
if [ -z "$actual" ]; then
actual=$(echo "$OUTPUT" | grep "^(error $epoch " | head -1 || true)
fi
[ -z "$actual" ] && actual="<no output for epoch $epoch>"
if echo "$actual" | grep -qF -- "$expected"; then
PASS=$((PASS+1))
[ "$VERBOSE" = "-v" ] && echo " ok $desc"
else
FAIL=$((FAIL+1))
ERRORS+=" FAIL [$desc] (epoch $epoch) expected: $expected | actual: $actual
"
fi
}
# Type predicates
check 10 "cl-null? nil" "true"
check 11 "cl-null? false" "false"
check 12 "cl-consp? pair" "true"
check 13 "cl-consp? nil" "false"
check 14 "cl-listp? nil" "true"
check 15 "cl-listp? list" "true"
check 16 "cl-atom? nil" "true"
check 17 "cl-atom? pair" "false"
check 18 "cl-integerp?" "true"
check 19 "cl-floatp?" "true"
check 20 "cl-characterp?" "true"
check 21 "cl-stringp?" "true"
# Arithmetic
check 30 "cl-mod 10 3" "1"
check 31 "cl-rem 10 3" "1"
check 32 "cl-quotient 10 3" "3"
check 33 "cl-gcd 12 8" "4"
check 34 "cl-lcm 4 6" "12"
check 35 "cl-abs -5" "5"
check 36 "cl-abs 5" "5"
check 37 "cl-min 2 7" "2"
check 38 "cl-max 2 7" "7"
check 39 "cl-evenp? 4" "true"
check 40 "cl-evenp? 3" "false"
check 41 "cl-oddp? 7" "true"
check 42 "cl-zerop? 0" "true"
check 43 "cl-plusp? 1" "true"
check 44 "cl-minusp? -1" "true"
check 45 "cl-signum pos" "1"
check 46 "cl-signum neg" "-1"
check 47 "cl-signum zero" "0"
# Characters
check 50 "cl-char-code" "65"
check 51 "code-char returns char" "true"
check 52 "cl-char=?" "true"
check 53 "cl-char<?" "true"
check 54 "cl-char-space code" "32"
check 55 "cl-char-newline code" "10"
check 56 "cl-alpha-char-p A" "true"
check 57 "cl-digit-char-p 0" "true"
# Format
check 60 "cl-format plain" '"hello"'
check 61 "cl-format ~a" '"world"'
check 62 "cl-format ~d" '"42"'
check 63 "cl-format ~x" '"ff"'
check 64 "cl-format multi" '"x=3 y=4"'
# Gensym
check 70 "gensym returns symbol" "true"
check 71 "gensyms are unique" "true"
# Sets
check 80 "make-set is set?" "true"
check 81 "set-add + member" "true"
check 82 "member in empty" "false"
check 83 "list->set member" "true"
# Lists
check 90 "cl-nth 0" "1"
check 91 "cl-nth 2" "3"
check 92 "cl-last" "(3)"
check 93 "cl-butlast" "(1 2)"
check 94 "cl-nthcdr 1" "(2 3)"
check 95 "cl-assoc hit" '("b" 2)'
check 96 "cl-assoc miss" "nil"
check 97 "cl-getf hit" "42"
check 98 "cl-adjoin new" "(0 1 2)"
check 99 "cl-adjoin dup" "(1 2)"
check 100 "cl-member hit" "(2 3)"
check 101 "cl-member miss" "nil"
check 102 "cl-flatten" "(1 2 3 4)"
# Radix
check 110 "cl-format-binary 10" '"1010"'
check 111 "cl-format-octal 15" '"17"'
check 112 "cl-format-hex 255" '"ff"'
check 113 "cl-format-decimal 42" '"42"'
check 114 "n->s base 16" '"1f"'
check 115 "s->n base 16" "31"
TOTAL=$((PASS+FAIL))
if [ $FAIL -eq 0 ]; then
echo "ok $PASS/$TOTAL lib/common-lisp tests passed"
else
echo "FAIL $PASS/$TOTAL passed, $FAIL failed:"
echo "$ERRORS"
fi
[ $FAIL -eq 0 ]

View File

@@ -1,230 +0,0 @@
;; lib/erlang/runtime.sx — Erlang BIFs and stdlib wrappers on SX primitives
;;
;; Provides Erlang-idiomatic wrappers. Thin where spec primitives match;
;; inline where Erlang semantics differ (e.g. rem sign, integer division).
;;
;; Primitives used from spec:
;; integer?/float? (Phase 2)
;; remainder/quotient (Phase 2 / Phase 15)
;; bitwise-and/or/xor/not (Phase 7)
;; arithmetic-shift (Phase 7)
;; make-set/set-add!/etc (Phase 18)
;; make-regexp/regexp-match/etc (Phase 20)
;; gcd (Phase 15)
;; ---------------------------------------------------------------------------
;; 1. Numeric tower — type predicates + conversions
;; ---------------------------------------------------------------------------
(define er-is-integer? integer?)
(define er-is-float? float?)
(define (er-is-number? x) (or (integer? x) (float? x)))
(define (er-is-atom? x) (= (type-of x) "symbol"))
(define er-is-list? list?)
(define er-is-binary? bytevector?)
;; Erlang float/1 coerces an integer to float
(define (er-float x) (* 1 x))
;; Erlang trunc/1 — truncate toward zero
(define er-trunc truncate)
;; Erlang round/1 — round to nearest integer
(define er-round round)
;; Erlang abs/1
(define er-abs abs)
;; Erlang max/min (BIFs in OTP 26)
(define (er-max a b) (if (>= a b) a b))
(define (er-min a b) (if (<= a b) a b))
;; ---------------------------------------------------------------------------
;; 2. Integer arithmetic — div + rem (Erlang semantics)
;; ---------------------------------------------------------------------------
;; Erlang div: integer division truncating toward zero
(define er-div quotient)
;; Erlang rem: remainder with sign of dividend (matches remainder primitive)
(define er-rem remainder)
;; Erlang gcd (non-standard BIF but useful)
(define er-gcd gcd)
;; ---------------------------------------------------------------------------
;; 3. Bitwise ops — band / bor / bxor / bnot / bsl / bsr
;; ---------------------------------------------------------------------------
(define er-band bitwise-and)
(define er-bor bitwise-or)
(define er-bxor bitwise-xor)
(define er-bnot bitwise-not)
;; bsl: bit shift left by N positions
(define (er-bsl x n) (arithmetic-shift x n))
;; bsr: bit shift right by N positions
(define (er-bsr x n) (arithmetic-shift x (- 0 n)))
;; ---------------------------------------------------------------------------
;; 4. Sets module — thin wrappers matching Erlang sets API
;; ---------------------------------------------------------------------------
(define er-sets-new make-set)
(define er-sets-add-element set-add!)
(define er-sets-is-element set-member?)
(define er-sets-del-element set-remove!)
(define er-sets-union set-union)
(define er-sets-intersection set-intersection)
(define er-sets-subtract set-difference)
(define er-sets-to-list set->list)
(define er-sets-from-list list->set)
(define (er-sets-size s) (len (set->list s)))
(define (er-sets-is-set? x) (set? x))
;; ---------------------------------------------------------------------------
;; 5. Regexp — re module wrappers
;; ---------------------------------------------------------------------------
;; er-re-run: returns match dict or nil (no match)
(define
(er-re-run subject pattern)
(regexp-match (make-regexp pattern) subject))
;; er-re-replace: replace first match
(define
(er-re-replace subject pattern replacement)
(regexp-replace (make-regexp pattern) subject replacement))
;; er-re-replace-all: global replace
(define
(er-re-replace-all subject pattern replacement)
(regexp-replace-all (make-regexp pattern) subject replacement))
;; er-re-match-groups: extract capture groups from a match result
(define (er-re-match-groups m) (if (= m nil) nil (get m :groups)))
;; er-re-split: split string on regexp delimiter
(define
(er-re-split subject pattern)
(let
((re (make-regexp pattern))
(ms (regexp-match-all (make-regexp pattern) subject)))
(if
(= (len ms) 0)
(list subject)
(letrec
((go (fn (matches pos acc) (if (= (len matches) 0) (append acc (list (substring subject pos (len subject)))) (let ((m (first matches)) (start (get (first matches) :start)) (end (get (first matches) :end))) (go (rest matches) end (append acc (list (substring subject pos start)))))))))
(go ms 0 (list))))))
;; ---------------------------------------------------------------------------
;; 6. List BIFs — hd/tl/length + lists module
;; ---------------------------------------------------------------------------
(define (er-hd lst) (first lst))
(define (er-tl lst) (rest lst))
(define (er-length lst) (len lst))
;; lists:member/2
(define
(er-lists-member elem lst)
(cond
((= (len lst) 0) false)
((= elem (first lst)) true)
(else (er-lists-member elem (rest lst)))))
;; lists:reverse/1
(define er-lists-reverse reverse)
;; lists:append/2
(define er-lists-append append)
;; lists:flatten/1
(define
(er-lists-flatten lst)
(cond
((= (len lst) 0) (list))
((list? (first lst))
(append (er-lists-flatten (first lst)) (er-lists-flatten (rest lst))))
(else (cons (first lst) (er-lists-flatten (rest lst))))))
;; lists:nth/2 — 1-indexed
(define (er-lists-nth n lst) (nth lst (- n 1)))
;; lists:map/2
(define er-lists-map map)
;; lists:filter/2
(define er-lists-filter filter)
;; lists:foldl/3 — (Fun, Acc0, List)
(define
(er-lists-foldl f acc lst)
(if
(= (len lst) 0)
acc
(er-lists-foldl f (f (first lst) acc) (rest lst))))
;; lists:foldr/3
(define
(er-lists-foldr f acc lst)
(if
(= (len lst) 0)
acc
(f (first lst) (er-lists-foldr f acc (rest lst)))))
;; lists:zip/2
(define
(er-lists-zip a b)
(if
(or (= (len a) 0) (= (len b) 0))
(list)
(cons (list (first a) (first b)) (er-lists-zip (rest a) (rest b)))))
;; lists:seq/2 — generate integer range (1-indexed like Erlang)
(define
(er-lists-seq from to)
(if
(> from to)
(list)
(cons from (er-lists-seq (+ from 1) to))))
;; ---------------------------------------------------------------------------
;; 7. Type conversion BIFs
;; ---------------------------------------------------------------------------
;; atom_to_list/1 — convert atom (symbol) to its name string
(define (er-atom-to-list a) (symbol->string a))
;; list_to_atom/1 — convert string to atom (symbol)
(define (er-list-to-atom s) (make-symbol s))
;; integer_to_list/1
(define (er-integer-to-list n) (str n))
;; list_to_integer/1
(define (er-list-to-integer s) (truncate (parse-number s)))
;; float_to_list/1
(define (er-float-to-list f) (str f))
;; list_to_float/1
(define (er-list-to-float s) (* 1 (parse-number s)))
;; integer_to_list/2 — with radix (e.g. 16 for hex)
(define (er-integer-to-list-radix n radix) (number->string n radix))
;; ---------------------------------------------------------------------------
;; 8. ok/error tuple helpers — Erlang idiom {ok, Val} / {error, Reason}
;; ---------------------------------------------------------------------------
(define (er-ok val) (list "ok" val))
(define (er-error reason) (list "error" reason))
(define
(er-is-ok? t)
(and (list? t) (= (len t) 2) (= (first t) "ok")))
(define
(er-is-error? t)
(and (list? t) (= (len t) 2) (= (first t) "error")))
(define (er-unwrap t) (nth t 1))

View File

@@ -1,260 +0,0 @@
#!/usr/bin/env bash
# lib/erlang/test.sh — smoke-test the Erlang runtime layer.
# Uses sx_server.exe epoch protocol.
#
# Usage:
# bash lib/erlang/test.sh
# bash lib/erlang/test.sh -v
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
exit 1
fi
VERBOSE="${1:-}"
PASS=0; FAIL=0; ERRORS=""
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "lib/erlang/runtime.sx")
;; --- Numeric tower ---
(epoch 10)
(eval "(er-is-integer? 42)")
(epoch 11)
(eval "(er-is-integer? 3.14)")
(epoch 12)
(eval "(er-is-float? 3.14)")
(epoch 13)
(eval "(er-is-float? 42)")
(epoch 14)
(eval "(er-is-number? 42)")
(epoch 15)
(eval "(er-is-number? 3.14)")
(epoch 16)
(eval "(er-float 5)")
(epoch 17)
(eval "(er-trunc 3.9)")
(epoch 18)
(eval "(er-round 3.5)")
(epoch 19)
(eval "(er-abs -7)")
(epoch 20)
(eval "(er-max 3 7)")
(epoch 21)
(eval "(er-min 3 7)")
;; --- div + rem ---
(epoch 30)
(eval "(er-div 10 3)")
(epoch 31)
(eval "(er-div -10 3)")
(epoch 32)
(eval "(er-rem 10 3)")
(epoch 33)
(eval "(er-rem -10 3)")
(epoch 34)
(eval "(er-gcd 12 8)")
;; --- Bitwise ---
(epoch 40)
(eval "(er-band 12 10)")
(epoch 41)
(eval "(er-bor 12 10)")
(epoch 42)
(eval "(er-bxor 12 10)")
(epoch 43)
(eval "(er-bnot 0)")
(epoch 44)
(eval "(er-bsl 1 4)")
(epoch 45)
(eval "(er-bsr 16 2)")
;; --- Sets ---
(epoch 50)
(eval "(er-sets-is-set? (er-sets-new))")
(epoch 51)
(eval "(let ((s (er-sets-new))) (do (er-sets-add-element s 1) (er-sets-is-element s 1)))")
(epoch 52)
(eval "(er-sets-is-element (er-sets-new) 42)")
(epoch 53)
(eval "(er-sets-is-element (er-sets-from-list (list 1 2 3)) 2)")
(epoch 54)
(eval "(er-sets-size (er-sets-from-list (list 1 2 3)))")
(epoch 55)
(eval "(len (er-sets-to-list (er-sets-from-list (list 1 2 3))))")
;; --- Regexp ---
(epoch 60)
(eval "(not (= (er-re-run \"hello\" \"ll\") nil))")
(epoch 61)
(eval "(= (er-re-run \"hello\" \"xyz\") nil)")
(epoch 62)
(eval "(get (er-re-run \"hello\" \"ll\") :match)")
(epoch 63)
(eval "(er-re-replace \"hello\" \"l\" \"r\")")
(epoch 64)
(eval "(er-re-replace-all \"hello\" \"l\" \"r\")")
(epoch 65)
(eval "(er-re-match-groups (er-re-run \"hello world\" \"(\\w+)\\s+(\\w+)\"))")
(epoch 66)
(eval "(len (er-re-split \"a,b,c\" \",\"))")
;; --- List BIFs ---
(epoch 70)
(eval "(er-hd (list 1 2 3))")
(epoch 71)
(eval "(er-tl (list 1 2 3))")
(epoch 72)
(eval "(er-length (list 1 2 3))")
(epoch 73)
(eval "(er-lists-member 2 (list 1 2 3))")
(epoch 74)
(eval "(er-lists-member 9 (list 1 2 3))")
(epoch 75)
(eval "(er-lists-reverse (list 1 2 3))")
(epoch 76)
(eval "(er-lists-nth 2 (list 10 20 30))")
(epoch 77)
(eval "(er-lists-foldl + 0 (list 1 2 3 4 5))")
(epoch 78)
(eval "(er-lists-seq 1 5)")
(epoch 79)
(eval "(er-lists-flatten (list 1 (list 2 3) (list 4 (list 5))))")
;; --- Type conversions ---
(epoch 80)
(eval "(er-integer-to-list 42)")
(epoch 81)
(eval "(er-list-to-integer \"42\")")
(epoch 82)
(eval "(er-integer-to-list-radix 255 16)")
(epoch 83)
(eval "(er-atom-to-list (make-symbol \"hello\"))")
(epoch 84)
(eval "(= (type-of (er-list-to-atom \"foo\")) \"symbol\")")
;; --- ok/error tuples ---
(epoch 90)
(eval "(er-is-ok? (er-ok 42))")
(epoch 91)
(eval "(er-is-error? (er-error \"reason\"))")
(epoch 92)
(eval "(er-unwrap (er-ok 42))")
(epoch 93)
(eval "(er-is-ok? (er-error \"bad\"))")
EPOCHS
OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
check() {
local epoch="$1" desc="$2" expected="$3"
local actual
actual=$(echo "$OUTPUT" | grep -A1 "^(ok-len $epoch " | tail -1 || true)
if echo "$actual" | grep -q "^(ok-len"; then actual=""; fi
if [ -z "$actual" ]; then
actual=$(echo "$OUTPUT" | grep "^(ok $epoch " | head -1 || true)
fi
if [ -z "$actual" ]; then
actual=$(echo "$OUTPUT" | grep "^(error $epoch " | head -1 || true)
fi
[ -z "$actual" ] && actual="<no output for epoch $epoch>"
if echo "$actual" | grep -qF -- "$expected"; then
PASS=$((PASS+1))
[ "$VERBOSE" = "-v" ] && echo " ok $desc"
else
FAIL=$((FAIL+1))
ERRORS+=" FAIL [$desc] (epoch $epoch) expected: $expected | actual: $actual
"
fi
}
# Numeric tower
check 10 "is-integer? 42" "true"
check 11 "is-integer? float" "false"
check 12 "is-float? 3.14" "true"
check 13 "is-float? int" "false"
check 14 "is-number? int" "true"
check 15 "is-number? float" "true"
check 16 "float 5" "5"
check 17 "trunc 3.9" "3"
check 18 "round 3.5" "4"
check 19 "abs -7" "7"
check 20 "max 3 7" "7"
check 21 "min 3 7" "3"
# div + rem
check 30 "div 10 3" "3"
check 31 "div -10 3" "-3"
check 32 "rem 10 3" "1"
check 33 "rem -10 3" "-1"
check 34 "gcd 12 8" "4"
# Bitwise
check 40 "band 12 10" "8"
check 41 "bor 12 10" "14"
check 42 "bxor 12 10" "6"
check 43 "bnot 0" "-1"
check 44 "bsl 1 4" "16"
check 45 "bsr 16 2" "4"
# Sets
check 50 "sets-new is-set?" "true"
check 51 "sets add+member" "true"
check 52 "member empty" "false"
check 53 "from-list member" "true"
check 54 "sets-size" "3"
check 55 "sets-to-list len" "3"
# Regexp
check 60 "re-run match" "true"
check 61 "re-run no match" "true"
check 62 "re-run match text" '"ll"'
check 63 "re-replace first" '"herlo"'
check 64 "re-replace-all" '"herro"'
check 65 "re-match-groups" '"hello"'
check 66 "re-split count" "3"
# List BIFs
check 70 "hd" "1"
check 71 "tl" "(2 3)"
check 72 "length" "3"
check 73 "member hit" "true"
check 74 "member miss" "false"
check 75 "reverse" "(3 2 1)"
check 76 "nth 2" "20"
check 77 "foldl sum" "15"
check 78 "seq 1..5" "(1 2 3 4 5)"
check 79 "flatten" "(1 2 3 4 5)"
# Type conversions
check 80 "integer-to-list" '"42"'
check 81 "list-to-integer" "42"
check 82 "integer-to-list hex" '"ff"'
check 83 "atom-to-list" '"hello"'
check 84 "list-to-atom" "true"
# ok/error
check 90 "ok? ok-tuple" "true"
check 91 "error? error-tuple" "true"
check 92 "unwrap ok" "42"
check 93 "ok? error-tuple" "false"
TOTAL=$((PASS+FAIL))
if [ $FAIL -eq 0 ]; then
echo "ok $PASS/$TOTAL lib/erlang tests passed"
else
echo "FAIL $PASS/$TOTAL passed, $FAIL failed:"
echo "$ERRORS"
fi
[ $FAIL -eq 0 ]

View File

@@ -1,175 +1,433 @@
;; lib/forth/runtime.sx — Forth primitives on SX
;;
;; Provides Forth-idiomatic wrappers over SX built-ins.
;; Primitives used:
;; bitwise-and/or/xor/not/arithmetic-shift/bit-count (Phase 7)
;; make-bytevector/bytevector-u8-ref/u8-set!/... (Phase 20)
;; quotient/remainder/modulo (Phase 15 / builtin)
;;
;; Naming: SX identifiers can't include @ or !-alone, so Forth words are:
;; C@ → forth-cfetch C! → forth-cstore
;; @ → forth-fetch ! → forth-store
;; ---------------------------------------------------------------------------
;; 1. Bitwise operations — Forth core words
;; Forth TRUE = -1 (all bits set), FALSE = 0.
;; All ops coerce to integer via truncate.
;; ---------------------------------------------------------------------------
(define (forth-and a b) (bitwise-and (truncate a) (truncate b)))
(define (forth-or a b) (bitwise-or (truncate a) (truncate b)))
(define (forth-xor a b) (bitwise-xor (truncate a) (truncate b)))
;; INVERT — bitwise NOT (Forth NOT is logical; INVERT is bitwise)
(define (forth-invert a) (bitwise-not (truncate a)))
;; LSHIFT RSHIFT — n bit — shift a by n positions
(define (forth-lshift a n) (arithmetic-shift (truncate a) (truncate n)))
(define
(forth-rshift a n)
(arithmetic-shift (truncate a) (- 0 (truncate n))))
;; 2* 2/ — multiply/divide by 2 via bit shift
(define (forth-2* a) (arithmetic-shift (truncate a) 1))
(define (forth-2/ a) (arithmetic-shift (truncate a) -1))
;; BIT-COUNT — number of set bits (Kernighan popcount)
(define (forth-bit-count a) (bit-count (truncate a)))
;; INTEGER-LENGTH — index of highest set bit (0 for zero)
(define (forth-integer-length a) (integer-length (truncate a)))
;; WITHIN — ( u ul uh -- flag ) true if ul <= u < uh
(define (forth-within u ul uh) (and (>= u ul) (< u uh)))
;; Arithmetic complements commonly used alongside bitwise ops
(define (forth-negate a) (- 0 (truncate a)))
(define (forth-abs a) (abs (truncate a)))
(define (forth-min a b) (if (< a b) a b))
(define (forth-max a b) (if (> a b) a b))
(define (forth-mod a b) (modulo (truncate a) (truncate b)))
;; /MOD — ( n1 n2 -- rem quot ) returns list (remainder quotient)
(define
(forth-divmod a b)
(list
(remainder (truncate a) (truncate b))
(quotient (truncate a) (truncate b))))
;; ---------------------------------------------------------------------------
;; 2. String buffer — word-definition / string accumulation
;; EMIT appends one char; TYPE appends a string.
;; Value is retrieved with forth-sb-value.
;; ---------------------------------------------------------------------------
;; Forth runtime — state, stacks, dictionary, output buffer.
;; Data stack: mutable SX list, TOS = first.
;; Return stack: separate mutable list.
;; Dictionary: SX dict {lowercased-name -> word-record}.
;; Word record: {"kind" "body" "immediate?"}; kind is "primitive" or "colon-def".
;; Output buffer: mutable string appended to by `.`, `EMIT`, `CR`, etc.
;; Compile-mode flag: "compiling" on the state.
(define
(forth-sb-new)
(let
((sb (dict)))
(dict-set! sb "_forth_sb" true)
(dict-set! sb "_chars" (list))
sb))
(define (forth-sb? v) (and (dict? v) (dict-has? v "_forth_sb")))
;; EMIT — append one character
(define
(forth-sb-emit! sb c)
(dict-set! sb "_chars" (append (get sb "_chars") (list c)))
sb)
;; TYPE — append a string
(define
(forth-sb-type! sb s)
(dict-set! sb "_chars" (append (get sb "_chars") (string->list s)))
sb)
(define (forth-sb-value sb) (list->string (get sb "_chars")))
(define (forth-sb-length sb) (len (get sb "_chars")))
(define (forth-sb-clear! sb) (dict-set! sb "_chars" (list)) sb)
;; Emit integer as decimal digits
(define (forth-sb-emit-int! sb n) (forth-sb-type! sb (str (truncate n))))
;; ---------------------------------------------------------------------------
;; 3. Memory / Bytevectors — Forth raw memory model
;; ALLOT allocates a bytevector. Byte and cell (32-bit LE) access.
;; ---------------------------------------------------------------------------
;; ALLOT — allocate n bytes zero-initialised
(define (forth-mem-new n) (make-bytevector (truncate n) 0))
(define (forth-mem? v) (bytevector? v))
(define (forth-mem-size v) (bytevector-length v))
;; C@ C! — byte fetch/store
(define (forth-cfetch mem addr) (bytevector-u8-ref mem (truncate addr)))
forth-make-state
(fn
()
(let
((s (dict)))
(dict-set! s "dstack" (list))
(dict-set! s "rstack" (list))
(dict-set! s "dict" (dict))
(dict-set! s "output" "")
(dict-set! s "compiling" false)
(dict-set! s "current-def" nil)
(dict-set! s "base" 10)
(dict-set! s "vars" (dict))
s)))
(define
(forth-cstore mem addr val)
(bytevector-u8-set!
mem
(truncate addr)
(modulo (truncate val) 256))
mem)
;; @ ! — 32-bit little-endian cell fetch/store
(define
(forth-fetch mem addr)
(let
((a (truncate addr)))
(+
(bytevector-u8-ref mem a)
(* 256 (bytevector-u8-ref mem (+ a 1)))
(* 65536 (bytevector-u8-ref mem (+ a 2)))
(* 16777216 (bytevector-u8-ref mem (+ a 3))))))
forth-error
(fn (state msg) (dict-set! state "error" msg) (raise msg)))
(define
(forth-store mem addr val)
(let
((a (truncate addr)) (v (truncate val)))
(bytevector-u8-set! mem a (modulo v 256))
(bytevector-u8-set!
mem
(+ a 1)
(modulo (quotient v 256) 256))
(bytevector-u8-set!
mem
(+ a 2)
(modulo (quotient v 65536) 256))
(bytevector-u8-set!
mem
(+ a 3)
(modulo (quotient v 16777216) 256)))
mem)
forth-push
(fn (state v) (dict-set! state "dstack" (cons v (get state "dstack")))))
;; MOVE — copy count bytes from src[src-addr] to dst[dst-addr]
(define
(forth-move! src src-addr dst dst-addr count)
(letrec
((go (fn (i) (when (< i (truncate count)) (bytevector-u8-set! dst (+ (truncate dst-addr) i) (bytevector-u8-ref src (+ (truncate src-addr) i))) (go (+ i 1))))))
(go 0))
dst)
forth-pop
(fn
(state)
(let
((st (get state "dstack")))
(if
(= (len st) 0)
(forth-error state "stack underflow")
(let ((top (first st))) (dict-set! state "dstack" (rest st)) top)))))
;; FILL — fill count bytes at addr with byte value
(define
(forth-fill! mem addr count byte)
(letrec
((go (fn (i) (when (< i (truncate count)) (bytevector-u8-set! mem (+ (truncate addr) i) (modulo (truncate byte) 256)) (go (+ i 1))))))
(go 0))
mem)
forth-peek
(fn
(state)
(let
((st (get state "dstack")))
(if (= (len st) 0) (forth-error state "stack underflow") (first st)))))
;; ERASE — fill with zeros (Forth: ERASE)
(define
(forth-erase! mem addr count)
(forth-fill! mem addr count 0))
(define forth-depth (fn (state) (len (get state "dstack"))))
;; Dump memory region as list of byte values
(define
(forth-mem->list mem addr count)
(letrec
((go (fn (i acc) (if (= i 0) acc (go (- i 1) (cons (bytevector-u8-ref mem (+ (truncate addr) (- i 1))) acc))))))
(go (truncate count) (list))))
forth-rpush
(fn (state v) (dict-set! state "rstack" (cons v (get state "rstack")))))
(define
forth-rpop
(fn
(state)
(let
((st (get state "rstack")))
(if
(= (len st) 0)
(forth-error state "return stack underflow")
(let ((top (first st))) (dict-set! state "rstack" (rest st)) top)))))
(define
forth-rpeek
(fn
(state)
(let
((st (get state "rstack")))
(if
(= (len st) 0)
(forth-error state "return stack underflow")
(first st)))))
(define
forth-emit-str
(fn (state s) (dict-set! state "output" (str (get state "output") s))))
(define
forth-make-word
(fn
(kind body immediate?)
(let
((w (dict)))
(dict-set! w "kind" kind)
(dict-set! w "body" body)
(dict-set! w "immediate?" immediate?)
w)))
(define
forth-def-prim!
(fn
(state name body)
(dict-set!
(get state "dict")
(downcase name)
(forth-make-word "primitive" body false))))
(define
forth-def-prim-imm!
(fn
(state name body)
(dict-set!
(get state "dict")
(downcase name)
(forth-make-word "primitive" body true))))
(define
forth-lookup
(fn (state name) (get (get state "dict") (downcase name))))
(define
forth-binop
(fn
(op)
(fn
(state)
(let
((b (forth-pop state)) (a (forth-pop state)))
(forth-push state (op a b))))))
(define
forth-unop
(fn
(op)
(fn (state) (let ((a (forth-pop state))) (forth-push state (op a))))))
(define
forth-cmp
(fn
(op)
(fn
(state)
(let
((b (forth-pop state)) (a (forth-pop state)))
(forth-push state (if (op a b) -1 0))))))
(define
forth-cmp0
(fn
(op)
(fn
(state)
(let ((a (forth-pop state))) (forth-push state (if (op a) -1 0))))))
(define
forth-trunc
(fn (x) (if (< x 0) (- 0 (floor (- 0 x))) (floor x))))
(define
forth-div
(fn
(a b)
(if (= b 0) (raise "division by zero") (forth-trunc (/ a b)))))
(define
forth-mod
(fn
(a b)
(if (= b 0) (raise "division by zero") (- a (* b (forth-div a b))))))
(define forth-bits-width 32)
(define
forth-to-unsigned
(fn (n w) (let ((m (pow 2 w))) (mod (+ (mod n m) m) m))))
(define
forth-from-unsigned
(fn
(n w)
(let ((half (pow 2 (- w 1)))) (if (>= n half) (- n (pow 2 w)) n))))
(define
forth-bitwise-step
(fn
(op ua ub out place i w)
(if
(>= i w)
out
(let
((da (mod ua 2)) (db (mod ub 2)))
(forth-bitwise-step
op
(floor (/ ua 2))
(floor (/ ub 2))
(+ out (* place (op da db)))
(* place 2)
(+ i 1)
w)))))
(define
forth-bitwise-uu
(fn
(op)
(fn
(a b)
(let
((ua (forth-to-unsigned a forth-bits-width))
(ub (forth-to-unsigned b forth-bits-width)))
(forth-from-unsigned
(forth-bitwise-step op ua ub 0 1 0 forth-bits-width)
forth-bits-width)))))
(define
forth-bit-and
(forth-bitwise-uu (fn (x y) (if (and (= x 1) (= y 1)) 1 0))))
(define
forth-bit-or
(forth-bitwise-uu (fn (x y) (if (or (= x 1) (= y 1)) 1 0))))
(define forth-bit-xor (forth-bitwise-uu (fn (x y) (if (= x y) 0 1))))
(define forth-bit-invert (fn (a) (- 0 (+ a 1))))
(define
forth-install-primitives!
(fn
(state)
(forth-def-prim! state "DUP" (fn (s) (forth-push s (forth-peek s))))
(forth-def-prim! state "DROP" (fn (s) (forth-pop s)))
(forth-def-prim!
state
"SWAP"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s b)
(forth-push s a))))
(forth-def-prim!
state
"OVER"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s a)
(forth-push s b)
(forth-push s a))))
(forth-def-prim!
state
"ROT"
(fn
(s)
(let
((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
(forth-push s b)
(forth-push s c)
(forth-push s a))))
(forth-def-prim!
state
"-ROT"
(fn
(s)
(let
((c (forth-pop s)) (b (forth-pop s)) (a (forth-pop s)))
(forth-push s c)
(forth-push s a)
(forth-push s b))))
(forth-def-prim!
state
"NIP"
(fn (s) (let ((b (forth-pop s))) (forth-pop s) (forth-push s b))))
(forth-def-prim!
state
"TUCK"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s b)
(forth-push s a)
(forth-push s b))))
(forth-def-prim!
state
"?DUP"
(fn
(s)
(let ((a (forth-peek s))) (when (not (= a 0)) (forth-push s a)))))
(forth-def-prim! state "DEPTH" (fn (s) (forth-push s (forth-depth s))))
(forth-def-prim!
state
"PICK"
(fn
(s)
(let
((n (forth-pop s)) (st (get s "dstack")))
(if
(or (< n 0) (>= n (len st)))
(forth-error s "PICK out of range")
(forth-push s (nth st n))))))
(forth-def-prim!
state
"ROLL"
(fn
(s)
(let
((n (forth-pop s)) (st (get s "dstack")))
(if
(or (< n 0) (>= n (len st)))
(forth-error s "ROLL out of range")
(let
((taken (nth st n))
(before (take st n))
(after (drop st (+ n 1))))
(dict-set! s "dstack" (concat before after))
(forth-push s taken))))))
(forth-def-prim!
state
"2DUP"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s a)
(forth-push s b)
(forth-push s a)
(forth-push s b))))
(forth-def-prim! state "2DROP" (fn (s) (forth-pop s) (forth-pop s)))
(forth-def-prim!
state
"2SWAP"
(fn
(s)
(let
((d (forth-pop s))
(c (forth-pop s))
(b (forth-pop s))
(a (forth-pop s)))
(forth-push s c)
(forth-push s d)
(forth-push s a)
(forth-push s b))))
(forth-def-prim!
state
"2OVER"
(fn
(s)
(let
((d (forth-pop s))
(c (forth-pop s))
(b (forth-pop s))
(a (forth-pop s)))
(forth-push s a)
(forth-push s b)
(forth-push s c)
(forth-push s d)
(forth-push s a)
(forth-push s b))))
(forth-def-prim! state "+" (forth-binop (fn (a b) (+ a b))))
(forth-def-prim! state "-" (forth-binop (fn (a b) (- a b))))
(forth-def-prim! state "*" (forth-binop (fn (a b) (* a b))))
(forth-def-prim! state "/" (forth-binop forth-div))
(forth-def-prim! state "MOD" (forth-binop forth-mod))
(forth-def-prim!
state
"/MOD"
(fn
(s)
(let
((b (forth-pop s)) (a (forth-pop s)))
(forth-push s (forth-mod a b))
(forth-push s (forth-div a b)))))
(forth-def-prim! state "NEGATE" (forth-unop (fn (a) (- 0 a))))
(forth-def-prim! state "ABS" (forth-unop abs))
(forth-def-prim!
state
"MIN"
(forth-binop (fn (a b) (if (< a b) a b))))
(forth-def-prim!
state
"MAX"
(forth-binop (fn (a b) (if (> a b) a b))))
(forth-def-prim! state "1+" (forth-unop (fn (a) (+ a 1))))
(forth-def-prim! state "1-" (forth-unop (fn (a) (- a 1))))
(forth-def-prim! state "2+" (forth-unop (fn (a) (+ a 2))))
(forth-def-prim! state "2-" (forth-unop (fn (a) (- a 2))))
(forth-def-prim! state "2*" (forth-unop (fn (a) (* a 2))))
(forth-def-prim! state "2/" (forth-unop (fn (a) (floor (/ a 2)))))
(forth-def-prim! state "=" (forth-cmp (fn (a b) (= a b))))
(forth-def-prim! state "<>" (forth-cmp (fn (a b) (not (= a b)))))
(forth-def-prim! state "<" (forth-cmp (fn (a b) (< a b))))
(forth-def-prim! state ">" (forth-cmp (fn (a b) (> a b))))
(forth-def-prim! state "<=" (forth-cmp (fn (a b) (<= a b))))
(forth-def-prim! state ">=" (forth-cmp (fn (a b) (>= a b))))
(forth-def-prim! state "0=" (forth-cmp0 (fn (a) (= a 0))))
(forth-def-prim! state "0<>" (forth-cmp0 (fn (a) (not (= a 0)))))
(forth-def-prim! state "0<" (forth-cmp0 (fn (a) (< a 0))))
(forth-def-prim! state "0>" (forth-cmp0 (fn (a) (> a 0))))
(forth-def-prim! state "AND" (forth-binop forth-bit-and))
(forth-def-prim! state "OR" (forth-binop forth-bit-or))
(forth-def-prim! state "XOR" (forth-binop forth-bit-xor))
(forth-def-prim! state "INVERT" (forth-unop forth-bit-invert))
(forth-def-prim!
state
"."
(fn (s) (forth-emit-str s (str (forth-pop s) " "))))
(forth-def-prim!
state
".S"
(fn
(s)
(let
((st (reverse (get s "dstack"))))
(forth-emit-str s "<")
(forth-emit-str s (str (len st)))
(forth-emit-str s "> ")
(for-each (fn (v) (forth-emit-str s (str v " "))) st))))
(forth-def-prim!
state
"EMIT"
(fn (s) (forth-emit-str s (code-char (forth-pop s)))))
(forth-def-prim! state "CR" (fn (s) (forth-emit-str s "\n")))
(forth-def-prim! state "SPACE" (fn (s) (forth-emit-str s " ")))
(forth-def-prim!
state
"SPACES"
(fn
(s)
(let
((n (forth-pop s)))
(when
(> n 0)
(for-each (fn (_) (forth-emit-str s " ")) (range 0 n))))))
(forth-def-prim! state "BL" (fn (s) (forth-push s 32)))
state))

View File

@@ -1,62 +0,0 @@
#!/usr/bin/env bash
# lib/forth/test.sh — smoke-test the Forth runtime layer.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found."
exit 1
fi
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "lib/forth/runtime.sx")
(epoch 2)
(load "lib/forth/tests/runtime.sx")
(epoch 3)
(eval "(list forth-test-pass forth-test-fail)")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"
echo "$OUTPUT" | tail -20
exit 1
fi
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
TOTAL=$((P + F))
if [ "$F" -eq 0 ]; then
echo "ok $P/$TOTAL lib/forth tests passed"
else
echo "FAIL $P/$TOTAL passed, $F failed"
TMPFILE2=$(mktemp)
cat > "$TMPFILE2" << 'EPOCHS2'
(epoch 1)
(load "lib/forth/runtime.sx")
(epoch 2)
(load "lib/forth/tests/runtime.sx")
(epoch 3)
(eval "(map (fn (f) (list (get f :name) (get f :got) (get f :expected))) forth-test-fails)")
EPOCHS2
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>/dev/null | grep -E '^\(ok-len 3' -A1 | tail -1 || true)
echo " Details: $FAILS"
rm -f "$TMPFILE2"
fi
[ "$F" -eq 0 ]

View File

@@ -1,201 +0,0 @@
;; lib/forth/tests/runtime.sx — Tests for lib/forth/runtime.sx
(define forth-test-pass 0)
(define forth-test-fail 0)
(define forth-test-fails (list))
(define
(forth-test name got expected)
(if
(= got expected)
(set! forth-test-pass (+ forth-test-pass 1))
(begin
(set! forth-test-fail (+ forth-test-fail 1))
(set! forth-test-fails (append forth-test-fails (list {:got got :expected expected :name name}))))))
;; ---------------------------------------------------------------------------
;; 1. Bitwise operations
;; ---------------------------------------------------------------------------
;; AND
(forth-test "and 0b1100 0b1010" (forth-and 12 10) 8)
(forth-test "and 0xFF 0x0F" (forth-and 255 15) 15)
(forth-test "and 0 any" (forth-and 0 42) 0)
;; OR
(forth-test "or 0b1100 0b1010" (forth-or 12 10) 14)
(forth-test "or 0 x" (forth-or 0 7) 7)
;; XOR
(forth-test "xor 0b1100 0b1010" (forth-xor 12 10) 6)
(forth-test "xor x x" (forth-xor 42 42) 0)
;; INVERT
(forth-test "invert 0" (forth-invert 0) -1)
(forth-test "invert -1" (forth-invert -1) 0)
(forth-test "invert 1" (forth-invert 1) -2)
;; LSHIFT RSHIFT
(forth-test "lshift 1 3" (forth-lshift 1 3) 8)
(forth-test "lshift 3 2" (forth-lshift 3 2) 12)
(forth-test "rshift 8 3" (forth-rshift 8 3) 1)
(forth-test "rshift 16 2" (forth-rshift 16 2) 4)
;; 2* 2/
(forth-test "2* 5" (forth-2* 5) 10)
(forth-test "2/ 10" (forth-2/ 10) 5)
(forth-test "2/ 7" (forth-2/ 7) 3)
;; BIT-COUNT
(forth-test "bit-count 0" (forth-bit-count 0) 0)
(forth-test "bit-count 1" (forth-bit-count 1) 1)
(forth-test "bit-count 7" (forth-bit-count 7) 3)
(forth-test "bit-count 255" (forth-bit-count 255) 8)
(forth-test "bit-count 256" (forth-bit-count 256) 1)
;; INTEGER-LENGTH
(forth-test "integer-length 0" (forth-integer-length 0) 0)
(forth-test "integer-length 1" (forth-integer-length 1) 1)
(forth-test "integer-length 4" (forth-integer-length 4) 3)
(forth-test "integer-length 255" (forth-integer-length 255) 8)
;; WITHIN
(forth-test
"within 5 0 10"
(forth-within 5 0 10)
true)
(forth-test
"within 0 0 10"
(forth-within 0 0 10)
true)
(forth-test
"within 10 0 10"
(forth-within 10 0 10)
false)
(forth-test
"within -1 0 10"
(forth-within -1 0 10)
false)
;; Arithmetic ops
(forth-test "negate 5" (forth-negate 5) -5)
(forth-test "negate -3" (forth-negate -3) 3)
(forth-test "abs -7" (forth-abs -7) 7)
(forth-test "min 3 5" (forth-min 3 5) 3)
(forth-test "max 3 5" (forth-max 3 5) 5)
(forth-test "mod 7 3" (forth-mod 7 3) 1)
(forth-test
"divmod 7 3"
(forth-divmod 7 3)
(list 1 2))
(forth-test
"divmod 10 5"
(forth-divmod 10 5)
(list 0 2))
;; ---------------------------------------------------------------------------
;; 2. String buffer
;; ---------------------------------------------------------------------------
(define sb1 (forth-sb-new))
(forth-test "sb? new" (forth-sb? sb1) true)
(forth-test "sb? non-sb" (forth-sb? 42) false)
(forth-test "sb value empty" (forth-sb-value sb1) "")
(forth-test "sb length empty" (forth-sb-length sb1) 0)
(forth-sb-type! sb1 "HELLO")
(forth-test "sb type" (forth-sb-value sb1) "HELLO")
(forth-test "sb length after type" (forth-sb-length sb1) 5)
;; EMIT one char
(define sb2 (forth-sb-new))
(forth-sb-emit! sb2 (nth (string->list "A") 0))
(forth-sb-emit! sb2 (nth (string->list "B") 0))
(forth-sb-emit! sb2 (nth (string->list "C") 0))
(forth-test "sb emit chars" (forth-sb-value sb2) "ABC")
;; Emit integer
(define sb3 (forth-sb-new))
(forth-sb-type! sb3 "n=")
(forth-sb-emit-int! sb3 42)
(forth-test "sb emit-int" (forth-sb-value sb3) "n=42")
(forth-sb-clear! sb1)
(forth-test "sb clear" (forth-sb-value sb1) "")
(forth-test "sb length after clear" (forth-sb-length sb1) 0)
;; Build a word definition-style name
(define sb4 (forth-sb-new))
(forth-sb-type! sb4 ": ")
(forth-sb-type! sb4 "SQUARE")
(forth-sb-type! sb4 " DUP * ;")
(forth-test "sb word def" (forth-sb-value sb4) ": SQUARE DUP * ;")
;; ---------------------------------------------------------------------------
;; 3. Memory / Bytevectors
;; ---------------------------------------------------------------------------
(define m1 (forth-mem-new 8))
(forth-test "mem? yes" (forth-mem? m1) true)
(forth-test "mem? no" (forth-mem? 42) false)
(forth-test "mem size" (forth-mem-size m1) 8)
(forth-test "mem cfetch zero" (forth-cfetch m1 0) 0)
;; C! C@
(forth-cstore m1 0 65)
(forth-cstore m1 1 66)
(forth-test "mem cstore/cfetch 0" (forth-cfetch m1 0) 65)
(forth-test "mem cstore/cfetch 1" (forth-cfetch m1 1) 66)
(forth-cstore m1 2 256)
(forth-test
"mem cstore wraps 256→0"
(forth-cfetch m1 2)
0)
(forth-cstore m1 2 257)
(forth-test
"mem cstore wraps 257→1"
(forth-cfetch m1 2)
1)
;; @ ! (32-bit LE cell)
(define m2 (forth-mem-new 8))
(forth-store m2 0 305419896)
(forth-test "mem store/fetch" (forth-fetch m2 0) 305419896)
(forth-store m2 4 1)
(forth-test "mem fetch byte 4" (forth-cfetch m2 4) 1)
(forth-test "mem fetch byte 5" (forth-cfetch m2 5) 0)
;; FILL ERASE
(define m3 (forth-mem-new 4))
(forth-fill! m3 0 4 42)
(forth-test
"mem fill"
(forth-mem->list m3 0 4)
(list 42 42 42 42))
(forth-erase! m3 1 2)
(forth-test
"mem erase middle"
(forth-mem->list m3 0 4)
(list 42 0 0 42))
;; MOVE
(define m4 (forth-mem-new 4))
(forth-cstore m4 0 1)
(forth-cstore m4 1 2)
(forth-cstore m4 2 3)
(define m5 (forth-mem-new 4))
(forth-move! m4 0 m5 0 3)
(forth-test
"mem move"
(forth-mem->list m5 0 3)
(list 1 2 3))
;; mem->list
(define m6 (forth-mem-new 3))
(forth-cstore m6 0 10)
(forth-cstore m6 1 20)
(forth-cstore m6 2 30)
(forth-test
"mem->list"
(forth-mem->list m6 0 3)
(list 10 20 30))

View File

@@ -1,507 +0,0 @@
;; lib/haskell/runtime.sx — Haskell-on-SX runtime layer
;;
;; Covers the Haskell primitives now reachable via SX spec:
;; 1. Numeric type class helpers (Num / Integral / Fractional)
;; 2. Rational numbers (dict-based: {:_rational true :num n :den d})
;; 3. Lazy evaluation — hk-force for promises created by delay
;; 4. Char utilities (Data.Char)
;; 5. Data.Set wrappers
;; 6. Data.List utilities
;; 7. Maybe / Either ADTs
;; 8. Tuples (lists, since list->vector unreliable in sx_server)
;; 9. String helpers (words/lines/isPrefixOf/etc.)
;; 10. Show helper
;; ===========================================================================
;; 1. Numeric type class helpers
;; ===========================================================================
(define hk-is-integer? integer?)
(define hk-is-float? float?)
(define hk-is-num? number?)
;; fromIntegral — coerce integer to Float
(define (hk-to-float x) (exact->inexact x))
;; truncate / round toward zero
(define hk-to-integer truncate)
(define hk-from-integer (fn (n) n))
;; Haskell div: floor division (rounds toward -inf)
(define
(hk-div a b)
(let
((q (quotient a b)) (r (remainder a b)))
(if
(and
(not (= r 0))
(or
(and (< a 0) (> b 0))
(and (> a 0) (< b 0))))
(- q 1)
q)))
;; Haskell mod: result has same sign as divisor
(define hk-mod modulo)
;; Haskell rem: result has same sign as dividend
(define hk-rem remainder)
;; Haskell quot: truncation division
(define hk-quot quotient)
;; divMod and quotRem return pairs (lists)
(define (hk-div-mod a b) (list (hk-div a b) (hk-mod a b)))
(define (hk-quot-rem a b) (list (hk-quot a b) (hk-rem a b)))
(define (hk-abs x) (if (< x 0) (- 0 x) x))
(define
(hk-signum x)
(cond
((> x 0) 1)
((< x 0) -1)
(else 0)))
(define hk-gcd gcd)
(define hk-lcm lcm)
(define (hk-even? n) (= (modulo n 2) 0))
(define (hk-odd? n) (not (= (modulo n 2) 0)))
;; ===========================================================================
;; 2. Rational numbers (dict implementation — no built-in rational in sx_server)
;; ===========================================================================
(define
(hk-make-rational n d)
(let
((g (gcd (hk-abs n) (hk-abs d))))
(if (< d 0) {:num (quotient (- 0 n) g) :den (quotient (- 0 d) g) :_rational true} {:num (quotient n g) :den (quotient d g) :_rational true})))
(define
(hk-rational? x)
(and (dict? x) (not (= (get x :_rational) nil))))
(define (hk-numerator r) (get r :num))
(define (hk-denominator r) (get r :den))
(define
(hk-rational-add r1 r2)
(hk-make-rational
(+
(* (hk-numerator r1) (hk-denominator r2))
(* (hk-numerator r2) (hk-denominator r1)))
(* (hk-denominator r1) (hk-denominator r2))))
(define
(hk-rational-sub r1 r2)
(hk-make-rational
(-
(* (hk-numerator r1) (hk-denominator r2))
(* (hk-numerator r2) (hk-denominator r1)))
(* (hk-denominator r1) (hk-denominator r2))))
(define
(hk-rational-mul r1 r2)
(hk-make-rational
(* (hk-numerator r1) (hk-numerator r2))
(* (hk-denominator r1) (hk-denominator r2))))
(define
(hk-rational-div r1 r2)
(hk-make-rational
(* (hk-numerator r1) (hk-denominator r2))
(* (hk-denominator r1) (hk-numerator r2))))
(define
(hk-rational-to-float r)
(exact->inexact (/ (hk-numerator r) (hk-denominator r))))
(define (hk-show-rational r) (str (hk-numerator r) "%" (hk-denominator r)))
;; ===========================================================================
;; 3. Lazy evaluation — promises (created via SX delay)
;; ===========================================================================
(define
(hk-force p)
(if
(and (dict? p) (not (= (get p :_promise) nil)))
(if (get p :forced) (get p :value) ((get p :thunk)))
p))
;; ===========================================================================
;; 4. Char utilities (Data.Char)
;; ===========================================================================
(define hk-ord char->integer)
(define hk-chr integer->char)
;; Inline ASCII predicates — char-alphabetic?/char-numeric? unreliable in sx_server
(define
(hk-is-alpha? c)
(let
((n (char->integer c)))
(or
(and (>= n 65) (<= n 90))
(and (>= n 97) (<= n 122)))))
(define
(hk-is-digit? c)
(let ((n (char->integer c))) (and (>= n 48) (<= n 57))))
(define
(hk-is-alnum? c)
(let
((n (char->integer c)))
(or
(and (>= n 48) (<= n 57))
(and (>= n 65) (<= n 90))
(and (>= n 97) (<= n 122)))))
(define
(hk-is-upper? c)
(let ((n (char->integer c))) (and (>= n 65) (<= n 90))))
(define
(hk-is-lower? c)
(let ((n (char->integer c))) (and (>= n 97) (<= n 122))))
(define
(hk-is-space? c)
(let
((n (char->integer c)))
(or
(= n 32)
(= n 9)
(= n 10)
(= n 13)
(= n 12)
(= n 11))))
(define hk-to-upper char-upcase)
(define hk-to-lower char-downcase)
;; digitToInt: '0'-'9' → 0-9, 'a'-'f'/'A'-'F' → 10-15
(define
(hk-digit-to-int c)
(let
((n (char->integer c)))
(cond
((and (>= n 48) (<= n 57)) (- n 48))
((and (>= n 65) (<= n 70)) (- n 55))
((and (>= n 97) (<= n 102)) (- n 87))
(else (error (str "hk-digit-to-int: not a hex digit: " c))))))
;; intToDigit: 0-15 → char
(define
(hk-int-to-digit n)
(cond
((and (>= n 0) (<= n 9))
(integer->char (+ n 48)))
((and (>= n 10) (<= n 15))
(integer->char (+ n 87)))
(else (error (str "hk-int-to-digit: out of range: " n)))))
;; ===========================================================================
;; 5. Data.Set wrappers
;; ===========================================================================
(define (hk-set-empty) (make-set))
(define hk-set? set?)
(define hk-set-member? set-member?)
(define (hk-set-insert x s) (begin (set-add! s x) s))
(define (hk-set-delete x s) (begin (set-remove! s x) s))
(define hk-set-union set-union)
(define hk-set-intersection set-intersection)
(define hk-set-difference set-difference)
(define hk-set-from-list list->set)
(define hk-set-to-list set->list)
(define (hk-set-null? s) (= (len (set->list s)) 0))
(define (hk-set-size s) (len (set->list s)))
(define (hk-set-singleton x) (let ((s (make-set))) (set-add! s x) s))
;; ===========================================================================
;; 6. Data.List utilities
;; ===========================================================================
(define hk-head first)
(define hk-tail rest)
(define (hk-null? lst) (= (len lst) 0))
(define hk-length len)
(define
(hk-take n lst)
(if
(or (= n 0) (= (len lst) 0))
(list)
(cons (first lst) (hk-take (- n 1) (rest lst)))))
(define
(hk-drop n lst)
(if
(or (= n 0) (= (len lst) 0))
lst
(hk-drop (- n 1) (rest lst))))
(define
(hk-take-while pred lst)
(if
(or (= (len lst) 0) (not (pred (first lst))))
(list)
(cons (first lst) (hk-take-while pred (rest lst)))))
(define
(hk-drop-while pred lst)
(if
(or (= (len lst) 0) (not (pred (first lst))))
lst
(hk-drop-while pred (rest lst))))
(define
(hk-zip a b)
(if
(or (= (len a) 0) (= (len b) 0))
(list)
(cons (list (first a) (first b)) (hk-zip (rest a) (rest b)))))
(define
(hk-zip-with f a b)
(if
(or (= (len a) 0) (= (len b) 0))
(list)
(cons (f (first a) (first b)) (hk-zip-with f (rest a) (rest b)))))
(define
(hk-unzip pairs)
(list
(map (fn (p) (first p)) pairs)
(map (fn (p) (nth p 1)) pairs)))
(define
(hk-elem x lst)
(cond
((= (len lst) 0) false)
((= x (first lst)) true)
(else (hk-elem x (rest lst)))))
(define (hk-not-elem x lst) (not (hk-elem x lst)))
(define
(hk-nub lst)
(letrec
((go (fn (seen acc items) (if (= (len items) 0) (reverse acc) (let ((h (first items)) (t (rest items))) (if (hk-elem h seen) (go seen acc t) (go (cons h seen) (cons h acc) t)))))))
(go (list) (list) lst)))
(define (hk-sum lst) (reduce + 0 lst))
(define (hk-product lst) (reduce * 1 lst))
(define
(hk-maximum lst)
(reduce (fn (a b) (if (> a b) a b)) (first lst) (rest lst)))
(define
(hk-minimum lst)
(reduce (fn (a b) (if (< a b) a b)) (first lst) (rest lst)))
(define (hk-concat lsts) (reduce append (list) lsts))
(define (hk-concat-map f lst) (hk-concat (map f lst)))
(define hk-sort sort)
(define
(hk-span pred lst)
(list (hk-take-while pred lst) (hk-drop-while pred lst)))
(define (hk-break pred lst) (hk-span (fn (x) (not (pred x))) lst))
(define
(hk-foldl f acc lst)
(if
(= (len lst) 0)
acc
(hk-foldl f (f acc (first lst)) (rest lst))))
(define
(hk-foldr f z lst)
(if
(= (len lst) 0)
z
(f (first lst) (hk-foldr f z (rest lst)))))
(define
(hk-scanl f acc lst)
(if
(= (len lst) 0)
(list acc)
(cons acc (hk-scanl f (f acc (first lst)) (rest lst)))))
(define
(hk-replicate n x)
(if (= n 0) (list) (cons x (hk-replicate (- n 1) x))))
(define
(hk-intersperse sep lst)
(if
(or (= (len lst) 0) (= (len lst) 1))
lst
(cons (first lst) (cons sep (hk-intersperse sep (rest lst))))))
;; ===========================================================================
;; 7. Maybe / Either ADTs
;; ===========================================================================
(define hk-nothing {:_maybe true :_tag "nothing"})
(define (hk-just x) {:_maybe true :value x :_tag "just"})
(define (hk-is-nothing? m) (= (get m :_tag) "nothing"))
(define (hk-is-just? m) (= (get m :_tag) "just"))
(define (hk-from-just m) (get m :value))
(define (hk-from-maybe def m) (if (hk-is-nothing? m) def (hk-from-just m)))
(define
(hk-maybe def f m)
(if (hk-is-nothing? m) def (f (hk-from-just m))))
(define (hk-left x) {:value x :_either true :_tag "left"})
(define (hk-right x) {:value x :_either true :_tag "right"})
(define (hk-is-left? e) (= (get e :_tag) "left"))
(define (hk-is-right? e) (= (get e :_tag) "right"))
(define (hk-from-left e) (get e :value))
(define (hk-from-right e) (get e :value))
(define
(hk-either f g e)
(if (hk-is-left? e) (f (hk-from-left e)) (g (hk-from-right e))))
;; ===========================================================================
;; 8. Tuples (lists — list->vector unreliable in sx_server)
;; ===========================================================================
(define (hk-pair a b) (list a b))
(define hk-fst first)
(define (hk-snd t) (nth t 1))
(define (hk-triple a b c) (list a b c))
(define hk-fst3 first)
(define (hk-snd3 t) (nth t 1))
(define (hk-thd3 t) (nth t 2))
(define (hk-curry f) (fn (a) (fn (b) (f a b))))
(define (hk-uncurry f) (fn (p) (f (hk-fst p) (hk-snd p))))
;; ===========================================================================
;; 9. String helpers (Data.List / Data.Char for strings)
;; ===========================================================================
;; words: split on whitespace
(define
(hk-words s)
(letrec
((slen (len s))
(skip-ws
(fn
(i)
(if
(>= i slen)
(list)
(let
((c (substring s i (+ i 1))))
(if
(or (= c " ") (= c "\t") (= c "\n"))
(skip-ws (+ i 1))
(collect-word i (+ i 1)))))))
(collect-word
(fn
(start i)
(if
(>= i slen)
(list (substring s start i))
(let
((c (substring s i (+ i 1))))
(if
(or (= c " ") (= c "\t") (= c "\n"))
(cons (substring s start i) (skip-ws (+ i 1)))
(collect-word start (+ i 1))))))))
(skip-ws 0)))
;; unwords: join with spaces
(define
(hk-unwords lst)
(if
(= (len lst) 0)
""
(reduce (fn (a b) (str a " " b)) (first lst) (rest lst))))
;; lines: split on newline
(define
(hk-lines s)
(letrec
((slen (len s))
(go
(fn
(start i acc)
(if
(>= i slen)
(reverse (cons (substring s start i) acc))
(if
(= (substring s i (+ i 1)) "\n")
(go
(+ i 1)
(+ i 1)
(cons (substring s start i) acc))
(go start (+ i 1) acc))))))
(if (= slen 0) (list) (go 0 0 (list)))))
;; unlines: join, each with trailing newline
(define (hk-unlines lst) (reduce (fn (a b) (str a b "\n")) "" lst))
;; isPrefixOf
(define
(hk-is-prefix-of pre s)
(and (<= (len pre) (len s)) (= pre (substring s 0 (len pre)))))
;; isSuffixOf
(define
(hk-is-suffix-of suf s)
(let
((sl (len suf)) (tl (len s)))
(and (<= sl tl) (= suf (substring s (- tl sl) tl)))))
;; isInfixOf — linear scan
(define
(hk-is-infix-of pat s)
(let
((plen (len pat)) (slen (len s)))
(letrec
((go (fn (i) (if (> (+ i plen) slen) false (if (= pat (substring s i (+ i plen))) true (go (+ i 1)))))))
(if (= plen 0) true (go 0)))))
;; ===========================================================================
;; 10. Show helper
;; ===========================================================================
(define
(hk-show x)
(cond
((= x nil) "Nothing")
((= x true) "True")
((= x false) "False")
((hk-rational? x) (hk-show-rational x))
((integer? x) (str x))
((float? x) (str x))
((= (type-of x) "string") (str "\"" x "\""))
((= (type-of x) "char") (str "'" (str x) "'"))
((list? x)
(str
"["
(if
(= (len x) 0)
""
(reduce
(fn (a b) (str a "," (hk-show b)))
(hk-show (first x))
(rest x)))
"]"))
(else (str x))))

View File

@@ -46,7 +46,6 @@ for FILE in "${FILES[@]}"; do
cat > "$TMPFILE" <<EPOCHS
(epoch 1)
(load "lib/haskell/tokenizer.sx")
(load "lib/haskell/runtime.sx")
(epoch 2)
(load "$FILE")
(epoch 3)
@@ -82,7 +81,6 @@ EPOCHS
cat > "$TMPFILE2" <<EPOCHS
(epoch 1)
(load "lib/haskell/tokenizer.sx")
(load "lib/haskell/runtime.sx")
(epoch 2)
(load "$FILE")
(epoch 3)

View File

@@ -1,451 +0,0 @@
;; lib/haskell/tests/runtime.sx — smoke-tests for lib/haskell/runtime.sx
;;
;; Uses the same hk-test framework as tests/parse.sx.
;; Loaded by test.sh after: tokenizer.sx + runtime.sx are pre-loaded.
;; ---------------------------------------------------------------------------
;; Test framework boilerplate (mirrors parse.sx)
;; ---------------------------------------------------------------------------
(define hk-test-pass 0)
(define hk-test-fail 0)
(define hk-test-fails (list))
(define
(hk-test name actual expected)
(if
(= actual expected)
(set! hk-test-pass (+ hk-test-pass 1))
(do
(set! hk-test-fail (+ hk-test-fail 1))
(append! hk-test-fails {:actual actual :expected expected :name name}))))
;; ---------------------------------------------------------------------------
;; 1. Numeric type class helpers
;; ---------------------------------------------------------------------------
(hk-test "is-integer? int" (hk-is-integer? 42) true)
(hk-test "is-integer? float" (hk-is-integer? 1.5) false)
(hk-test "is-float? float" (hk-is-float? 3.14) true)
(hk-test "is-float? int" (hk-is-float? 3) false)
(hk-test "is-num? int" (hk-is-num? 10) true)
(hk-test "is-num? float" (hk-is-num? 1) true)
(hk-test "to-float" (hk-to-float 5) 5)
(hk-test "to-integer trunc" (hk-to-integer 3.7) 3)
(hk-test "div pos pos" (hk-div 7 2) 3)
(hk-test "div neg pos" (hk-div -7 2) -4)
(hk-test "div pos neg" (hk-div 7 -2) -4)
(hk-test "div neg neg" (hk-div -7 -2) 3)
(hk-test "div exact" (hk-div 6 2) 3)
(hk-test "mod pos pos" (hk-mod 10 3) 1)
(hk-test "mod neg pos" (hk-mod -7 3) 2)
(hk-test "rem pos pos" (hk-rem 10 3) 1)
(hk-test "rem neg pos" (hk-rem -7 3) -1)
(hk-test "abs pos" (hk-abs 5) 5)
(hk-test "abs neg" (hk-abs -5) 5)
(hk-test "signum pos" (hk-signum 42) 1)
(hk-test "signum neg" (hk-signum -7) -1)
(hk-test "signum zero" (hk-signum 0) 0)
(hk-test "gcd" (hk-gcd 12 8) 4)
(hk-test "lcm" (hk-lcm 4 6) 12)
(hk-test "even?" (hk-even? 4) true)
(hk-test "even? odd" (hk-even? 3) false)
(hk-test "odd?" (hk-odd? 7) true)
;; ---------------------------------------------------------------------------
;; 2. Rational numbers
;; ---------------------------------------------------------------------------
(let
((r (hk-make-rational 1 2)))
(do
(hk-test "rational?" (hk-rational? r) true)
(hk-test "numerator" (hk-numerator r) 1)
(hk-test "denominator" (hk-denominator r) 2)))
(let
((r (hk-make-rational 2 4)))
(do
(hk-test "rat normalise num" (hk-numerator r) 1)
(hk-test "rat normalise den" (hk-denominator r) 2)))
(let
((sum (hk-rational-add (hk-make-rational 1 2) (hk-make-rational 1 3))))
(do
(hk-test "rat-add num" (hk-numerator sum) 5)
(hk-test "rat-add den" (hk-denominator sum) 6)))
(hk-test
"rat-to-float"
(hk-rational-to-float (hk-make-rational 1 2))
0.5)
(hk-test "rational? int" (hk-rational? 42) false)
;; ---------------------------------------------------------------------------
;; 3. Lazy evaluation (promises via SX delay)
;; ---------------------------------------------------------------------------
(let
((p (delay 42)))
(hk-test "force promise" (hk-force p) 42))
(hk-test "force non-promise" (hk-force 99) 99)
;; ---------------------------------------------------------------------------
;; 4. Char utilities — compare via hk-ord to avoid = on char type
;; ---------------------------------------------------------------------------
(hk-test "ord A" (hk-ord (integer->char 65)) 65)
(hk-test "chr 65" (hk-ord (hk-chr 65)) 65)
(hk-test "is-alpha? A" (hk-is-alpha? (integer->char 65)) true)
(hk-test "is-alpha? 0" (hk-is-alpha? (integer->char 48)) false)
(hk-test "is-digit? 5" (hk-is-digit? (integer->char 53)) true)
(hk-test "is-digit? A" (hk-is-digit? (integer->char 65)) false)
(hk-test "is-upper? A" (hk-is-upper? (integer->char 65)) true)
(hk-test "is-upper? a" (hk-is-upper? (integer->char 97)) false)
(hk-test "is-lower? a" (hk-is-lower? (integer->char 97)) true)
(hk-test "is-space? spc" (hk-is-space? (integer->char 32)) true)
(hk-test "is-space? A" (hk-is-space? (integer->char 65)) false)
(hk-test
"to-upper a"
(hk-ord (hk-to-upper (integer->char 97)))
65)
(hk-test
"to-lower A"
(hk-ord (hk-to-lower (integer->char 65)))
97)
(hk-test
"digit-to-int 0"
(hk-digit-to-int (integer->char 48))
0)
(hk-test
"digit-to-int 9"
(hk-digit-to-int (integer->char 57))
9)
(hk-test
"digit-to-int a"
(hk-digit-to-int (integer->char 97))
10)
(hk-test
"digit-to-int F"
(hk-digit-to-int (integer->char 70))
15)
(hk-test "int-to-digit 0" (hk-ord (hk-int-to-digit 0)) 48)
(hk-test "int-to-digit 10" (hk-ord (hk-int-to-digit 10)) 97)
;; ---------------------------------------------------------------------------
;; 5. Data.Set
;; ---------------------------------------------------------------------------
(hk-test "set-empty is set?" (hk-set? (hk-set-empty)) true)
(hk-test "set-null? empty" (hk-set-null? (hk-set-empty)) true)
(let
((s (hk-set-singleton 42)))
(do
(hk-test "singleton member" (hk-set-member? 42 s) true)
(hk-test "singleton size" (hk-set-size s) 1)))
(let
((s (hk-set-from-list (list 1 2 3))))
(do
(hk-test "from-list member" (hk-set-member? 2 s) true)
(hk-test "from-list absent" (hk-set-member? 9 s) false)
(hk-test "from-list size" (hk-set-size s) 3)))
;; ---------------------------------------------------------------------------
;; 6. Data.List
;; ---------------------------------------------------------------------------
(hk-test "head" (hk-head (list 1 2 3)) 1)
(hk-test
"tail length"
(len (hk-tail (list 1 2 3)))
2)
(hk-test "null? empty" (hk-null? (list)) true)
(hk-test "null? non-empty" (hk-null? (list 1)) false)
(hk-test
"length"
(hk-length (list 1 2 3))
3)
(hk-test
"take 2"
(hk-take 2 (list 1 2 3))
(list 1 2))
(hk-test "take 0" (hk-take 0 (list 1 2)) (list))
(hk-test
"take overflow"
(hk-take 5 (list 1 2))
(list 1 2))
(hk-test
"drop 1"
(hk-drop 1 (list 1 2 3))
(list 2 3))
(hk-test
"drop 0"
(hk-drop 0 (list 1 2))
(list 1 2))
(hk-test
"take-while"
(hk-take-while
(fn (x) (< x 3))
(list 1 2 3 4))
(list 1 2))
(hk-test
"drop-while"
(hk-drop-while
(fn (x) (< x 3))
(list 1 2 3 4))
(list 3 4))
(hk-test
"zip"
(hk-zip (list 1 2) (list 3 4))
(list (list 1 3) (list 2 4)))
(hk-test
"zip uneven"
(hk-zip
(list 1 2 3)
(list 4 5))
(list (list 1 4) (list 2 5)))
(hk-test
"zip-with +"
(hk-zip-with
+
(list 1 2 3)
(list 10 20 30))
(list 11 22 33))
(hk-test
"unzip fst"
(first
(hk-unzip
(list (list 1 3) (list 2 4))))
(list 1 2))
(hk-test
"unzip snd"
(nth
(hk-unzip
(list (list 1 3) (list 2 4)))
1)
(list 3 4))
(hk-test
"elem hit"
(hk-elem 2 (list 1 2 3))
true)
(hk-test
"elem miss"
(hk-elem 9 (list 1 2 3))
false)
(hk-test
"not-elem"
(hk-not-elem 9 (list 1 2 3))
true)
(hk-test
"nub"
(hk-nub (list 1 2 1 3 2))
(list 1 2 3))
(hk-test
"sum"
(hk-sum (list 1 2 3 4))
10)
(hk-test
"product"
(hk-product (list 1 2 3 4))
24)
(hk-test
"maximum"
(hk-maximum (list 3 1 4 1 5))
5)
(hk-test
"minimum"
(hk-minimum (list 3 1 4 1 5))
1)
(hk-test
"concat"
(hk-concat
(list (list 1 2) (list 3 4)))
(list 1 2 3 4))
(hk-test
"concat-map"
(hk-concat-map
(fn (x) (list x (* x x)))
(list 1 2 3))
(list 1 1 2 4 3 9))
(hk-test
"sort"
(hk-sort (list 3 1 4 1 5))
(list 1 1 3 4 5))
(hk-test
"replicate"
(hk-replicate 3 0)
(list 0 0 0))
(hk-test "replicate 0" (hk-replicate 0 99) (list))
(hk-test
"intersperse"
(hk-intersperse 0 (list 1 2 3))
(list 1 0 2 0 3))
(hk-test
"intersperse 1"
(hk-intersperse 0 (list 1))
(list 1))
(hk-test "intersperse empty" (hk-intersperse 0 (list)) (list))
(hk-test
"span"
(hk-span
(fn (x) (< x 3))
(list 1 2 3 4))
(list (list 1 2) (list 3 4)))
(hk-test
"break"
(hk-break
(fn (x) (>= x 3))
(list 1 2 3 4))
(list (list 1 2) (list 3 4)))
(hk-test
"foldl"
(hk-foldl
(fn (a b) (- a b))
10
(list 1 2 3))
4)
(hk-test
"foldr"
(hk-foldr cons (list) (list 1 2 3))
(list 1 2 3))
(hk-test
"scanl"
(hk-scanl + 0 (list 1 2 3))
(list 0 1 3 6))
;; ---------------------------------------------------------------------------
;; 7. Maybe / Either
;; ---------------------------------------------------------------------------
(hk-test "nothing is-nothing?" (hk-is-nothing? hk-nothing) true)
(hk-test "nothing is-just?" (hk-is-just? hk-nothing) false)
(hk-test "just is-just?" (hk-is-just? (hk-just 42)) true)
(hk-test "just is-nothing?" (hk-is-nothing? (hk-just 42)) false)
(hk-test "from-just" (hk-from-just (hk-just 99)) 99)
(hk-test
"from-maybe nothing"
(hk-from-maybe 0 hk-nothing)
0)
(hk-test
"from-maybe just"
(hk-from-maybe 0 (hk-just 42))
42)
(hk-test
"maybe nothing"
(hk-maybe 0 (fn (x) (* x 2)) hk-nothing)
0)
(hk-test
"maybe just"
(hk-maybe 0 (fn (x) (* x 2)) (hk-just 5))
10)
(hk-test "left is-left?" (hk-is-left? (hk-left "e")) true)
(hk-test "right is-right?" (hk-is-right? (hk-right 42)) true)
(hk-test "from-right" (hk-from-right (hk-right 7)) 7)
(hk-test
"either left"
(hk-either (fn (x) (str "L" x)) (fn (x) (str "R" x)) (hk-left "err"))
"Lerr")
(hk-test
"either right"
(hk-either
(fn (x) (str "L" x))
(fn (x) (str "R" x))
(hk-right 42))
"R42")
;; ---------------------------------------------------------------------------
;; 8. Tuples
;; ---------------------------------------------------------------------------
(hk-test "pair" (hk-pair 1 2) (list 1 2))
(hk-test "fst" (hk-fst (hk-pair 3 4)) 3)
(hk-test "snd" (hk-snd (hk-pair 3 4)) 4)
(hk-test
"triple"
(hk-triple 1 2 3)
(list 1 2 3))
(hk-test
"fst3"
(hk-fst3 (hk-triple 7 8 9))
7)
(hk-test
"thd3"
(hk-thd3 (hk-triple 7 8 9))
9)
(hk-test "curry" ((hk-curry +) 3 4) 7)
(hk-test
"uncurry"
((hk-uncurry (fn (a b) (* a b))) (list 3 4))
12)
;; ---------------------------------------------------------------------------
;; 9. String helpers
;; ---------------------------------------------------------------------------
(hk-test "words" (hk-words "hello world") (list "hello" "world"))
(hk-test "words leading ws" (hk-words " foo bar") (list "foo" "bar"))
(hk-test "words empty" (hk-words "") (list))
(hk-test "unwords" (hk-unwords (list "a" "b" "c")) "a b c")
(hk-test "unwords single" (hk-unwords (list "x")) "x")
(hk-test "lines" (hk-lines "a\nb\nc") (list "a" "b" "c"))
(hk-test "lines single" (hk-lines "hello") (list "hello"))
(hk-test "unlines" (hk-unlines (list "a" "b")) "a\nb\n")
(hk-test "is-prefix-of yes" (hk-is-prefix-of "he" "hello") true)
(hk-test "is-prefix-of no" (hk-is-prefix-of "wo" "hello") false)
(hk-test "is-prefix-of eq" (hk-is-prefix-of "hi" "hi") true)
(hk-test "is-prefix-of empty" (hk-is-prefix-of "" "hi") true)
(hk-test "is-suffix-of yes" (hk-is-suffix-of "lo" "hello") true)
(hk-test "is-suffix-of no" (hk-is-suffix-of "he" "hello") false)
(hk-test "is-suffix-of empty" (hk-is-suffix-of "" "hi") true)
(hk-test "is-infix-of yes" (hk-is-infix-of "ell" "hello") true)
(hk-test "is-infix-of no" (hk-is-infix-of "xyz" "hello") false)
(hk-test "is-infix-of empty" (hk-is-infix-of "" "hello") true)
;; ---------------------------------------------------------------------------
;; 10. Show
;; ---------------------------------------------------------------------------
(hk-test "show nil" (hk-show nil) "Nothing")
(hk-test "show true" (hk-show true) "True")
(hk-test "show false" (hk-show false) "False")
(hk-test "show int" (hk-show 42) "42")
(hk-test "show string" (hk-show "hi") "\"hi\"")
(hk-test
"show list"
(hk-show (list 1 2 3))
"[1,2,3]")
(hk-test "show empty list" (hk-show (list)) "[]")
;; ---------------------------------------------------------------------------
;; Summary (required by test.sh — last expression is the return value)
;; ---------------------------------------------------------------------------
(list hk-test-pass hk-test-fail)

View File

@@ -49,8 +49,6 @@ trap "rm -f $TMPFILE" EXIT
echo '(load "lib/js/transpile.sx")'
echo '(epoch 5)'
echo '(load "lib/js/runtime.sx")'
echo '(epoch 6)'
echo '(load "lib/js/regex.sx")'
epoch=100
for f in "${FIXTURES[@]}"; do

View File

@@ -1,943 +0,0 @@
;; lib/js/regex.sx — pure-SX recursive backtracking regex engine
;;
;; Installed via (js-regex-platform-override! ...) at load time.
;; Covers: character classes (\d\w\s . [abc] [^abc] [a-z]),
;; anchors (^ $ \b \B), quantifiers (* + ? {n,m} lazy variants),
;; groups (capturing + non-capturing), alternation (a|b),
;; flags: i (case-insensitive), g (global), m (multiline).
;;
;; Architecture:
;; 1. rx-parse-pattern — pattern string → compiled node list
;; 2. rx-match-nodes — recursive backtracker
;; 3. rx-exec / rx-test — public interface
;; 4. Install as {:test rx-test :exec rx-exec}
;; ── Utilities ─────────────────────────────────────────────────────
(define
rx-char-at
(fn (s i) (if (and (>= i 0) (< i (len s))) (char-at s i) "")))
(define
rx-digit?
(fn
(c)
(and (not (= c "")) (>= (char-code c) 48) (<= (char-code c) 57))))
(define
rx-word?
(fn
(c)
(and
(not (= c ""))
(or
(and (>= (char-code c) 65) (<= (char-code c) 90))
(and (>= (char-code c) 97) (<= (char-code c) 122))
(and (>= (char-code c) 48) (<= (char-code c) 57))
(= c "_")))))
(define
rx-space?
(fn
(c)
(or (= c " ") (= c "\t") (= c "\n") (= c "\r") (= c "\\f") (= c ""))))
(define rx-newline? (fn (c) (or (= c "\n") (= c "\r"))))
(define
rx-downcase-char
(fn
(c)
(let
((cc (char-code c)))
(if (and (>= cc 65) (<= cc 90)) (char-from-code (+ cc 32)) c))))
(define
rx-char-eq?
(fn
(a b ci?)
(if ci? (= (rx-downcase-char a) (rx-downcase-char b)) (= a b))))
(define
rx-parse-int
(fn
(pat i acc)
(let
((c (rx-char-at pat i)))
(if
(rx-digit? c)
(rx-parse-int pat (+ i 1) (+ (* acc 10) (- (char-code c) 48)))
(list acc i)))))
(define
rx-hex-digit-val
(fn
(c)
(cond
((and (>= (char-code c) 48) (<= (char-code c) 57))
(- (char-code c) 48))
((and (>= (char-code c) 65) (<= (char-code c) 70))
(+ 10 (- (char-code c) 65)))
((and (>= (char-code c) 97) (<= (char-code c) 102))
(+ 10 (- (char-code c) 97)))
(else -1))))
(define
rx-parse-hex-n
(fn
(pat i n acc)
(if
(= n 0)
(list (char-from-code acc) i)
(let
((v (rx-hex-digit-val (rx-char-at pat i))))
(if
(< v 0)
(list (char-from-code acc) i)
(rx-parse-hex-n pat (+ i 1) (- n 1) (+ (* acc 16) v)))))))
;; ── Pattern compiler ──────────────────────────────────────────────
;; Node types (stored in dicts with "__t__" key):
;; literal : {:__t__ "literal" :__c__ char}
;; any : {:__t__ "any"}
;; class-d : {:__t__ "class-d" :__neg__ bool}
;; class-w : {:__t__ "class-w" :__neg__ bool}
;; class-s : {:__t__ "class-s" :__neg__ bool}
;; char-class: {:__t__ "char-class" :__neg__ bool :__items__ list}
;; anchor-start / anchor-end / anchor-word / anchor-nonword
;; quant : {:__t__ "quant" :__node__ n :__min__ m :__max__ mx :__lazy__ bool}
;; group : {:__t__ "group" :__idx__ i :__nodes__ list}
;; ncgroup : {:__t__ "ncgroup" :__nodes__ list}
;; alt : {:__t__ "alt" :__branches__ list-of-node-lists}
;; parse one escape after `\`, returns (node new-i)
(define
rx-parse-escape
(fn
(pat i)
(let
((c (rx-char-at pat i)))
(cond
((= c "d") (list (dict "__t__" "class-d" "__neg__" false) (+ i 1)))
((= c "D") (list (dict "__t__" "class-d" "__neg__" true) (+ i 1)))
((= c "w") (list (dict "__t__" "class-w" "__neg__" false) (+ i 1)))
((= c "W") (list (dict "__t__" "class-w" "__neg__" true) (+ i 1)))
((= c "s") (list (dict "__t__" "class-s" "__neg__" false) (+ i 1)))
((= c "S") (list (dict "__t__" "class-s" "__neg__" true) (+ i 1)))
((= c "b") (list (dict "__t__" "anchor-word") (+ i 1)))
((= c "B") (list (dict "__t__" "anchor-nonword") (+ i 1)))
((= c "n") (list (dict "__t__" "literal" "__c__" "\n") (+ i 1)))
((= c "r") (list (dict "__t__" "literal" "__c__" "\r") (+ i 1)))
((= c "t") (list (dict "__t__" "literal" "__c__" "\t") (+ i 1)))
((= c "f") (list (dict "__t__" "literal" "__c__" "\\f") (+ i 1)))
((= c "v") (list (dict "__t__" "literal" "__c__" "") (+ i 1)))
((= c "u")
(let
((res (rx-parse-hex-n pat (+ i 1) 4 0)))
(list (dict "__t__" "literal" "__c__" (nth res 0)) (nth res 1))))
((= c "x")
(let
((res (rx-parse-hex-n pat (+ i 1) 2 0)))
(list (dict "__t__" "literal" "__c__" (nth res 0)) (nth res 1))))
(else (list (dict "__t__" "literal" "__c__" c) (+ i 1)))))))
;; parse a char-class item inside [...], returns (item new-i)
(define
rx-parse-class-item
(fn
(pat i)
(let
((c (rx-char-at pat i)))
(cond
((= c "\\")
(let
((esc (rx-parse-escape pat (+ i 1))))
(let
((node (nth esc 0)) (ni (nth esc 1)))
(let
((t (get node "__t__")))
(cond
((= t "class-d")
(list
(dict "kind" "class-d" "neg" (get node "__neg__"))
ni))
((= t "class-w")
(list
(dict "kind" "class-w" "neg" (get node "__neg__"))
ni))
((= t "class-s")
(list
(dict "kind" "class-s" "neg" (get node "__neg__"))
ni))
(else
(let
((lc (get node "__c__")))
(if
(and
(= (rx-char-at pat ni) "-")
(not (= (rx-char-at pat (+ ni 1)) "]")))
(let
((hi-c (rx-char-at pat (+ ni 1))))
(list
(dict "kind" "range" "lo" lc "hi" hi-c)
(+ ni 2)))
(list (dict "kind" "lit" "c" lc) ni)))))))))
(else
(if
(and
(not (= c ""))
(= (rx-char-at pat (+ i 1)) "-")
(not (= (rx-char-at pat (+ i 2)) "]"))
(not (= (rx-char-at pat (+ i 2)) "")))
(let
((hi-c (rx-char-at pat (+ i 2))))
(list (dict "kind" "range" "lo" c "hi" hi-c) (+ i 3)))
(list (dict "kind" "lit" "c" c) (+ i 1))))))))
(define
rx-parse-class-items
(fn
(pat i items)
(let
((c (rx-char-at pat i)))
(if
(or (= c "]") (= c ""))
(list items i)
(let
((res (rx-parse-class-item pat i)))
(begin
(append! items (nth res 0))
(rx-parse-class-items pat (nth res 1) items)))))))
;; parse a sequence until stop-ch or EOF; returns (nodes new-i groups-count)
(define
rx-parse-seq
(fn
(pat i stop-ch ds)
(let
((c (rx-char-at pat i)))
(cond
((= c "") (list (get ds "nodes") i (get ds "groups")))
((= c stop-ch) (list (get ds "nodes") i (get ds "groups")))
((= c "|") (rx-parse-alt-rest pat i ds))
(else
(let
((res (rx-parse-atom pat i ds)))
(let
((node (nth res 0)) (ni (nth res 1)) (ds2 (nth res 2)))
(let
((qres (rx-parse-quant pat ni node)))
(begin
(append! (get ds2 "nodes") (nth qres 0))
(rx-parse-seq pat (nth qres 1) stop-ch ds2))))))))))
;; when we hit | inside a sequence, collect all alternatives
(define
rx-parse-alt-rest
(fn
(pat i ds)
(let
((left-branch (get ds "nodes")) (branches (list)))
(begin
(append! branches left-branch)
(rx-parse-alt-branches pat i (get ds "groups") branches)))))
(define
rx-parse-alt-branches
(fn
(pat i n-groups branches)
(let
((new-nodes (list)) (ds2 (dict "groups" n-groups "nodes" new-nodes)))
(let
((res (rx-parse-seq pat (+ i 1) "|" ds2)))
(begin
(append! branches (nth res 0))
(let
((ni2 (nth res 1)) (g2 (nth res 2)))
(if
(= (rx-char-at pat ni2) "|")
(rx-parse-alt-branches pat ni2 g2 branches)
(list
(list (dict "__t__" "alt" "__branches__" branches))
ni2
g2))))))))
;; parse quantifier suffix, returns (node new-i)
(define
rx-parse-quant
(fn
(pat i node)
(let
((c (rx-char-at pat i)))
(cond
((= c "*")
(let
((lazy? (= (rx-char-at pat (+ i 1)) "?")))
(list
(dict
"__t__"
"quant"
"__node__"
node
"__min__"
0
"__max__"
-1
"__lazy__"
lazy?)
(if lazy? (+ i 2) (+ i 1)))))
((= c "+")
(let
((lazy? (= (rx-char-at pat (+ i 1)) "?")))
(list
(dict
"__t__"
"quant"
"__node__"
node
"__min__"
1
"__max__"
-1
"__lazy__"
lazy?)
(if lazy? (+ i 2) (+ i 1)))))
((= c "?")
(let
((lazy? (= (rx-char-at pat (+ i 1)) "?")))
(list
(dict
"__t__"
"quant"
"__node__"
node
"__min__"
0
"__max__"
1
"__lazy__"
lazy?)
(if lazy? (+ i 2) (+ i 1)))))
((= c "{")
(let
((mres (rx-parse-int pat (+ i 1) 0)))
(let
((mn (nth mres 0)) (mi (nth mres 1)))
(let
((sep (rx-char-at pat mi)))
(cond
((= sep "}")
(let
((lazy? (= (rx-char-at pat (+ mi 1)) "?")))
(list
(dict
"__t__"
"quant"
"__node__"
node
"__min__"
mn
"__max__"
mn
"__lazy__"
lazy?)
(if lazy? (+ mi 2) (+ mi 1)))))
((= sep ",")
(let
((c2 (rx-char-at pat (+ mi 1))))
(if
(= c2 "}")
(let
((lazy? (= (rx-char-at pat (+ mi 2)) "?")))
(list
(dict
"__t__"
"quant"
"__node__"
node
"__min__"
mn
"__max__"
-1
"__lazy__"
lazy?)
(if lazy? (+ mi 3) (+ mi 2))))
(let
((mxres (rx-parse-int pat (+ mi 1) 0)))
(let
((mx (nth mxres 0)) (mxi (nth mxres 1)))
(let
((lazy? (= (rx-char-at pat (+ mxi 1)) "?")))
(list
(dict
"__t__"
"quant"
"__node__"
node
"__min__"
mn
"__max__"
mx
"__lazy__"
lazy?)
(if lazy? (+ mxi 2) (+ mxi 1)))))))))
(else (list node i)))))))
(else (list node i))))))
;; parse one atom, returns (node new-i new-ds)
(define
rx-parse-atom
(fn
(pat i ds)
(let
((c (rx-char-at pat i)))
(cond
((= c ".") (list (dict "__t__" "any") (+ i 1) ds))
((= c "^") (list (dict "__t__" "anchor-start") (+ i 1) ds))
((= c "$") (list (dict "__t__" "anchor-end") (+ i 1) ds))
((= c "\\")
(let
((esc (rx-parse-escape pat (+ i 1))))
(list (nth esc 0) (nth esc 1) ds)))
((= c "[")
(let
((neg? (= (rx-char-at pat (+ i 1)) "^")))
(let
((start (if neg? (+ i 2) (+ i 1))) (items (list)))
(let
((res (rx-parse-class-items pat start items)))
(let
((ci (nth res 1)))
(list
(dict
"__t__"
"char-class"
"__neg__"
neg?
"__items__"
items)
(+ ci 1)
ds))))))
((= c "(")
(let
((c2 (rx-char-at pat (+ i 1))))
(if
(and (= c2 "?") (= (rx-char-at pat (+ i 2)) ":"))
(let
((inner-nodes (list))
(inner-ds
(dict "groups" (get ds "groups") "nodes" inner-nodes)))
(let
((res (rx-parse-seq pat (+ i 3) ")" inner-ds)))
(list
(dict "__t__" "ncgroup" "__nodes__" (nth res 0))
(+ (nth res 1) 1)
(dict "groups" (nth res 2) "nodes" (get ds "nodes")))))
(let
((gidx (+ (get ds "groups") 1)) (inner-nodes (list)))
(let
((inner-ds (dict "groups" gidx "nodes" inner-nodes)))
(let
((res (rx-parse-seq pat (+ i 1) ")" inner-ds)))
(list
(dict
"__t__"
"group"
"__idx__"
gidx
"__nodes__"
(nth res 0))
(+ (nth res 1) 1)
(dict "groups" (nth res 2) "nodes" (get ds "nodes")))))))))
(else (list (dict "__t__" "literal" "__c__" c) (+ i 1) ds))))))
;; top-level compile
(define
rx-compile
(fn
(pattern)
(let
((nodes (list)) (ds (dict "groups" 0 "nodes" nodes)))
(let
((res (rx-parse-seq pattern 0 "" ds)))
(dict "nodes" (nth res 0) "ngroups" (nth res 2))))))
;; ── Matcher ───────────────────────────────────────────────────────
;; Match a char-class item against character c
(define
rx-item-matches?
(fn
(item c ci?)
(let
((kind (get item "kind")))
(cond
((= kind "lit") (rx-char-eq? c (get item "c") ci?))
((= kind "range")
(let
((lo (if ci? (rx-downcase-char (get item "lo")) (get item "lo")))
(hi
(if ci? (rx-downcase-char (get item "hi")) (get item "hi")))
(dc (if ci? (rx-downcase-char c) c)))
(and
(>= (char-code dc) (char-code lo))
(<= (char-code dc) (char-code hi)))))
((= kind "class-d")
(let ((m (rx-digit? c))) (if (get item "neg") (not m) m)))
((= kind "class-w")
(let ((m (rx-word? c))) (if (get item "neg") (not m) m)))
((= kind "class-s")
(let ((m (rx-space? c))) (if (get item "neg") (not m) m)))
(else false)))))
(define
rx-class-items-any?
(fn
(items c ci?)
(if
(empty? items)
false
(if
(rx-item-matches? (first items) c ci?)
true
(rx-class-items-any? (rest items) c ci?)))))
(define
rx-class-matches?
(fn
(node c ci?)
(let
((neg? (get node "__neg__")) (items (get node "__items__")))
(let
((hit (rx-class-items-any? items c ci?)))
(if neg? (not hit) hit)))))
;; Word boundary check
(define
rx-is-word-boundary?
(fn
(s i slen)
(let
((before (if (> i 0) (rx-word? (char-at s (- i 1))) false))
(after (if (< i slen) (rx-word? (char-at s i)) false)))
(not (= before after)))))
;; ── Core matcher ──────────────────────────────────────────────────
;;
;; rx-match-nodes : nodes s i slen ci? mi? groups → end-pos or -1
;;
;; Matches `nodes` starting at position `i` in string `s`.
;; Returns the position after the last character consumed, or -1 on failure.
;; Mutates `groups` dict to record captures.
(define
rx-match-nodes
(fn
(nodes s i slen ci? mi? groups)
(if
(empty? nodes)
i
(let
((node (first nodes)) (rest-nodes (rest nodes)))
(let
((t (get node "__t__")))
(cond
((= t "literal")
(if
(and
(< i slen)
(rx-char-eq? (char-at s i) (get node "__c__") ci?))
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
-1))
((= t "any")
(if
(and (< i slen) (not (rx-newline? (char-at s i))))
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
-1))
((= t "class-d")
(let
((m (and (< i slen) (rx-digit? (char-at s i)))))
(if
(if (get node "__neg__") (not m) m)
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
-1)))
((= t "class-w")
(let
((m (and (< i slen) (rx-word? (char-at s i)))))
(if
(if (get node "__neg__") (not m) m)
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
-1)))
((= t "class-s")
(let
((m (and (< i slen) (rx-space? (char-at s i)))))
(if
(if (get node "__neg__") (not m) m)
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
-1)))
((= t "char-class")
(if
(and (< i slen) (rx-class-matches? node (char-at s i) ci?))
(rx-match-nodes rest-nodes s (+ i 1) slen ci? mi? groups)
-1))
((= t "anchor-start")
(if
(or
(= i 0)
(and mi? (rx-newline? (rx-char-at s (- i 1)))))
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
-1))
((= t "anchor-end")
(if
(or (= i slen) (and mi? (rx-newline? (rx-char-at s i))))
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
-1))
((= t "anchor-word")
(if
(rx-is-word-boundary? s i slen)
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
-1))
((= t "anchor-nonword")
(if
(not (rx-is-word-boundary? s i slen))
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
-1))
((= t "group")
(let
((gidx (get node "__idx__"))
(inner (get node "__nodes__")))
(let
((g-end (rx-match-nodes inner s i slen ci? mi? groups)))
(if
(>= g-end 0)
(begin
(dict-set!
groups
(js-to-string gidx)
(substring s i g-end))
(let
((final-end (rx-match-nodes rest-nodes s g-end slen ci? mi? groups)))
(if
(>= final-end 0)
final-end
(begin
(dict-set! groups (js-to-string gidx) nil)
-1))))
-1))))
((= t "ncgroup")
(let
((inner (get node "__nodes__")))
(rx-match-nodes
(append inner rest-nodes)
s
i
slen
ci?
mi?
groups)))
((= t "alt")
(let
((branches (get node "__branches__")))
(rx-try-branches branches rest-nodes s i slen ci? mi? groups)))
((= t "quant")
(let
((inner-node (get node "__node__"))
(mn (get node "__min__"))
(mx (get node "__max__"))
(lazy? (get node "__lazy__")))
(if
lazy?
(rx-quant-lazy
inner-node
mn
mx
rest-nodes
s
i
slen
ci?
mi?
groups
0)
(rx-quant-greedy
inner-node
mn
mx
rest-nodes
s
i
slen
ci?
mi?
groups
0))))
(else -1)))))))
(define
rx-try-branches
(fn
(branches rest-nodes s i slen ci? mi? groups)
(if
(empty? branches)
-1
(let
((res (rx-match-nodes (append (first branches) rest-nodes) s i slen ci? mi? groups)))
(if
(>= res 0)
res
(rx-try-branches (rest branches) rest-nodes s i slen ci? mi? groups))))))
;; Greedy: expand as far as possible, then try rest from the longest match
;; Strategy: recurse forward (extend first); only try rest when extension fails
(define
rx-quant-greedy
(fn
(inner-node mn mx rest-nodes s i slen ci? mi? groups count)
(let
((can-extend (and (< i slen) (or (= mx -1) (< count mx)))))
(if
can-extend
(let
((ni (rx-match-one inner-node s i slen ci? mi? groups)))
(if
(>= ni 0)
(let
((res (rx-quant-greedy inner-node mn mx rest-nodes s ni slen ci? mi? groups (+ count 1))))
(if
(>= res 0)
res
(if
(>= count mn)
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
-1)))
(if
(>= count mn)
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
-1)))
(if
(>= count mn)
(rx-match-nodes rest-nodes s i slen ci? mi? groups)
-1)))))
;; Lazy: try rest first, extend only if rest fails
(define
rx-quant-lazy
(fn
(inner-node mn mx rest-nodes s i slen ci? mi? groups count)
(if
(>= count mn)
(let
((res (rx-match-nodes rest-nodes s i slen ci? mi? groups)))
(if
(>= res 0)
res
(if
(and (< i slen) (or (= mx -1) (< count mx)))
(let
((ni (rx-match-one inner-node s i slen ci? mi? groups)))
(if
(>= ni 0)
(rx-quant-lazy
inner-node
mn
mx
rest-nodes
s
ni
slen
ci?
mi?
groups
(+ count 1))
-1))
-1)))
(if
(< i slen)
(let
((ni (rx-match-one inner-node s i slen ci? mi? groups)))
(if
(>= ni 0)
(rx-quant-lazy
inner-node
mn
mx
rest-nodes
s
ni
slen
ci?
mi?
groups
(+ count 1))
-1))
-1))))
;; Match a single node at position i, return new pos or -1
(define
rx-match-one
(fn
(node s i slen ci? mi? groups)
(rx-match-nodes (list node) s i slen ci? mi? groups)))
;; ── Engine entry points ───────────────────────────────────────────
;; Try matching at exactly position i. Returns result dict or nil.
(define
rx-try-at
(fn
(compiled s i slen ci? mi?)
(let
((nodes (get compiled "nodes")) (ngroups (get compiled "ngroups")))
(let
((groups (dict)))
(let
((end (rx-match-nodes nodes s i slen ci? mi? groups)))
(if
(>= end 0)
(dict "start" i "end" end "groups" groups "ngroups" ngroups)
nil))))))
;; Find first match scanning from search-start.
(define
rx-find-from
(fn
(compiled s search-start slen ci? mi?)
(if
(> search-start slen)
nil
(let
((res (rx-try-at compiled s search-start slen ci? mi?)))
(if
res
res
(rx-find-from compiled s (+ search-start 1) slen ci? mi?))))))
;; Build exec result dict from raw match result
(define
rx-build-exec-result
(fn
(s match-res)
(let
((start (get match-res "start"))
(end (get match-res "end"))
(groups (get match-res "groups"))
(ngroups (get match-res "ngroups")))
(let
((matched (substring s start end))
(caps (rx-build-captures groups ngroups 1)))
(dict "match" matched "index" start "input" s "groups" caps)))))
(define
rx-build-captures
(fn
(groups ngroups idx)
(if
(> idx ngroups)
(list)
(let
((cap (get groups (js-to-string idx))))
(cons
(if (= cap nil) :js-undefined cap)
(rx-build-captures groups ngroups (+ idx 1)))))))
;; ── Public interface ──────────────────────────────────────────────
;; Lazy compile: build NFA on first use, cache under "__compiled__"
(define
rx-ensure-compiled!
(fn
(rx)
(if
(dict-has? rx "__compiled__")
(get rx "__compiled__")
(let
((c (rx-compile (get rx "source"))))
(begin (dict-set! rx "__compiled__" c) c)))))
(define
rx-test
(fn
(rx s)
(let
((compiled (rx-ensure-compiled! rx))
(ci? (get rx "ignoreCase"))
(mi? (get rx "multiline"))
(slen (len s)))
(let
((start (if (get rx "global") (let ((li (get rx "lastIndex"))) (if (number? li) li 0)) 0)))
(let
((res (rx-find-from compiled s start slen ci? mi?)))
(if
(get rx "global")
(begin
(dict-set! rx "lastIndex" (if res (get res "end") 0))
(if res true false))
(if res true false)))))))
(define
rx-exec
(fn
(rx s)
(let
((compiled (rx-ensure-compiled! rx))
(ci? (get rx "ignoreCase"))
(mi? (get rx "multiline"))
(slen (len s)))
(let
((start (if (get rx "global") (let ((li (get rx "lastIndex"))) (if (number? li) li 0)) 0)))
(let
((res (rx-find-from compiled s start slen ci? mi?)))
(if
res
(begin
(when
(get rx "global")
(dict-set! rx "lastIndex" (get res "end")))
(rx-build-exec-result s res))
(begin
(when (get rx "global") (dict-set! rx "lastIndex" 0))
nil)))))))
;; match-all for String.prototype.matchAll
(define
js-regex-match-all
(fn
(rx s)
(let
((compiled (rx-ensure-compiled! rx))
(ci? (get rx "ignoreCase"))
(mi? (get rx "multiline"))
(slen (len s))
(results (list)))
(rx-match-all-loop compiled s 0 slen ci? mi? results))))
(define
rx-match-all-loop
(fn
(compiled s i slen ci? mi? results)
(if
(> i slen)
results
(let
((res (rx-find-from compiled s i slen ci? mi?)))
(if
res
(begin
(append! results (rx-build-exec-result s res))
(let
((next (get res "end")))
(rx-match-all-loop
compiled
s
(if (= next i) (+ i 1) next)
slen
ci?
mi?
results)))
results)))))
;; ── Install platform ──────────────────────────────────────────────
(js-regex-platform-override! "test" rx-test)
(js-regex-platform-override! "exec" rx-exec)

View File

@@ -2032,15 +2032,7 @@
(&rest args)
(cond
((= (len args) 0) nil)
((js-regex? (nth args 0))
(let
((rx (nth args 0)))
(let
((impl (get __js_regex_platform__ "exec")))
(if
(js-undefined? impl)
(js-regex-stub-exec rx s)
(impl rx s)))))
((js-regex? (nth args 0)) (js-regex-stub-exec (nth args 0) s))
(else
(let
((needle (js-to-string (nth args 0))))
@@ -2049,7 +2041,7 @@
(if
(= idx -1)
nil
(let ((res (list))) (begin (append! res needle) res)))))))))
(let ((res (list))) (append! res needle) res))))))))
((= name "at")
(fn
(i)
@@ -2107,20 +2099,6 @@
((= name "toWellFormed") (fn () s))
(else js-undefined))))
(define __js_tdz_sentinel__ (dict "__tdz__" true))
(define js-tdz? (fn (v) (and (dict? v) (dict-has? v "__tdz__"))))
(define
js-tdz-check
(fn
(name val)
(if
(js-tdz? val)
(raise
(TypeError (str "Cannot access '" name "' before initialization")))
val)))
(define
js-string-slice
(fn

View File

@@ -1,239 +0,0 @@
;; lib/js/stdlib.sx — Phase 22 JS additions
;;
;; Adds to lib/js/runtime.sx (already loaded):
;; 1. Bitwise binary ops (js-bitand/bitor/bitxor/lshift/rshift/urshift/bitnot)
;; 2. Map class (arbitrary-key hash map via list of pairs)
;; 3. Set class (uniqueness collection via SX make-set)
;; 4. RegExp constructor (wraps js-regex-new already in runtime)
;; 5. Wires Map / Set / RegExp into js-global
;; ---------------------------------------------------------------------------
;; 1. Bitwise binary ops
;; JS coerces operands to 32-bit signed int before applying the op.
;; Use truncate (not js-num-to-int) since integer / 0 crashes the evaluator.
;; ---------------------------------------------------------------------------
(define
(js-bitand a b)
(bitwise-and (truncate (js-to-number a)) (truncate (js-to-number b))))
(define
(js-bitor a b)
(bitwise-or (truncate (js-to-number a)) (truncate (js-to-number b))))
(define
(js-bitxor a b)
(bitwise-xor (truncate (js-to-number a)) (truncate (js-to-number b))))
;; << : left-shift by (b mod 32) positions
(define
(js-lshift a b)
(arithmetic-shift
(truncate (js-to-number a))
(modulo (truncate (js-to-number b)) 32)))
;; >> : arithmetic right-shift (sign-extending)
(define
(js-rshift a b)
(arithmetic-shift
(truncate (js-to-number a))
(- 0 (modulo (truncate (js-to-number b)) 32))))
;; >>> : logical right-shift (zero-extending)
;; Convert to uint32 first, then divide by 2^n.
(define
(js-urshift a b)
(let
((u32 (modulo (truncate (js-to-number a)) 4294967296))
(n (modulo (truncate (js-to-number b)) 32)))
(quotient u32 (arithmetic-shift 1 n))))
;; ~ : bitwise NOT — equivalent to -(n+1) in 32-bit signed arithmetic
(define (js-bitnot a) (bitwise-not (truncate (js-to-number a))))
;; ---------------------------------------------------------------------------
;; 2. Map class
;; Stored as {:__js_map__ true :size N :_pairs (list (list key val) ...)}
;; Mutation via dict-set! on the underlying dict.
;; ---------------------------------------------------------------------------
(define
(js-map-new)
(let
((m (dict)))
(dict-set! m "__js_map__" true)
(dict-set! m "size" 0)
(dict-set! m "_pairs" (list))
m))
(define (js-map? v) (and (dict? v) (dict-has? v "__js_map__")))
;; Linear scan for key using ===; returns index or -1
(define
(js-map-find-idx pairs k)
(letrec
((go (fn (ps i) (cond ((= (len ps) 0) -1) ((js-strict-eq (first (first ps)) k) i) (else (go (rest ps) (+ i 1)))))))
(go pairs 0)))
(define
(js-map-get m k)
(letrec
((go (fn (ps) (if (= (len ps) 0) js-undefined (if (js-strict-eq (first (first ps)) k) (nth (first ps) 1) (go (rest ps)))))))
(go (get m "_pairs"))))
;; Replace element at index i in list
(define
(js-list-set-nth lst i newval)
(letrec
((go (fn (ps j) (if (= (len ps) 0) (list) (cons (if (= j i) newval (first ps)) (go (rest ps) (+ j 1)))))))
(go lst 0)))
;; Remove element at index i from list
(define
(js-list-remove-nth lst i)
(letrec
((go (fn (ps j) (if (= (len ps) 0) (list) (if (= j i) (go (rest ps) (+ j 1)) (cons (first ps) (go (rest ps) (+ j 1))))))))
(go lst 0)))
(define
(js-map-set! m k v)
(let
((pairs (get m "_pairs")) (idx (js-map-find-idx (get m "_pairs") k)))
(if
(= idx -1)
(begin
(dict-set! m "_pairs" (append pairs (list (list k v))))
(dict-set! m "size" (+ (get m "size") 1)))
(dict-set! m "_pairs" (js-list-set-nth pairs idx (list k v)))))
m)
(define
(js-map-has m k)
(not (= (js-map-find-idx (get m "_pairs") k) -1)))
(define
(js-map-delete! m k)
(let
((idx (js-map-find-idx (get m "_pairs") k)))
(when
(not (= idx -1))
(dict-set! m "_pairs" (js-list-remove-nth (get m "_pairs") idx))
(dict-set! m "size" (- (get m "size") 1))))
m)
(define
(js-map-clear! m)
(dict-set! m "_pairs" (list))
(dict-set! m "size" 0)
m)
(define (js-map-keys m) (map first (get m "_pairs")))
(define
(js-map-vals m)
(map (fn (p) (nth p 1)) (get m "_pairs")))
(define (js-map-entries m) (get m "_pairs"))
(define
(js-map-for-each m cb)
(for-each
(fn (p) (cb (nth p 1) (first p) m))
(get m "_pairs"))
js-undefined)
;; Map method dispatch (called from js-object-method-call in runtime)
(define
(js-map-method m name args)
(cond
((= name "set")
(js-map-set! m (nth args 0) (nth args 1)))
((= name "get") (js-map-get m (nth args 0)))
((= name "has") (js-map-has m (nth args 0)))
((= name "delete") (js-map-delete! m (nth args 0)))
((= name "clear") (js-map-clear! m))
((= name "keys") (js-map-keys m))
((= name "values") (js-map-vals m))
((= name "entries") (js-map-entries m))
((= name "forEach") (js-map-for-each m (nth args 0)))
((= name "toString") "[object Map]")
(else js-undefined)))
(define Map {:__callable__ (fn (&rest args) (let ((m (js-map-new))) (when (and (> (len args) 0) (list? (nth args 0))) (for-each (fn (entry) (js-map-set! m (nth entry 0) (nth entry 1))) (nth args 0))) m)) :prototype {:entries (fn (&rest a) (js-map-entries (js-this))) :delete (fn (&rest a) (js-map-delete! (js-this) (nth a 0))) :get (fn (&rest a) (js-map-get (js-this) (nth a 0))) :values (fn (&rest a) (js-map-vals (js-this))) :toString (fn () "[object Map]") :has (fn (&rest a) (js-map-has (js-this) (nth a 0))) :set (fn (&rest a) (js-map-set! (js-this) (nth a 0) (nth a 1))) :forEach (fn (&rest a) (js-map-for-each (js-this) (nth a 0))) :clear (fn (&rest a) (js-map-clear! (js-this))) :keys (fn (&rest a) (js-map-keys (js-this)))}})
;; ---------------------------------------------------------------------------
;; 3. Set class
;; {:__js_set__ true :size N :_set <sx-set>}
;; Note: set-member?/set-add!/set-remove! all take (set item) order.
;; ---------------------------------------------------------------------------
(define
(js-set-new)
(let
((s (dict)))
(dict-set! s "__js_set__" true)
(dict-set! s "size" 0)
(dict-set! s "_set" (make-set))
s))
(define (js-set? v) (and (dict? v) (dict-has? v "__js_set__")))
(define
(js-set-add! s v)
(let
((sx (get s "_set")))
(when
(not (set-member? sx v))
(set-add! sx v)
(dict-set! s "size" (+ (get s "size") 1))))
s)
(define (js-set-has s v) (set-member? (get s "_set") v))
(define
(js-set-delete! s v)
(let
((sx (get s "_set")))
(when
(set-member? sx v)
(set-remove! sx v)
(dict-set! s "size" (- (get s "size") 1))))
s)
(define
(js-set-clear! s)
(dict-set! s "_set" (make-set))
(dict-set! s "size" 0)
s)
(define (js-set-vals s) (set->list (get s "_set")))
(define
(js-set-for-each s cb)
(for-each (fn (v) (cb v v s)) (set->list (get s "_set")))
js-undefined)
(define Set {:__callable__ (fn (&rest args) (let ((s (js-set-new))) (when (and (> (len args) 0) (list? (nth args 0))) (for-each (fn (v) (js-set-add! s v)) (nth args 0))) s)) :prototype {:entries (fn (&rest a) (map (fn (v) (list v v)) (js-set-vals (js-this)))) :delete (fn (&rest a) (js-set-delete! (js-this) (nth a 0))) :values (fn (&rest a) (js-set-vals (js-this))) :add (fn (&rest a) (js-set-add! (js-this) (nth a 0))) :toString (fn () "[object Set]") :has (fn (&rest a) (js-set-has (js-this) (nth a 0))) :forEach (fn (&rest a) (js-set-for-each (js-this) (nth a 0))) :clear (fn (&rest a) (js-set-clear! (js-this))) :keys (fn (&rest a) (js-set-vals (js-this)))}})
;; ---------------------------------------------------------------------------
;; 4. RegExp constructor — callable lambda wrapping js-regex-new
;; ---------------------------------------------------------------------------
(define
RegExp
(fn
(&rest args)
(cond
((= (len args) 0) (js-regex-new "" ""))
((= (len args) 1)
(js-regex-new (js-to-string (nth args 0)) ""))
(else
(js-regex-new
(js-to-string (nth args 0))
(js-to-string (nth args 1)))))))
;; ---------------------------------------------------------------------------
;; 5. Wire new globals into js-global
;; ---------------------------------------------------------------------------
(dict-set! js-global "Map" Map)
(dict-set! js-global "Set" Set)
(dict-set! js-global "RegExp" RegExp)

View File

@@ -33,10 +33,6 @@ cat > "$TMPFILE" << 'EPOCHS'
(load "lib/js/transpile.sx")
(epoch 5)
(load "lib/js/runtime.sx")
(epoch 6)
(load "lib/js/regex.sx")
(epoch 7)
(load "lib/js/stdlib.sx")
;; ── Phase 0: stubs still behave ─────────────────────────────────
(epoch 10)
@@ -1327,166 +1323,6 @@ cat > "$TMPFILE" << 'EPOCHS'
(epoch 3505)
(eval "(js-eval \"var a = {length: 3, 0: 10, 1: 20, 2: 30}; var sum = 0; Array.prototype.forEach.call(a, function(x){sum += x;}); sum\")")
;; ── Phase 12: Regex engine ────────────────────────────────────────
;; Platform is installed (test key is a function, not undefined)
(epoch 5000)
(eval "(js-undefined? (get __js_regex_platform__ \"test\"))")
(epoch 5001)
(eval "(js-eval \"/foo/.test('hi foo bar')\")")
(epoch 5002)
(eval "(js-eval \"/foo/.test('hi bar')\")")
;; Case-insensitive flag
(epoch 5003)
(eval "(js-eval \"/FOO/i.test('hello foo world')\")")
;; Anchors
(epoch 5004)
(eval "(js-eval \"/^hello/.test('hello world')\")")
(epoch 5005)
(eval "(js-eval \"/^hello/.test('say hello')\")")
(epoch 5006)
(eval "(js-eval \"/world$/.test('hello world')\")")
;; Character classes
(epoch 5007)
(eval "(js-eval \"/\\\\d+/.test('abc 123')\")")
(epoch 5008)
(eval "(js-eval \"/\\\\w+/.test('hello')\")")
(epoch 5009)
(eval "(js-eval \"/[abc]/.test('dog')\")")
(epoch 5010)
(eval "(js-eval \"/[abc]/.test('cat')\")")
;; Quantifiers
(epoch 5011)
(eval "(js-eval \"/a*b/.test('b')\")")
(epoch 5012)
(eval "(js-eval \"/a+b/.test('b')\")")
(epoch 5013)
(eval "(js-eval \"/a{2,3}/.test('aa')\")")
(epoch 5014)
(eval "(js-eval \"/a{2,3}/.test('a')\")")
;; Dot
(epoch 5015)
(eval "(js-eval \"/h.llo/.test('hello')\")")
(epoch 5016)
(eval "(js-eval \"/h.llo/.test('hllo')\")")
;; exec result
(epoch 5017)
(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.match\")")
(epoch 5018)
(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.index\")")
(epoch 5019)
(eval "(js-eval \"var m = /foo(\\\\w+)/.exec('foobar'); m.groups[0]\")")
;; Alternation
(epoch 5020)
(eval "(js-eval \"/cat|dog/.test('I have a dog')\")")
(epoch 5021)
(eval "(js-eval \"/cat|dog/.test('I have a fish')\")")
;; Non-capturing group
(epoch 5022)
(eval "(js-eval \"/(?:foo)+/.test('foofoo')\")")
;; Negated char class
(epoch 5023)
(eval "(js-eval \"/[^abc]/.test('d')\")")
(epoch 5024)
(eval "(js-eval \"/[^abc]/.test('a')\")")
;; Range inside char class
(epoch 5025)
(eval "(js-eval \"/[a-z]+/.test('hello')\")")
;; Word boundary
(epoch 5026)
(eval "(js-eval \"/\\\\bword\\\\b/.test('a word here')\")")
(epoch 5027)
(eval "(js-eval \"/\\\\bword\\\\b/.test('password')\")")
;; Lazy quantifier
(epoch 5028)
(eval "(js-eval \"var m = /a+?/.exec('aaa'); m.match\")")
;; Global flag exec
(epoch 5029)
(eval "(js-eval \"var r=/\\\\d+/g; r.exec('a1b2'); r.exec('a1b2').match\")")
;; String.prototype.match with regex
(epoch 5030)
(eval "(js-eval \"'hello world'.match(/\\\\w+/).match\")")
;; String.prototype.search
(epoch 5031)
(eval "(js-eval \"'hello world'.search(/world/)\")")
;; String.prototype.replace with regex
(epoch 5032)
(eval "(js-eval \"'hello world'.replace(/world/, 'there')\")")
;; multiline anchor
(epoch 5033)
(eval "(js-eval \"/^bar/m.test('foo\\nbar')\")")
;; ── Phase 13: let/const TDZ infrastructure ───────────────────────
;; The TDZ sentinel and checker are defined in runtime.sx.
;; let/const bindings work normally after initialization.
(epoch 5100)
(eval "(js-eval \"let x = 5; x\")")
(epoch 5101)
(eval "(js-eval \"const y = 42; y\")")
;; TDZ sentinel exists and is detectable
(epoch 5102)
(eval "(js-tdz? __js_tdz_sentinel__)")
;; js-tdz-check passes through non-sentinel values
(epoch 5103)
(eval "(js-tdz-check \"x\" 42)")
;; ── Phase 22: Bitwise ops ────────────────────────────────────────
(epoch 6000)
(eval "(js-bitand 5 3)")
(epoch 6001)
(eval "(js-bitor 5 3)")
(epoch 6002)
(eval "(js-bitxor 5 3)")
(epoch 6003)
(eval "(js-lshift 1 4)")
(epoch 6004)
(eval "(js-rshift 32 2)")
(epoch 6005)
(eval "(js-rshift -8 1)")
(epoch 6006)
(eval "(js-urshift 4294967292 2)")
(epoch 6007)
(eval "(js-bitnot 0)")
;; ── Phase 22: Map ─────────────────────────────────────────────────
(epoch 6010)
(eval "(js-map? (js-map-new))")
(epoch 6011)
(eval "(get (js-map-set! (js-map-new) \"k\" 42) \"size\")")
(epoch 6012)
(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-get m \"a\"))")
(epoch 6013)
(eval "(let ((m (js-map-new))) (js-map-set! m \"x\" 9) (js-map-has m \"x\"))")
(epoch 6014)
(eval "(let ((m (js-map-new))) (js-map-set! m \"x\" 9) (js-map-has m \"y\"))")
(epoch 6015)
(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-set! m \"b\" 2) (get m \"size\"))")
(epoch 6016)
(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-delete! m \"a\") (get m \"size\"))")
(epoch 6017)
(eval "(let ((m (js-map-new))) (js-map-set! m \"a\" 1) (js-map-set! m \"a\" 99) (js-map-get m \"a\"))")
;; ── Phase 22: Set ─────────────────────────────────────────────────
(epoch 6020)
(eval "(js-set? (js-set-new))")
(epoch 6021)
(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-has s 1))")
(epoch 6022)
(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-has s 2))")
(epoch 6023)
(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-add! s 1) (get s \"size\"))")
(epoch 6024)
(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-add! s 2) (get s \"size\"))")
(epoch 6025)
(eval "(let ((s (js-set-new))) (js-set-add! s 1) (js-set-delete! s 1) (get s \"size\"))")
;; ── Phase 22: RegExp constructor ──────────────────────────────────
(epoch 6030)
(eval "(js-regex? (RegExp \"ab\" \"i\"))")
(epoch 6031)
(eval "(get (RegExp \"hello\" \"gi\") \"global\")")
(epoch 6032)
(eval "(get (RegExp \"foo\" \"i\") \"ignoreCase\")")
EPOCHS
@@ -2206,81 +2042,6 @@ check 3503 "indexOf.call arrLike" '1'
check 3504 "filter.call arrLike" '"2,3"'
check 3505 "forEach.call arrLike sum" '60'
# ── Phase 12: Regex engine ────────────────────────────────────────
check 5000 "regex platform installed" 'false'
check 5001 "/foo/ matches" 'true'
check 5002 "/foo/ no match" 'false'
check 5003 "/FOO/i case-insensitive" 'true'
check 5004 "/^hello/ anchor match" 'true'
check 5005 "/^hello/ anchor no-match" 'false'
check 5006 "/world$/ end anchor" 'true'
check 5007 "/\\d+/ digit class" 'true'
check 5008 "/\\w+/ word class" 'true'
check 5009 "/[abc]/ class no-match" 'false'
check 5010 "/[abc]/ class match" 'true'
check 5011 "/a*b/ zero-or-more" 'true'
check 5012 "/a+b/ one-or-more no-match" 'false'
check 5013 "/a{2,3}/ quant match" 'true'
check 5014 "/a{2,3}/ quant no-match" 'false'
check 5015 "dot matches any" 'true'
check 5016 "dot requires char" 'false'
check 5017 "exec match string" '"foobar"'
check 5018 "exec match index" '0'
check 5019 "exec capture group" '"bar"'
check 5020 "alternation cat|dog match" 'true'
check 5021 "alternation cat|dog no-match" 'false'
check 5022 "non-capturing group" 'true'
check 5023 "negated class match" 'true'
check 5024 "negated class no-match" 'false'
check 5025 "range [a-z]+" 'true'
check 5026 "word boundary match" 'true'
check 5027 "word boundary no-match" 'false'
check 5028 "lazy quantifier" '"a"'
check 5029 "global exec advances" '"2"'
check 5030 "String.match regex" '"hello"'
check 5031 "String.search regex" '6'
check 5032 "String.replace regex" '"hello there"'
check 5033 "multiline anchor" 'true'
# ── Phase 13: let/const TDZ infrastructure ───────────────────────
check 5100 "let binding initialized" '5'
check 5101 "const binding initialized" '42'
check 5102 "TDZ sentinel is detectable" 'true'
check 5103 "tdz-check passes non-sentinel" '42'
# ── Phase 22: Bitwise ops ─────────────────────────────────────────
check 6000 "bitand 5&3" '1'
check 6001 "bitor 5|3" '7'
check 6002 "bitxor 5^3" '6'
check 6003 "lshift 1<<4" '16'
check 6004 "rshift 32>>2" '8'
check 6005 "rshift -8>>1" '-4'
check 6006 "urshift >>>" '1073741823'
check 6007 "bitnot ~0" '-1'
# ── Phase 22: Map ─────────────────────────────────────────────────
check 6010 "map? new map" 'true'
check 6011 "map set→size 1" '1'
check 6012 "map get existing" '1'
check 6013 "map has key yes" 'true'
check 6014 "map has key no" 'false'
check 6015 "map size 2 entries" '2'
check 6016 "map delete→size 0" '0'
check 6017 "map set overwrites" '99'
# ── Phase 22: Set ─────────────────────────────────────────────────
check 6020 "set? new set" 'true'
check 6021 "set has after add" 'true'
check 6022 "set has absent" 'false'
check 6023 "set dedup size" '1'
check 6024 "set size 2" '2'
check 6025 "set delete→size 0" '0'
# ── Phase 22: RegExp ──────────────────────────────────────────────
check 6030 "RegExp? result" 'true'
check 6031 "RegExp global flag" 'true'
check 6032 "RegExp ignoreCase" 'true'
TOTAL=$((PASS + FAIL))
if [ $FAIL -eq 0 ]; then
echo "$PASS/$TOTAL JS-on-SX tests passed"

View File

@@ -798,7 +798,6 @@ class ServerSession:
self._run_and_collect(3, '(load "lib/js/parser.sx")', timeout=60.0)
self._run_and_collect(4, '(load "lib/js/transpile.sx")', timeout=60.0)
self._run_and_collect(5, '(load "lib/js/runtime.sx")', timeout=60.0)
self._run_and_collect(50, '(load "lib/js/regex.sx")', timeout=60.0)
# Preload the stub harness — use precomputed SX cache when available
# (huge win: ~15s js-eval HARNESS_STUB → ~0s load precomputed .sx).
cache_rel = _harness_cache_rel_path()

View File

@@ -935,12 +935,12 @@
(define
js-transpile-var
(fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms kind decls))))
(fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms decls))))
(define
js-vardecl-forms
(fn
(kind decls)
(decls)
(cond
((empty? decls) (list))
(else
@@ -953,7 +953,7 @@
(js-sym "define")
(js-sym (nth d 1))
(js-transpile (nth d 2)))
(js-vardecl-forms kind (rest decls))))
(js-vardecl-forms (rest decls))))
((js-tag? d "js-vardecl-obj")
(let
((names (nth d 1))
@@ -964,7 +964,7 @@
(js-vardecl-obj-forms
names
tmp-sym
(js-vardecl-forms kind (rest decls))))))
(js-vardecl-forms (rest decls))))))
((js-tag? d "js-vardecl-arr")
(let
((names (nth d 1))
@@ -976,7 +976,7 @@
names
tmp-sym
0
(js-vardecl-forms kind (rest decls))))))
(js-vardecl-forms (rest decls))))))
(else (error "js-vardecl-forms: unexpected decl"))))))))
(define

View File

@@ -123,7 +123,7 @@
(fn
(i)
(if
(not (= (get a (str i)) nil))
(has? a (str i))
(begin (set! n i) (count-loop (+ i 1)))
n)))
(count-loop 1))))
@@ -152,9 +152,7 @@
(cond
((= (first f) "pos")
(begin
(set!
t
(assoc t (str array-idx) (nth f 1)))
(set! t (assoc t (str array-idx) (nth f 1)))
(set! array-idx (+ array-idx 1))))
((= (first f) "kv")
(let
@@ -171,108 +169,3 @@
(if (= t nil) nil (let ((v (get t (str k)))) (if (= v nil) nil v)))))
(define lua-set! (fn (t k v) (assoc t (str k) v)))
;; ---------------------------------------------------------------------------
;; Helpers for stdlib
;; ---------------------------------------------------------------------------
;; Apply a char function to every character in a string
(define (lua-str-map s fn) (list->string (map fn (string->list s))))
;; Repeat string s n times
(define
(lua-str-rep s n)
(letrec
((go (fn (acc i) (if (= i 0) acc (go (str acc s) (- i 1))))))
(go "" n)))
;; Force a promise created by delay
(define
(lua-force p)
(if
(and (dict? p) (get p :_promise))
(if (get p :forced) (get p :value) ((get p :thunk)))
p))
;; ---------------------------------------------------------------------------
;; math — Lua math library
;; ---------------------------------------------------------------------------
(define math {:asin asin :floor floor :exp exp :huge 1e+308 :tan tan :sqrt sqrt :log log :abs abs :ceil ceil :sin sin :max (fn (a b) (if (> a b) a b)) :acos acos :min (fn (a b) (if (< a b) a b)) :cos cos :pi 3.14159 :atan atan})
;; ---------------------------------------------------------------------------
;; string — Lua string library
;; ---------------------------------------------------------------------------
(define
(lua-string-find s pat)
(let
((m (regexp-match (make-regexp pat) s)))
(if (= m nil) nil (list (+ (get m :start) 1) (get m :end)))))
(define
(lua-string-match s pat)
(let
((m (regexp-match (make-regexp pat) s)))
(if
(= m nil)
nil
(let
((groups (get m :groups)))
(if (= (len groups) 0) (get m :match) (first groups))))))
(define
(lua-string-gmatch s pat)
(map (fn (m) (get m :match)) (regexp-match-all (make-regexp pat) s)))
(define
(lua-string-gsub s pat repl)
(regexp-replace-all (make-regexp pat) s repl))
(define string {:rep lua-str-rep :sub (fn (s i &rest j-args) (let ((slen (len s)) (j (if (= (len j-args) 0) -1 (first j-args)))) (let ((from (if (< i 0) (let ((r (+ slen i))) (if (< r 0) 0 r)) (- i 1))) (to (if (< j 0) (let ((r (+ slen j 1))) (if (< r 0) 0 r)) (if (> j slen) slen j)))) (if (> from to) "" (substring s from to))))) :len (fn (s) (len s)) :upper (fn (s) (lua-str-map s char-upcase)) :char (fn (&rest codes) (list->string (map (fn (c) (integer->char (truncate c))) codes))) :gmatch lua-string-gmatch :gsub lua-string-gsub :lower (fn (s) (lua-str-map s char-downcase)) :byte (fn (s &rest args) (char->integer (nth (string->list s) (- (if (= (len args) 0) 1 (first args)) 1)))) :match lua-string-match :find lua-string-find :reverse (fn (s) (list->string (reverse (string->list s))))})
;; ---------------------------------------------------------------------------
;; table — Lua table library
;; ---------------------------------------------------------------------------
(define
(lua-table-insert t v)
(assoc t (str (+ (lua-len t) 1)) v))
(define
(lua-table-remove t &rest args)
(let
((n (lua-len t))
(pos (if (= (len args) 0) (lua-len t) (first args))))
(letrec
((slide (fn (t i) (if (< i n) (assoc (slide t (+ i 1)) (str i) (lua-get t (+ i 1))) (assoc t (str n) nil)))))
(slide t pos))))
(define
(lua-table-concat t &rest args)
(let
((sep (if (= (len args) 0) "" (first args)))
(n (lua-len t)))
(letrec
((go (fn (acc i) (if (> i n) acc (go (str acc (if (= i 1) "" sep) (lua-to-string (lua-get t i))) (+ i 1))))))
(go "" 1))))
(define
(lua-table-sort t)
(let
((n (lua-len t)))
(letrec
((collect (fn (i acc) (if (< i 1) acc (collect (- i 1) (cons (lua-get t i) acc)))))
(rebuild
(fn
(t i items)
(if
(= (len items) 0)
t
(rebuild
(assoc t (str i) (first items))
(+ i 1)
(rest items))))))
(rebuild t 1 (sort (collect n (list)))))))
(define table {:sort lua-table-sort :concat lua-table-concat :insert lua-table-insert :remove lua-table-remove})

View File

@@ -633,116 +633,6 @@ check 482 "while i<5 count" '5'
check 483 "repeat until i>=3" '3'
check 484 "for 1..100 sum" '5050'
# ── Phase 3: stdlib — math, string, table ──────────────────────────────────
cat >> "$TMPFILE" << 'EPOCHS2'
;; ── math library ───────────────────────────────────────────────
(epoch 500)
(eval "(lua-eval-ast \"return math.abs(-7)\")")
(epoch 501)
(eval "(lua-eval-ast \"return math.floor(3.9)\")")
(epoch 502)
(eval "(lua-eval-ast \"return math.ceil(3.1)\")")
(epoch 503)
(eval "(lua-eval-ast \"return math.sqrt(9)\")")
(epoch 504)
(eval "(lua-eval-ast \"return math.sin(0)\")")
(epoch 505)
(eval "(lua-eval-ast \"return math.cos(0)\")")
(epoch 506)
(eval "(lua-eval-ast \"return math.max(3, 7)\")")
(epoch 507)
(eval "(lua-eval-ast \"return math.min(3, 7)\")")
(epoch 508)
(eval "(lua-eval-ast \"return math.pi > 3\")")
(epoch 509)
(eval "(lua-eval-ast \"return math.huge > 0\")")
;; ── string library ─────────────────────────────────────────────
(epoch 520)
(eval "(lua-eval-ast \"return string.len(\\\"hello\\\")\")")
(epoch 521)
(eval "(lua-eval-ast \"return string.upper(\\\"hello\\\")\")")
(epoch 522)
(eval "(lua-eval-ast \"return string.lower(\\\"WORLD\\\")\")")
(epoch 523)
(eval "(lua-eval-ast \"return string.sub(\\\"hello\\\", 2, 4)\")")
(epoch 524)
(eval "(lua-eval-ast \"return string.rep(\\\"ab\\\", 3)\")")
(epoch 525)
(eval "(lua-eval-ast \"return string.reverse(\\\"hello\\\")\")")
(epoch 526)
(eval "(lua-eval-ast \"return string.byte(\\\"A\\\")\")")
(epoch 527)
(eval "(lua-eval-ast \"return string.char(72, 105)\")")
(epoch 528)
(eval "(lua-eval-ast \"return string.find(\\\"hello\\\", \\\"ll\\\")\")")
(epoch 529)
(eval "(lua-eval-ast \"return string.match(\\\"hello\\\", \\\"ell\\\")\")")
(epoch 530)
(eval "(lua-eval-ast \"return string.gsub(\\\"hello\\\", \\\"l\\\", \\\"r\\\")\")")
;; ── table library ──────────────────────────────────────────────
(epoch 540)
(eval "(lua-eval-ast \"local t = {10, 20, 30} t = table.insert(t, 40) return t[4]\")")
(epoch 541)
(eval "(lua-eval-ast \"local t = {10, 20, 30} t = table.remove(t) return t[3]\")")
(epoch 542)
(eval "(lua-eval-ast \"local t = {\\\"a\\\", \\\"b\\\", \\\"c\\\"} return table.concat(t, \\\",\\\")\")")
(epoch 543)
(eval "(lua-eval-ast \"local t = {3, 1, 2} t = table.sort(t) return t[1]\")")
(epoch 544)
(eval "(lua-eval-ast \"local t = {3, 1, 2} t = table.sort(t) return t[3]\")")
;; ── delay / force ──────────────────────────────────────────────
(epoch 550)
(eval "(lua-force (delay (+ 10 5)))")
(epoch 551)
(eval "(lua-force 42)")
EPOCHS2
OUTPUT2=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
OUTPUT="$OUTPUT
$OUTPUT2"
# math
check 500 "math.abs(-7)" '7'
check 501 "math.floor(3.9)" '3'
check 502 "math.ceil(3.1)" '4'
check 503 "math.sqrt(9)" '3'
check 504 "math.sin(0)" '0'
check 505 "math.cos(0)" '1'
check 506 "math.max(3,7)" '7'
check 507 "math.min(3,7)" '3'
check 508 "math.pi > 3" 'true'
check 509 "math.huge > 0" 'true'
# string
check 520 "string.len" '5'
check 521 "string.upper" '"HELLO"'
check 522 "string.lower" '"world"'
check 523 "string.sub(2,4)" '"ell"'
check 524 "string.rep(ab,3)" '"ababab"'
check 525 "string.reverse" '"olleh"'
check 526 "string.byte(A)" '65'
check 527 "string.char(72,105)" '"Hi"'
check 528 "string.find ll" '3'
check 529 "string.match ell" '"ell"'
check 530 "string.gsub l->r" '"herro"'
# table
check 540 "table.insert" '40'
check 541 "table.remove" 'nil'
check 542 "table.concat ," '"a,b,c"'
check 543 "table.sort [1]" '1'
check 544 "table.sort [3]" '3'
# delay/force
check 550 "lua-force delay" '15'
check 551 "lua-force non-promise" '42'
TOTAL=$((PASS + FAIL))
if [ $FAIL -eq 0 ]; then
echo "ok $PASS/$TOTAL Lua-on-SX tests passed"

View File

@@ -73,10 +73,7 @@
(define string->symbol make-symbol)
(define number->string
(let ((prim-n->s number->string))
(fn (n &rest r)
(if (= (len r) 0) (str n) (prim-n->s n (first r))))))
(define number->string (fn (n) (str n)))
(define
string->number

831
lib/ruby/parser.sx Normal file
View File

@@ -0,0 +1,831 @@
;; Ruby parser: token list → AST.
;; Entry: (rb-parse tokens) or (rb-parse-str src)
;; AST nodes: dicts with :type plus type-specific fields.
(define rb-parse
(fn (tokens)
(let ((pos 0) (tok-count (len tokens)))
(define rb-p-cur
(fn () (nth tokens pos)))
(define rb-p-peek
(fn (n)
(if (< (+ pos n) tok-count)
(nth tokens (+ pos n))
{:type "eof" :value nil :line 0 :col 0})))
(define rb-p-advance!
(fn () (set! pos (+ pos 1))))
(define rb-p-type
(fn () (get (rb-p-cur) :type)))
(define rb-p-val
(fn () (get (rb-p-cur) :value)))
(define rb-p-sep?
(fn () (or (= (rb-p-type) "newline") (= (rb-p-type) "semi"))))
(define rb-p-skip-seps!
(fn ()
(when (rb-p-sep?)
(do (rb-p-advance!) (rb-p-skip-seps!)))))
(define rb-p-skip-newlines!
(fn ()
(when (= (rb-p-type) "newline")
(do (rb-p-advance!) (rb-p-skip-newlines!)))))
(define rb-p-expect!
(fn (type)
(if (= (rb-p-type) type)
(let ((tok (rb-p-cur)))
(rb-p-advance!)
tok)
{:type "error"
:msg (join "" (list "expected " type " got " (rb-p-type)))})))
(define rb-p-expect-kw!
(fn (kw)
(when (and (= (rb-p-type) "keyword") (= (rb-p-val) kw))
(rb-p-advance!))))
;; Block: do |params| body end or { |params| body }
(define rb-p-parse-block-params
(fn ()
(if (= (rb-p-type) "pipe")
(do
(rb-p-advance!)
(let ((params (list)))
(define rb-p-bp-loop
(fn ()
(when (not (or (= (rb-p-type) "pipe") (= (rb-p-type) "eof")))
(do
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "**"))
(do
(rb-p-advance!)
(append! params {:type "param-kwrest" :name (rb-p-val)})
(rb-p-advance!)))
((and (= (rb-p-type) "op") (= (rb-p-val) "*"))
(do
(rb-p-advance!)
(if (= (rb-p-type) "ident")
(do
(append! params {:type "param-rest" :name (rb-p-val)})
(rb-p-advance!))
(append! params {:type "param-rest" :name nil}))))
(:else
(do
(append! params {:type "param-req" :name (rb-p-val)})
(rb-p-advance!))))
(when (= (rb-p-type) "comma") (rb-p-advance!))
(rb-p-bp-loop)))))
(rb-p-bp-loop)
(rb-p-expect! "pipe")
params))
(list))))
(define rb-p-parse-block
(fn ()
(cond
((and (= (rb-p-type) "keyword") (= (rb-p-val) "do"))
(do
(rb-p-advance!)
(let ((params (rb-p-parse-block-params)))
(rb-p-skip-seps!)
(let ((body (rb-p-parse-stmts (list "end"))))
(rb-p-expect-kw! "end")
{:type "block" :params params :body body}))))
((= (rb-p-type) "lbrace")
(do
(rb-p-advance!)
(let ((params (rb-p-parse-block-params)))
(rb-p-skip-seps!)
(let ((body (rb-p-parse-stmts (list "rbrace"))))
(rb-p-expect! "rbrace")
{:type "block" :params params :body body}))))
(:else nil))))
;; Method def params
(define rb-p-parse-def-params
(fn ()
(let ((params (list)))
(define rb-p-dp-one
(fn ()
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "&"))
(do
(rb-p-advance!)
(append! params {:type "param-block" :name (rb-p-val)})
(rb-p-advance!)))
((and (= (rb-p-type) "op") (= (rb-p-val) "**"))
(do
(rb-p-advance!)
(append! params {:type "param-kwrest" :name (rb-p-val)})
(rb-p-advance!)))
((and (= (rb-p-type) "op") (= (rb-p-val) "*"))
(do
(rb-p-advance!)
(if (= (rb-p-type) "ident")
(do
(append! params {:type "param-rest" :name (rb-p-val)})
(rb-p-advance!))
(append! params {:type "param-rest" :name nil}))))
((and (= (rb-p-type) "ident")
(= (get (rb-p-peek 1) :type) "colon"))
(do
(let ((name (rb-p-val)))
(rb-p-advance!)
(rb-p-advance!)
(if (or (rb-p-sep?) (= (rb-p-type) "comma")
(= (rb-p-type) "rparen") (= (rb-p-type) "eof"))
(append! params {:type "param-kw" :name name :default nil})
(append! params {:type "param-kw" :name name
:default (rb-p-parse-assign)})))))
(:else
(let ((name (rb-p-val)))
(rb-p-advance!)
(if (and (= (rb-p-type) "op") (= (rb-p-val) "="))
(do
(rb-p-advance!)
(append! params {:type "param-opt" :name name
:default (rb-p-parse-assign)}))
(append! params {:type "param-req" :name name})))))))
(define rb-p-dp-loop
(fn ()
(when (not (or (= (rb-p-type) "rparen") (rb-p-sep?)
(= (rb-p-type) "eof")))
(do
(rb-p-dp-one)
(when (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!)))
(rb-p-dp-loop)))))
(rb-p-dp-loop)
params)))
;; def [recv.] name [(params)] body end
(define rb-p-parse-def
(fn ()
(rb-p-advance!)
(let ((recv nil) (name nil))
(cond
((and (= (rb-p-type) "keyword") (= (rb-p-val) "self")
(= (get (rb-p-peek 1) :type) "dot"))
(do
(set! recv {:type "self"})
(rb-p-advance!)
(rb-p-advance!)
(set! name (rb-p-val))
(rb-p-advance!)))
((and (= (rb-p-type) "ident")
(= (get (rb-p-peek 1) :type) "dot"))
(do
(set! recv {:type "lvar" :name (rb-p-val)})
(rb-p-advance!)
(rb-p-advance!)
(set! name (rb-p-val))
(rb-p-advance!)))
(:else
(do
(set! name (rb-p-val))
(rb-p-advance!))))
(let ((params (list)))
(cond
((= (rb-p-type) "lparen")
(do
(rb-p-advance!)
(rb-p-skip-newlines!)
(set! params (rb-p-parse-def-params))
(rb-p-expect! "rparen")))
((not (or (rb-p-sep?) (= (rb-p-type) "eof")))
(set! params (rb-p-parse-def-params)))
(:else nil))
(rb-p-skip-seps!)
(let ((body (rb-p-parse-stmts (list "end"))))
(rb-p-expect-kw! "end")
{:type "method-def" :recv recv :name name
:params params :body body})))))
;; class [<<obj | Name [<Super]] body end
(define rb-p-parse-class
(fn ()
(rb-p-advance!)
(if (and (= (rb-p-type) "op") (= (rb-p-val) "<<"))
(do
(rb-p-advance!)
(let ((obj (rb-p-parse-primary)))
(rb-p-skip-seps!)
(let ((body (rb-p-parse-stmts (list "end"))))
(rb-p-expect-kw! "end")
{:type "sclass" :obj obj :body body})))
(let ((name (rb-p-parse-const-path)))
(let ((super nil))
(when (and (= (rb-p-type) "op") (= (rb-p-val) "<"))
(do
(rb-p-advance!)
(set! super (rb-p-parse-const-path))))
(rb-p-skip-seps!)
(let ((body (rb-p-parse-stmts (list "end"))))
(rb-p-expect-kw! "end")
{:type "class-def" :name name :super super :body body}))))))
;; module Name body end
(define rb-p-parse-module
(fn ()
(rb-p-advance!)
(let ((name (rb-p-parse-const-path)))
(rb-p-skip-seps!)
(let ((body (rb-p-parse-stmts (list "end"))))
(rb-p-expect-kw! "end")
{:type "module-def" :name name :body body}))))
;; Const or Const::Const::...
(define rb-p-parse-const-path
(fn ()
(let ((node {:type "const" :name (rb-p-val)}))
(rb-p-advance!)
(define rb-p-cp-loop
(fn ()
(when (= (rb-p-type) "dcolon")
(do
(rb-p-advance!)
(let ((name (rb-p-val)))
(rb-p-advance!)
(set! node {:type "const-path" :left node :name name})
(rb-p-cp-loop))))))
(rb-p-cp-loop)
node)))
;; [e, *e, ...]
(define rb-p-parse-array
(fn ()
(rb-p-advance!)
(rb-p-skip-newlines!)
(let ((elems (list)))
(define rb-p-arr-loop
(fn ()
(when (not (or (= (rb-p-type) "rbracket") (= (rb-p-type) "eof")))
(do
(if (and (= (rb-p-type) "op") (= (rb-p-val) "*"))
(do
(rb-p-advance!)
(append! elems {:type "splat" :value (rb-p-parse-assign)}))
(append! elems (rb-p-parse-assign)))
(rb-p-skip-newlines!)
(when (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!)))
(rb-p-arr-loop)))))
(rb-p-arr-loop)
(rb-p-expect! "rbracket")
{:type "array" :elems elems})))
;; {k: v, k => v, ...}
(define rb-p-parse-hash
(fn ()
(rb-p-advance!)
(rb-p-skip-newlines!)
(let ((pairs (list)))
(define rb-p-hash-loop
(fn ()
(when (not (or (= (rb-p-type) "rbrace") (= (rb-p-type) "eof")))
(do
(let ((key nil) (val nil) (style nil))
(cond
((and (or (= (rb-p-type) "ident") (= (rb-p-type) "const"))
(= (get (rb-p-peek 1) :type) "colon"))
(do
(set! key {:type "lit-sym" :value (rb-p-val)})
(set! style "colon")
(rb-p-advance!)
(rb-p-advance!)))
(:else
(do
(set! key (rb-p-parse-assign))
(set! style "rocket")
(when (and (= (rb-p-type) "op") (= (rb-p-val) "=>"))
(rb-p-advance!)))))
(rb-p-skip-newlines!)
(set! val (rb-p-parse-assign))
(append! pairs {:key key :val val :style style}))
(rb-p-skip-newlines!)
(when (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!)))
(rb-p-hash-loop)))))
(rb-p-hash-loop)
(rb-p-expect! "rbrace")
{:type "hash" :pairs pairs})))
;; (a, *b, **c, &d)
(define rb-p-parse-args-parens
(fn ()
(rb-p-advance!)
(rb-p-skip-newlines!)
(let ((args (list)))
(define rb-p-ap-loop
(fn ()
(when (not (or (= (rb-p-type) "rparen") (= (rb-p-type) "eof")))
(do
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "**"))
(do (rb-p-advance!)
(append! args {:type "dsplat" :value (rb-p-parse-assign)})))
((and (= (rb-p-type) "op") (= (rb-p-val) "*"))
(do (rb-p-advance!)
(append! args {:type "splat" :value (rb-p-parse-assign)})))
((and (= (rb-p-type) "op") (= (rb-p-val) "&"))
(do (rb-p-advance!)
(append! args {:type "block-pass" :value (rb-p-parse-assign)})))
(:else (append! args (rb-p-parse-assign))))
(rb-p-skip-newlines!)
(when (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!)))
(rb-p-ap-loop)))))
(rb-p-ap-loop)
(rb-p-expect! "rparen")
args)))
;; No-paren arg list up to sep/end-keyword
(define rb-p-parse-args-bare
(fn ()
(let ((args (list)) (going true))
(define rb-p-ab-loop
(fn ()
(when (and going
(not (rb-p-sep?))
(not (= (rb-p-type) "eof"))
(not (= (rb-p-type) "rparen"))
(not (= (rb-p-type) "rbracket"))
(not (= (rb-p-type) "rbrace"))
(not (and (= (rb-p-type) "keyword")
(contains? (list "end" "else" "elsif" "when"
"rescue" "ensure" "then" "do")
(rb-p-val)))))
(do
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "*"))
(do (rb-p-advance!)
(append! args {:type "splat" :value (rb-p-parse-assign)})))
((and (= (rb-p-type) "op") (= (rb-p-val) "**"))
(do (rb-p-advance!)
(append! args {:type "dsplat" :value (rb-p-parse-assign)})))
((and (= (rb-p-type) "op") (= (rb-p-val) "&"))
(do (rb-p-advance!)
(append! args {:type "block-pass" :value (rb-p-parse-assign)})))
(:else (append! args (rb-p-parse-assign))))
(if (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!) (rb-p-ab-loop))
(set! going false))))))
(rb-p-ab-loop)
args)))
;; Primary expression
(define rb-p-parse-primary
(fn ()
(cond
((= (rb-p-type) "int")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "lit-int" :value v}))
((= (rb-p-type) "float")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "lit-float" :value v}))
((= (rb-p-type) "string")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "lit-str" :value v}))
((= (rb-p-type) "symbol")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "lit-sym" :value v}))
((= (rb-p-type) "words")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "lit-words" :elems v}))
((= (rb-p-type) "isymbols")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "lit-isyms" :elems v}))
((= (rb-p-type) "ivar")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "ivar" :name v}))
((= (rb-p-type) "cvar")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "cvar" :name v}))
((= (rb-p-type) "gvar")
(let ((v (rb-p-val))) (rb-p-advance!) {:type "gvar" :name v}))
((= (rb-p-type) "const")
(rb-p-parse-const-path))
((= (rb-p-type) "ident")
(let ((name (rb-p-val)))
(rb-p-advance!)
(if (= (rb-p-type) "lparen")
(let ((args (rb-p-parse-args-parens))
(blk (rb-p-parse-block)))
{:type "send" :name name :args args :block blk})
{:type "send" :name name :args (list) :block nil})))
((= (rb-p-type) "keyword")
(cond
((= (rb-p-val) "nil")
(do (rb-p-advance!) {:type "lit-nil"}))
((= (rb-p-val) "true")
(do (rb-p-advance!) {:type "lit-bool" :value true}))
((= (rb-p-val) "false")
(do (rb-p-advance!) {:type "lit-bool" :value false}))
((= (rb-p-val) "self")
(do (rb-p-advance!) {:type "self"}))
((= (rb-p-val) "super")
(do
(rb-p-advance!)
(let ((args (if (= (rb-p-type) "lparen")
(rb-p-parse-args-parens) (list)))
(blk (rb-p-parse-block)))
{:type "send" :name "super" :args args :block blk})))
(:else
{:type "error"
:msg (join "" (list "unexpected kw " (rb-p-val)))})))
((= (rb-p-type) "lbracket")
(rb-p-parse-array))
((= (rb-p-type) "lbrace")
(rb-p-parse-hash))
((= (rb-p-type) "lparen")
(do
(rb-p-advance!)
(rb-p-skip-seps!)
(let ((node (rb-p-parse-expr)))
(rb-p-skip-seps!)
(rb-p-expect! "rparen")
node)))
(:else
(do
(rb-p-advance!)
{:type "error"
:msg (join "" (list "unexpected " (rb-p-type)
" '" (or (rb-p-val) "") "'"))})))))
;; .method ::Const [index] chains
(define rb-p-parse-postfix
(fn ()
(let ((node (rb-p-parse-primary)))
(define rb-p-pf-loop
(fn ()
(cond
((= (rb-p-type) "dot")
(do
(rb-p-advance!)
(let ((method (rb-p-val)))
(rb-p-advance!)
(let ((args (if (= (rb-p-type) "lparen")
(rb-p-parse-args-parens) (list)))
(blk (rb-p-parse-block)))
(set! node {:type "call" :recv node :method method
:args args :block blk})
(rb-p-pf-loop)))))
((= (rb-p-type) "dcolon")
(do
(rb-p-advance!)
(let ((name (rb-p-val)))
(rb-p-advance!)
(if (= (rb-p-type) "lparen")
(let ((args (rb-p-parse-args-parens))
(blk (rb-p-parse-block)))
(set! node {:type "call" :recv node :method name
:args args :block blk}))
(set! node {:type "const-path" :left node :name name}))
(rb-p-pf-loop))))
((= (rb-p-type) "lbracket")
(do
(rb-p-advance!)
(rb-p-skip-newlines!)
(let ((idxargs (list)))
(define rb-p-idx-loop
(fn ()
(when (not (or (= (rb-p-type) "rbracket") (= (rb-p-type) "eof")))
(do
(append! idxargs (rb-p-parse-assign))
(when (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!)))
(rb-p-idx-loop)))))
(rb-p-idx-loop)
(rb-p-expect! "rbracket")
(set! node {:type "index" :recv node :args idxargs})
(rb-p-pf-loop))))
(:else nil))))
(rb-p-pf-loop)
node)))
(define rb-p-parse-unary
(fn ()
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "!"))
(do (rb-p-advance!)
{:type "unop" :op "!" :value (rb-p-parse-unary)}))
((and (= (rb-p-type) "op") (= (rb-p-val) "~"))
(do (rb-p-advance!)
{:type "unop" :op "~" :value (rb-p-parse-unary)}))
((and (= (rb-p-type) "op") (= (rb-p-val) "-"))
(do (rb-p-advance!)
{:type "unop" :op "-" :value (rb-p-parse-unary)}))
((and (= (rb-p-type) "op") (= (rb-p-val) "+"))
(do (rb-p-advance!) (rb-p-parse-unary)))
(:else (rb-p-parse-postfix)))))
(define rb-p-parse-power
(fn ()
(let ((node (rb-p-parse-unary)))
(if (and (= (rb-p-type) "op") (= (rb-p-val) "**"))
(do (rb-p-advance!)
{:type "binop" :op "**" :left node :right (rb-p-parse-power)})
node))))
(define rb-p-parse-mul
(fn ()
(let ((node (rb-p-parse-power)))
(define rb-p-mul-loop
(fn ()
(if (and (= (rb-p-type) "op")
(or (= (rb-p-val) "*") (= (rb-p-val) "/") (= (rb-p-val) "%")))
(let ((op (rb-p-val)))
(rb-p-advance!)
(set! node {:type "binop" :op op :left node :right (rb-p-parse-power)})
(rb-p-mul-loop))
node)))
(rb-p-mul-loop))))
(define rb-p-parse-add
(fn ()
(let ((node (rb-p-parse-mul)))
(define rb-p-add-loop
(fn ()
(if (and (= (rb-p-type) "op")
(or (= (rb-p-val) "+") (= (rb-p-val) "-")))
(let ((op (rb-p-val)))
(rb-p-advance!)
(set! node {:type "binop" :op op :left node :right (rb-p-parse-mul)})
(rb-p-add-loop))
node)))
(rb-p-add-loop))))
(define rb-p-parse-shift
(fn ()
(let ((node (rb-p-parse-add)))
(define rb-p-sh-loop
(fn ()
(if (and (= (rb-p-type) "op")
(or (= (rb-p-val) "<<") (= (rb-p-val) ">>")))
(let ((op (rb-p-val)))
(rb-p-advance!)
(set! node {:type "binop" :op op :left node :right (rb-p-parse-add)})
(rb-p-sh-loop))
node)))
(rb-p-sh-loop))))
(define rb-p-parse-bitand
(fn ()
(let ((node (rb-p-parse-shift)))
(define rb-p-ba-loop
(fn ()
(if (and (= (rb-p-type) "op") (= (rb-p-val) "&"))
(do
(rb-p-advance!)
(set! node {:type "binop" :op "&" :left node :right (rb-p-parse-shift)})
(rb-p-ba-loop))
node)))
(rb-p-ba-loop))))
;; | is "pipe" token (not "op")
(define rb-p-parse-bitor
(fn ()
(let ((node (rb-p-parse-bitand)))
(define rb-p-bo-loop
(fn ()
(cond
((= (rb-p-type) "pipe")
(do
(rb-p-advance!)
(set! node {:type "binop" :op "|" :left node :right (rb-p-parse-bitand)})
(rb-p-bo-loop)))
((and (= (rb-p-type) "op") (= (rb-p-val) "^"))
(do
(rb-p-advance!)
(set! node {:type "binop" :op "^" :left node :right (rb-p-parse-bitand)})
(rb-p-bo-loop)))
(:else node))))
(rb-p-bo-loop))))
(define rb-p-parse-comparison
(fn ()
(let ((node (rb-p-parse-bitor)))
(if (and (= (rb-p-type) "op")
(contains? (list "==" "!=" "<" ">" "<=" ">="
"<=>" "===" "=~" "!~") (rb-p-val)))
(let ((op (rb-p-val)))
(rb-p-advance!)
{:type "binop" :op op :left node :right (rb-p-parse-bitor)})
node))))
(define rb-p-parse-not
(fn ()
(if (and (= (rb-p-type) "keyword") (= (rb-p-val) "not"))
(do (rb-p-advance!)
{:type "not" :value (rb-p-parse-not)})
(rb-p-parse-comparison))))
(define rb-p-parse-and
(fn ()
(let ((node (rb-p-parse-not)))
(define rb-p-and-loop
(fn ()
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "&&"))
(do
(rb-p-advance!)
(set! node {:type "binop" :op "&&" :left node :right (rb-p-parse-not)})
(rb-p-and-loop)))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "and"))
(do
(rb-p-advance!)
(set! node {:type "binop" :op "and" :left node :right (rb-p-parse-not)})
(rb-p-and-loop)))
(:else node))))
(rb-p-and-loop))))
(define rb-p-parse-or
(fn ()
(let ((node (rb-p-parse-and)))
(define rb-p-or-loop
(fn ()
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "||"))
(do
(rb-p-advance!)
(set! node {:type "binop" :op "||" :left node :right (rb-p-parse-and)})
(rb-p-or-loop)))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "or"))
(do
(rb-p-advance!)
(set! node {:type "binop" :op "or" :left node :right (rb-p-parse-and)})
(rb-p-or-loop)))
(:else node))))
(rb-p-or-loop))))
(define rb-p-parse-range
(fn ()
(let ((node (rb-p-parse-or)))
(cond
((= (rb-p-type) "dotdot")
(do (rb-p-advance!)
{:type "range" :from node :to (rb-p-parse-or) :exclusive false}))
((= (rb-p-type) "dotdotdot")
(do (rb-p-advance!)
{:type "range" :from node :to (rb-p-parse-or) :exclusive true}))
(:else node)))))
(define rb-p-parse-assign
(fn ()
(let ((node (rb-p-parse-range)))
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "="))
(do (rb-p-advance!)
{:type "assign" :target node :value (rb-p-parse-assign)}))
((and (= (rb-p-type) "op")
(contains? (list "+=" "-=" "*=" "/=" "%=" "**="
"<<=" ">>=" "&=" "|=" "^=" "&&=" "||=")
(rb-p-val)))
(let ((op (substring (rb-p-val) 0 (- (len (rb-p-val)) 1))))
(rb-p-advance!)
{:type "op-assign" :target node :op op :value (rb-p-parse-assign)}))
(:else node)))))
(define rb-p-parse-expr
(fn () (rb-p-parse-assign)))
;; e, e, ... → single node or array
(define rb-p-parse-multi-val
(fn ()
(let ((vals (list)))
(define rb-p-mv-loop
(fn ()
(append! vals (rb-p-parse-assign))
(when (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!) (rb-p-mv-loop)))))
(rb-p-mv-loop)
(if (= (len vals) 1)
(nth vals 0)
{:type "array" :elems vals}))))
;; a, b, *c = rhs
(define rb-p-parse-massign
(fn ()
(let ((targets (list)))
(define rb-p-ma-loop
(fn ()
(cond
((and (= (rb-p-type) "op") (= (rb-p-val) "*"))
(do
(rb-p-advance!)
(if (= (rb-p-type) "ident")
(do
(append! targets {:type "splat-target" :name (rb-p-val)})
(rb-p-advance!))
(append! targets {:type "splat-target" :name nil}))))
((= (rb-p-type) "ident")
(do (append! targets {:type "lvar" :name (rb-p-val)}) (rb-p-advance!)))
((= (rb-p-type) "ivar")
(do (append! targets {:type "ivar" :name (rb-p-val)}) (rb-p-advance!)))
((= (rb-p-type) "cvar")
(do (append! targets {:type "cvar" :name (rb-p-val)}) (rb-p-advance!)))
((= (rb-p-type) "gvar")
(do (append! targets {:type "gvar" :name (rb-p-val)}) (rb-p-advance!)))
((= (rb-p-type) "const")
(do (append! targets {:type "const" :name (rb-p-val)}) (rb-p-advance!)))
(:else nil))
(when (= (rb-p-type) "comma")
(do (rb-p-advance!) (rb-p-skip-newlines!) (rb-p-ma-loop)))))
(rb-p-ma-loop)
(rb-p-advance!)
{:type "massign" :targets targets :value (rb-p-parse-multi-val)})))
(define rb-p-parse-stmt
(fn ()
(cond
((and (= (rb-p-type) "keyword") (= (rb-p-val) "def"))
(rb-p-parse-def))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "class"))
(rb-p-parse-class))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "module"))
(rb-p-parse-module))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "return"))
(do (rb-p-advance!)
{:type "return"
:value (if (or (rb-p-sep?) (= (rb-p-type) "eof"))
nil (rb-p-parse-multi-val))}))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "yield"))
(do (rb-p-advance!)
{:type "yield"
:args (cond
((= (rb-p-type) "lparen") (rb-p-parse-args-parens))
((or (rb-p-sep?) (= (rb-p-type) "eof")) (list))
(:else (rb-p-parse-args-bare)))}))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "break"))
(do (rb-p-advance!)
{:type "break"
:value (if (or (rb-p-sep?) (= (rb-p-type) "eof"))
nil (rb-p-parse-expr))}))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "next"))
(do (rb-p-advance!)
{:type "next"
:value (if (or (rb-p-sep?) (= (rb-p-type) "eof"))
nil (rb-p-parse-expr))}))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "redo"))
(do (rb-p-advance!) {:type "redo"}))
((and (= (rb-p-type) "keyword") (= (rb-p-val) "raise"))
(do (rb-p-advance!)
{:type "raise"
:value (if (or (rb-p-sep?) (= (rb-p-type) "eof"))
nil (rb-p-parse-expr))}))
;; Massign: token followed by comma
((and (or (= (rb-p-type) "ident") (= (rb-p-type) "ivar")
(= (rb-p-type) "cvar") (= (rb-p-type) "gvar")
(= (rb-p-type) "const"))
(= (get (rb-p-peek 1) :type) "comma"))
(rb-p-parse-massign))
(:else
(let ((node (rb-p-parse-assign)))
(if (and (= (get node :type) "send")
(= (len (get node :args)) 0)
(nil? (get node :block)))
;; Bare send: check for block or no-paren args
(cond
;; Block immediately follows (do or {)
((or (and (= (rb-p-type) "keyword") (= (rb-p-val) "do"))
(= (rb-p-type) "lbrace"))
(let ((blk (rb-p-parse-block)))
{:type "send" :name (get node :name) :args (list) :block blk}))
;; No-paren args (stop before block/sep/end keywords)
((and (not (rb-p-sep?))
(not (= (rb-p-type) "eof"))
(not (= (rb-p-type) "op"))
(not (= (rb-p-type) "dot"))
(not (= (rb-p-type) "dcolon"))
(not (= (rb-p-type) "rparen"))
(not (= (rb-p-type) "rbracket"))
(not (= (rb-p-type) "rbrace"))
(not (= (rb-p-type) "lbrace"))
(not (and (= (rb-p-type) "keyword")
(contains? (list "end" "else" "elsif" "when"
"rescue" "ensure" "then" "do"
"and" "or" "not")
(rb-p-val)))))
(let ((args (rb-p-parse-args-bare))
(blk (rb-p-parse-block)))
(if (> (len args) 0)
{:type "send" :name (get node :name) :args args :block blk}
node)))
(:else node))
node))))))
(define rb-p-parse-stmts
(fn (terminators)
(let ((stmts (list)))
(define rb-p-at-term?
(fn ()
(or (= (rb-p-type) "eof")
(and (= (rb-p-type) "keyword")
(contains? terminators (rb-p-val)))
(and (= (rb-p-type) "rbrace")
(contains? terminators "rbrace")))))
(define rb-p-ps-loop
(fn ()
(rb-p-skip-seps!)
(when (not (rb-p-at-term?))
(do
(append! stmts (rb-p-parse-stmt))
(rb-p-skip-seps!)
(rb-p-ps-loop)))))
(rb-p-ps-loop)
stmts)))
{:type "program" :stmts (rb-p-parse-stmts (list))})))
(define rb-parse-str
(fn (src) (rb-parse (rb-tokenize src))))

View File

@@ -1,352 +0,0 @@
;; lib/ruby/runtime.sx — Ruby primitives on SX
;;
;; Provides Ruby-idiomatic wrappers over SX built-ins.
;; Primitives used:
;; call/cc (core evaluator)
;; make-set/set-add!/set-member?/set-remove!/set->list (Phase 18)
;; make-regexp/regexp-match/regexp-match-all/... (Phase 19)
;; make-bytevector/bytevector-u8-ref/... (Phase 20)
;; ---------------------------------------------------------------------------
;; 0. Internal list helpers
;; ---------------------------------------------------------------------------
(define
(rb-list-set-nth lst i newval)
(letrec
((go (fn (ps j) (if (= (len ps) 0) (list) (cons (if (= j i) newval (first ps)) (go (rest ps) (+ j 1)))))))
(go lst 0)))
(define
(rb-list-remove-nth lst i)
(letrec
((go (fn (ps j) (if (= (len ps) 0) (list) (if (= j i) (go (rest ps) (+ j 1)) (cons (first ps) (go (rest ps) (+ j 1))))))))
(go lst 0)))
;; ---------------------------------------------------------------------------
;; 1. Hash (mutable, any-key, dict-backed list-of-pairs)
;; ---------------------------------------------------------------------------
(define
(rb-hash-new)
(let
((h (dict)))
(dict-set! h "_rb_hash" true)
(dict-set! h "_pairs" (list))
(dict-set! h "_size" 0)
h))
(define (rb-hash? v) (and (dict? v) (dict-has? v "_rb_hash")))
(define (rb-hash-size h) (get h "_size"))
(define
(rb-hash-find-idx pairs k)
(letrec
((go (fn (ps i) (cond ((= (len ps) 0) -1) ((= (first (first ps)) k) i) (else (go (rest ps) (+ i 1)))))))
(go pairs 0)))
(define
(rb-hash-at h k)
(letrec
((go (fn (ps) (if (= (len ps) 0) nil (if (= (first (first ps)) k) (nth (first ps) 1) (go (rest ps)))))))
(go (get h "_pairs"))))
(define
(rb-hash-at-or h k default)
(if (rb-hash-has-key? h k) (rb-hash-at h k) default))
(define
(rb-hash-at-put! h k v)
(let
((pairs (get h "_pairs")) (idx (rb-hash-find-idx (get h "_pairs") k)))
(if
(= idx -1)
(begin
(dict-set! h "_pairs" (append pairs (list (list k v))))
(dict-set! h "_size" (+ (get h "_size") 1)))
(dict-set! h "_pairs" (rb-list-set-nth pairs idx (list k v)))))
h)
(define
(rb-hash-has-key? h k)
(not (= (rb-hash-find-idx (get h "_pairs") k) -1)))
(define
(rb-hash-delete! h k)
(let
((idx (rb-hash-find-idx (get h "_pairs") k)))
(when
(not (= idx -1))
(dict-set! h "_pairs" (rb-list-remove-nth (get h "_pairs") idx))
(dict-set! h "_size" (- (get h "_size") 1))))
h)
(define (rb-hash-keys h) (map first (get h "_pairs")))
(define
(rb-hash-values h)
(map (fn (p) (nth p 1)) (get h "_pairs")))
(define
(rb-hash-each h callback)
(for-each
(fn (p) (callback (first p) (nth p 1)))
(get h "_pairs")))
(define (rb-hash->list h) (get h "_pairs"))
(define
(rb-list->hash pairs)
(let
((h (rb-hash-new)))
(for-each
(fn (p) (rb-hash-at-put! h (first p) (nth p 1)))
pairs)
h))
(define
(rb-hash-merge h1 h2)
(let
((result (rb-hash-new)))
(for-each
(fn (p) (rb-hash-at-put! result (first p) (nth p 1)))
(get h1 "_pairs"))
(for-each
(fn (p) (rb-hash-at-put! result (first p) (nth p 1)))
(get h2 "_pairs"))
result))
;; ---------------------------------------------------------------------------
;; 2. Set (uniqueness collection backed by SX make-set)
;; Note: set-member?/set-add!/set-remove! take (set item) order.
;; ---------------------------------------------------------------------------
(define
(rb-set-new)
(let
((s (dict)))
(dict-set! s "_rb_set" true)
(dict-set! s "_set" (make-set))
(dict-set! s "_size" 0)
s))
(define (rb-set? v) (and (dict? v) (dict-has? v "_rb_set")))
(define (rb-set-size s) (get s "_size"))
(define
(rb-set-add! s v)
(let
((sx (get s "_set")))
(when
(not (set-member? sx v))
(set-add! sx v)
(dict-set! s "_size" (+ (get s "_size") 1))))
s)
(define (rb-set-include? s v) (set-member? (get s "_set") v))
(define
(rb-set-delete! s v)
(let
((sx (get s "_set")))
(when
(set-member? sx v)
(set-remove! sx v)
(dict-set! s "_size" (- (get s "_size") 1))))
s)
(define (rb-set->list s) (set->list (get s "_set")))
(define
(rb-set-each s callback)
(for-each callback (set->list (get s "_set"))))
(define
(rb-set-union s1 s2)
(let
((result (rb-set-new)))
(for-each (fn (v) (rb-set-add! result v)) (rb-set->list s1))
(for-each (fn (v) (rb-set-add! result v)) (rb-set->list s2))
result))
(define
(rb-set-intersection s1 s2)
(let
((result (rb-set-new)))
(for-each
(fn (v) (when (rb-set-include? s2 v) (rb-set-add! result v)))
(rb-set->list s1))
result))
(define
(rb-set-difference s1 s2)
(let
((result (rb-set-new)))
(for-each
(fn (v) (when (not (rb-set-include? s2 v)) (rb-set-add! result v)))
(rb-set->list s1))
result))
;; ---------------------------------------------------------------------------
;; 3. Regexp (thin wrappers over Phase-19 make-regexp primitives)
;; ---------------------------------------------------------------------------
(define
(rb-regexp-new pattern flags)
(make-regexp pattern (if (= flags nil) "" flags)))
(define (rb-regexp? v) (regexp? v))
(define (rb-regexp-match rx str) (regexp-match rx str))
(define (rb-regexp-match-all rx str) (regexp-match-all rx str))
(define (rb-regexp-match? rx str) (not (= (regexp-match rx str) nil)))
(define
(rb-regexp-replace rx str replacement)
(regexp-replace rx str replacement))
(define
(rb-regexp-replace-all rx str replacement)
(regexp-replace-all rx str replacement))
(define (rb-regexp-split rx str) (regexp-split rx str))
;; ---------------------------------------------------------------------------
;; 4. StringIO (write buffer + char-by-char read after rewind)
;; ---------------------------------------------------------------------------
(define
(rb-string-io-new)
(let
((io (dict)))
(dict-set! io "_rb_string_io" true)
(dict-set! io "_buf" "")
(dict-set! io "_chars" (list))
(dict-set! io "_pos" 0)
io))
(define (rb-string-io? v) (and (dict? v) (dict-has? v "_rb_string_io")))
(define
(rb-string-io-write! io s)
(dict-set! io "_buf" (str (get io "_buf") s))
io)
(define (rb-string-io-string io) (get io "_buf"))
(define
(rb-string-io-rewind! io)
(dict-set! io "_chars" (string->list (get io "_buf")))
(dict-set! io "_pos" 0)
io)
(define
(rb-string-io-eof? io)
(>= (get io "_pos") (len (get io "_chars"))))
(define
(rb-string-io-read-char io)
(if
(rb-string-io-eof? io)
nil
(let
((c (nth (get io "_chars") (get io "_pos"))))
(dict-set! io "_pos" (+ (get io "_pos") 1))
c)))
(define
(rb-string-io-read io)
(letrec
((go (fn (acc) (let ((c (rb-string-io-read-char io))) (if (= c nil) (list->string (reverse acc)) (go (cons c acc)))))))
(go (list))))
;; ---------------------------------------------------------------------------
;; 5. Bytevectors (thin wrappers over Phase-20 bytevector primitives)
;; ---------------------------------------------------------------------------
(define
(rb-bytes-new n fill)
(make-bytevector n (if (= fill nil) 0 fill)))
(define (rb-bytes? v) (bytevector? v))
(define (rb-bytes-length v) (bytevector-length v))
(define (rb-bytes-get v i) (bytevector-u8-ref v i))
(define (rb-bytes-set! v i b) (bytevector-u8-set! v i b) v)
(define (rb-bytes-copy v) (bytevector-copy v))
(define (rb-bytes-append v1 v2) (bytevector-append v1 v2))
(define (rb-bytes-to-string v) (utf8->string v))
(define (rb-bytes-from-string s) (string->utf8 s))
(define (rb-bytes->list v) (bytevector->list v))
(define (rb-list->bytes lst) (list->bytevector lst))
;; ---------------------------------------------------------------------------
;; 6. Fiber (call/cc coroutines)
;; Body wrapped so completion always routes through _resumer, ensuring
;; rb-fiber-resume always returns via the captured continuation.
;; ---------------------------------------------------------------------------
(define rb-current-fiber nil)
(define
(rb-fiber-new body)
(let
((f (dict)))
(dict-set! f "_rb_fiber" true)
(dict-set! f "_state" "new")
(dict-set! f "_cont" nil)
(dict-set! f "_resumer" nil)
(dict-set! f "_parent" nil)
(dict-set!
f
"_body"
(fn
()
(let
((result (body)))
(dict-set! f "_state" "dead")
(set! rb-current-fiber (get f "_parent"))
((get f "_resumer") result))))
f))
(define (rb-fiber? v) (and (dict? v) (dict-has? v "_rb_fiber")))
(define (rb-fiber-alive? f) (not (= (get f "_state") "dead")))
(define
(rb-fiber-yield val)
(call/cc
(fn
(resume-k)
(let
((cur rb-current-fiber))
(dict-set! cur "_cont" resume-k)
(dict-set! cur "_state" "suspended")
(set! rb-current-fiber (get cur "_parent"))
((get cur "_resumer") val)))))
(define
(rb-fiber-resume f)
(call/cc
(fn
(return-k)
(dict-set! f "_parent" rb-current-fiber)
(dict-set! f "_resumer" return-k)
(set! rb-current-fiber f)
(dict-set! f "_state" "running")
(if
(= (get f "_cont") nil)
((get f "_body"))
((get f "_cont") nil)))))

View File

@@ -1,62 +1,92 @@
#!/usr/bin/env bash
# lib/ruby/test.sh — smoke-test the Ruby runtime layer.
# Ruby-on-SX test runner.
# Usage:
# bash lib/ruby/test.sh # run all tests
# bash lib/ruby/test.sh -v # verbose
# bash lib/ruby/test.sh tests/parse.sx # single file
set -uo pipefail
set -euo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found."
exit 1
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
else
echo "ERROR: sx_server.exe not found."
exit 1
fi
fi
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
VERBOSE=""
FILES=()
for arg in "$@"; do
case "$arg" in
-v|--verbose) VERBOSE=1 ;;
*) FILES+=("$arg") ;;
esac
done
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "lib/ruby/runtime.sx")
(epoch 2)
(load "lib/ruby/tests/runtime.sx")
(epoch 3)
(eval "(list rb-test-pass rb-test-fail)")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"
echo "$OUTPUT" | tail -20
exit 1
if [ ${#FILES[@]} -eq 0 ]; then
mapfile -t FILES < <(find lib/ruby/tests -maxdepth 2 -name '*.sx' | sort)
fi
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
TOTAL=$((P + F))
TOTAL_PASS=0
TOTAL_FAIL=0
FAILED_FILES=()
if [ "$F" -eq 0 ]; then
echo "ok $P/$TOTAL lib/ruby tests passed"
for FILE in "${FILES[@]}"; do
[ -f "$FILE" ] || { echo "skip $FILE (not found)"; continue; }
TMPFILE=$(mktemp)
# Build epoch sequence: load runtime files, then test file, then eval summary.
{
echo "(epoch 1)"
echo "(load \"lib/ruby/tokenizer.sx\")"
if [ -f "lib/ruby/parser.sx" ]; then
echo "(epoch 2)"
echo "(load \"lib/ruby/parser.sx\")"
fi
echo "(epoch 3)"
echo "(load \"$FILE\")"
echo "(epoch 4)"
echo "(eval \"(list rb-test-pass rb-test-fail)\")"
} > "$TMPFILE"
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
rm -f "$TMPFILE"
# Extract epoch 4 result: (ok-len 4 N)\n<val> or (ok 4 <val>)
LINE=$(printf '%s\n' "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(printf '%s\n' "$OUTPUT" \
| grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 4 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "$FILE: could not extract summary"
printf '%s\n' "$OUTPUT" | grep -v '^(ok ' | tail -10
TOTAL_FAIL=$((TOTAL_FAIL + 1))
FAILED_FILES+=("$FILE")
continue
fi
P=$(printf '%s\n' "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(printf '%s\n' "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
TOTAL_PASS=$((TOTAL_PASS + P))
TOTAL_FAIL=$((TOTAL_FAIL + F))
if [ "$F" -gt 0 ]; then
FAILED_FILES+=("$FILE")
printf '✗ %-40s %d/%d\n' "$FILE" "$P" "$((P+F))"
elif [ "$VERBOSE" = "1" ]; then
printf '✓ %-40s %d passed\n' "$FILE" "$P"
fi
done
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
if [ $TOTAL_FAIL -eq 0 ]; then
echo "$TOTAL_PASS/$TOTAL ruby-on-sx tests passed"
else
echo "FAIL $P/$TOTAL passed, $F failed"
TMPFILE2=$(mktemp)
cat > "$TMPFILE2" << 'EPOCHS2'
(epoch 1)
(load "lib/ruby/runtime.sx")
(epoch 2)
(load "lib/ruby/tests/runtime.sx")
(epoch 3)
(eval "(map (fn (f) (get f \"name\")) rb-test-fails)")
EPOCHS2
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>/dev/null | grep -E '^\(ok 3 ' || true)
echo " Failed: $FAILS"
rm -f "$TMPFILE2"
echo "$TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed in: ${FAILED_FILES[*]}"
fi
[ "$F" -eq 0 ]
[ $TOTAL_FAIL -eq 0 ]

439
lib/ruby/tests/parse.sx Normal file
View File

@@ -0,0 +1,439 @@
;; Parser tests for Ruby 2.7 subset.
(define rb-deep=?
(fn (a b)
(cond
((= a b) true)
((and (dict? a) (dict? b))
(let ((ak (keys a)) (bk (keys b)))
(if (not (= (len ak) (len bk)))
false
(every?
(fn (k)
(and (has-key? b k) (rb-deep=? (get a k) (get b k))))
ak))))
((and (list? a) (list? b))
(if (not (= (len a) (len b)))
false
(let ((i 0) (ok true))
(define rb-de-loop
(fn ()
(when (and ok (< i (len a)))
(do
(when (not (rb-deep=? (nth a i) (nth b i)))
(set! ok false))
(set! i (+ i 1))
(rb-de-loop)))))
(rb-de-loop)
ok)))
(:else false))))
(define rb-test-pass 0)
(define rb-test-fail 0)
(define rb-test-fails (list))
(define rb-test
(fn (name actual expected)
(if (rb-deep=? actual expected)
(set! rb-test-pass (+ rb-test-pass 1))
(do
(set! rb-test-fail (+ rb-test-fail 1))
(append! rb-test-fails {:name name :actual actual :expected expected})))))
;; Shorthand: parse src and extract :stmts list
(define rb-p-stmts
(fn (src)
(get (rb-parse-str src) :stmts)))
;; Shorthand: parse and get first statement
(define rb-p-first
(fn (src)
(nth (rb-p-stmts src) 0)))
;; ── Literals ─────────────────────────────────────────────────────────────────
(rb-test "int literal"
(rb-p-first "42")
{:type "lit-int" :value 42})
(rb-test "negative int"
(rb-p-first "-7")
{:type "unop" :op "-" :value {:type "lit-int" :value 7}})
(rb-test "float literal"
(rb-p-first "3.14")
{:type "lit-float" :value "3.14"})
(rb-test "string literal"
(rb-p-first "\"hello\"")
{:type "lit-str" :value "hello"})
(rb-test "symbol literal"
(rb-p-first ":foo")
{:type "lit-sym" :value "foo"})
(rb-test "nil literal"
(rb-p-first "nil")
{:type "lit-nil"})
(rb-test "true literal"
(rb-p-first "true")
{:type "lit-bool" :value true})
(rb-test "false literal"
(rb-p-first "false")
{:type "lit-bool" :value false})
(rb-test "self"
(rb-p-first "self")
{:type "self"})
(rb-test "%w[] words"
(rb-p-first "%w[a b c]")
{:type "lit-words" :elems (list "a" "b" "c")})
(rb-test "%i[] isymbols"
(rb-p-first "%i[x y]")
{:type "lit-isyms" :elems (list "x" "y")})
;; ── Variables ─────────────────────────────────────────────────────────────────
(rb-test "local var / send"
(rb-p-first "x")
{:type "send" :name "x" :args (list) :block nil})
(rb-test "ivar"
(rb-p-first "@foo")
{:type "ivar" :name "@foo"})
(rb-test "cvar"
(rb-p-first "@@count")
{:type "cvar" :name "@@count"})
(rb-test "gvar"
(rb-p-first "$stdout")
{:type "gvar" :name "$stdout"})
(rb-test "constant"
(rb-p-first "Foo")
{:type "const" :name "Foo"})
(rb-test "const path"
(rb-p-first "Foo::Bar")
{:type "const-path"
:left {:type "const" :name "Foo"}
:name "Bar"})
(rb-test "triple const path"
(rb-p-first "A::B::C")
{:type "const-path"
:left {:type "const-path"
:left {:type "const" :name "A"}
:name "B"}
:name "C"})
;; ── Arrays and Hashes ─────────────────────────────────────────────────────────
(rb-test "empty array"
(rb-p-first "[]")
{:type "array" :elems (list)})
(rb-test "array literal"
(rb-p-first "[1, 2, 3]")
{:type "array" :elems (list {:type "lit-int" :value 1}
{:type "lit-int" :value 2}
{:type "lit-int" :value 3})})
(rb-test "hash colon style"
(get (rb-p-first "{a: 1}") :type)
"hash")
(rb-test "hash pair style"
(get (nth (get (rb-p-first "{a: 1}") :pairs) 0) :style)
"colon")
(rb-test "hash symbol key"
(get (get (nth (get (rb-p-first "{a: 1}") :pairs) 0) :key) :value)
"a")
;; ── Binary operators ──────────────────────────────────────────────────────────
(rb-test "addition"
(rb-p-first "1 + 2")
{:type "binop" :op "+"
:left {:type "lit-int" :value 1}
:right {:type "lit-int" :value 2}})
(rb-test "subtraction"
(get (rb-p-first "a - b") :op)
"-")
(rb-test "multiplication"
(get (rb-p-first "x * y") :op)
"*")
(rb-test "precedence: * before +"
(rb-p-first "1 + 2 * 3")
{:type "binop" :op "+"
:left {:type "lit-int" :value 1}
:right {:type "binop" :op "*"
:left {:type "lit-int" :value 2}
:right {:type "lit-int" :value 3}}})
(rb-test "power right-assoc"
(rb-p-first "2 ** 3 ** 4")
{:type "binop" :op "**"
:left {:type "lit-int" :value 2}
:right {:type "binop" :op "**"
:left {:type "lit-int" :value 3}
:right {:type "lit-int" :value 4}}})
(rb-test "equality"
(get (rb-p-first "a == b") :op)
"==")
(rb-test "logical and"
(get (rb-p-first "a && b") :op)
"&&")
(rb-test "logical or"
(get (rb-p-first "a || b") :op)
"||")
(rb-test "range inclusive"
(rb-p-first "1..5")
{:type "range"
:from {:type "lit-int" :value 1}
:to {:type "lit-int" :value 5}
:exclusive false})
(rb-test "range exclusive"
(get (rb-p-first "1...5") :exclusive)
true)
;; ── Assignment ────────────────────────────────────────────────────────────────
(rb-test "assign"
(rb-p-first "x = 1")
{:type "assign"
:target {:type "send" :name "x" :args (list) :block nil}
:value {:type "lit-int" :value 1}})
(rb-test "op-assign +="
(get (rb-p-first "x += 1") :type)
"op-assign")
(rb-test "op-assign op"
(get (rb-p-first "x += 1") :op)
"+")
(rb-test "massign"
(get (rb-p-first "a, b = 1, 2") :type)
"massign")
(rb-test "massign targets"
(len (get (rb-p-first "a, b = 1, 2") :targets))
2)
(rb-test "massign value array"
(get (get (rb-p-first "a, b = 1, 2") :value) :type)
"array")
;; ── Method calls ──────────────────────────────────────────────────────────────
(rb-test "call with parens"
(rb-p-first "foo(1, 2)")
{:type "send" :name "foo"
:args (list {:type "lit-int" :value 1}
{:type "lit-int" :value 2})
:block nil})
(rb-test "chained call"
(get (rb-p-first "obj.foo") :type)
"call")
(rb-test "chained call method"
(get (rb-p-first "obj.foo") :method)
"foo")
(rb-test "chained call with args"
(len (get (rb-p-first "obj.foo(1, 2)") :args))
2)
(rb-test "no-paren call"
(get (rb-p-first "puts \"hello\"") :type)
"send")
(rb-test "no-paren call name"
(get (rb-p-first "puts \"hello\"") :name)
"puts")
(rb-test "no-paren call args"
(len (get (rb-p-first "puts \"hello\"") :args))
1)
(rb-test "indexing"
(get (rb-p-first "a[0]") :type)
"index")
;; ── Unary operators ───────────────────────────────────────────────────────────
(rb-test "unary not"
(rb-p-first "!x")
{:type "unop" :op "!"
:value {:type "send" :name "x" :args (list) :block nil}})
(rb-test "unary minus"
(get (rb-p-first "-x") :op)
"-")
;; ── Method def ────────────────────────────────────────────────────────────────
(rb-test "empty method def"
(get (rb-p-first "def foo; end") :type)
"method-def")
(rb-test "method def name"
(get (rb-p-first "def foo; end") :name)
"foo")
(rb-test "method def no params"
(len (get (rb-p-first "def foo; end") :params))
0)
(rb-test "method def with params"
(len (get (rb-p-first "def foo(a, b); end") :params))
2)
(rb-test "method def param-req"
(get (nth (get (rb-p-first "def foo(a); end") :params) 0) :type)
"param-req")
(rb-test "method def param name"
(get (nth (get (rb-p-first "def foo(a); end") :params) 0) :name)
"a")
(rb-test "method def optional param"
(get (nth (get (rb-p-first "def foo(a, b=1); end") :params) 1) :type)
"param-opt")
(rb-test "method def splat"
(get (nth (get (rb-p-first "def foo(*args); end") :params) 0) :type)
"param-rest")
(rb-test "method def double splat"
(get (nth (get (rb-p-first "def foo(**opts); end") :params) 0) :type)
"param-kwrest")
(rb-test "method def block param"
(get (nth (get (rb-p-first "def foo(&blk); end") :params) 0) :type)
"param-block")
(rb-test "method def all param types"
(len (get (rb-p-first "def foo(a, b=1, *c, **d, &e); end") :params))
5)
(rb-test "method def singleton recv"
(get (get (rb-p-first "def self.bar; end") :recv) :type)
"self")
(rb-test "method def body"
(len (get (rb-p-first "def foo; 1; 2; end") :body))
2)
;; ── Class def ────────────────────────────────────────────────────────────────
(rb-test "class def type"
(get (rb-p-first "class Foo; end") :type)
"class-def")
(rb-test "class def name"
(get (get (rb-p-first "class Foo; end") :name) :name)
"Foo")
(rb-test "class def no super"
(nil? (get (rb-p-first "class Foo; end") :super))
true)
(rb-test "class def with super"
(get (get (rb-p-first "class Foo < Bar; end") :super) :name)
"Bar")
(rb-test "singleton class"
(get (rb-p-first "class << self; end") :type)
"sclass")
;; ── Module def ────────────────────────────────────────────────────────────────
(rb-test "module def type"
(get (rb-p-first "module M; end") :type)
"module-def")
(rb-test "module def name"
(get (get (rb-p-first "module M; end") :name) :name)
"M")
;; ── Blocks ────────────────────────────────────────────────────────────────────
(rb-test "block do...end"
(get (get (rb-p-first "foo do |x| x end") :block) :type)
"block")
(rb-test "block brace"
(get (get (rb-p-first "foo { |x| x }") :block) :type)
"block")
(rb-test "block params"
(len (get (get (rb-p-first "foo { |a, b| a }") :block) :params))
2)
(rb-test "block no params"
(len (get (get (rb-p-first "foo { 42 }") :block) :params))
0)
;; ── Control flow ──────────────────────────────────────────────────────────────
(rb-test "return type"
(get (rb-p-first "return 1") :type)
"return")
(rb-test "return value"
(get (get (rb-p-first "return 1") :value) :value)
1)
(rb-test "return nil"
(nil? (get (rb-p-first "return") :value))
true)
(rb-test "yield type"
(get (rb-p-first "yield 1") :type)
"yield")
(rb-test "break type"
(get (rb-p-first "break") :type)
"break")
(rb-test "next type"
(get (rb-p-first "next") :type)
"next")
(rb-test "redo type"
(get (rb-p-first "redo") :type)
"redo")
;; ── Multi-statement program ───────────────────────────────────────────────────
(rb-test "two statements"
(len (rb-p-stmts "1\n2"))
2)
(rb-test "semi-separated"
(len (rb-p-stmts "1; 2; 3"))
3)
(rb-test "class with method"
(let ((cls (rb-p-first "class Foo\n def bar\n 1\n end\nend")))
(len (get cls :body)))
1)
(list rb-test-pass rb-test-fail)

View File

@@ -1,207 +0,0 @@
;; lib/ruby/tests/runtime.sx — Tests for lib/ruby/runtime.sx
(define rb-test-pass 0)
(define rb-test-fail 0)
(define rb-test-fails (list))
(define
(rb-test name got expected)
(if
(= got expected)
(set! rb-test-pass (+ rb-test-pass 1))
(begin
(set! rb-test-fail (+ rb-test-fail 1))
(set! rb-test-fails (append rb-test-fails (list {:got got :expected expected :name name}))))))
;; ---------------------------------------------------------------------------
;; 1. Hash
;; ---------------------------------------------------------------------------
(define h1 (rb-hash-new))
(rb-test "hash? new" (rb-hash? h1) true)
(rb-test "hash? non-hash" (rb-hash? 42) false)
(rb-test "hash size empty" (rb-hash-size h1) 0)
(rb-hash-at-put! h1 "a" 1)
(rb-hash-at-put! h1 "b" 2)
(rb-hash-at-put! h1 "c" 3)
(rb-test "hash at a" (rb-hash-at h1 "a") 1)
(rb-test "hash at b" (rb-hash-at h1 "b") 2)
(rb-test "hash at missing" (rb-hash-at h1 "z") nil)
(rb-test "hash at-or default" (rb-hash-at-or h1 "z" 99) 99)
(rb-test "hash has-key yes" (rb-hash-has-key? h1 "a") true)
(rb-test "hash has-key no" (rb-hash-has-key? h1 "z") false)
(rb-test "hash size after inserts" (rb-hash-size h1) 3)
(rb-hash-at-put! h1 "a" 10)
(rb-test "hash at-put update" (rb-hash-at h1 "a") 10)
(rb-test "hash size unchanged after update" (rb-hash-size h1) 3)
(rb-hash-delete! h1 "b")
(rb-test "hash delete" (rb-hash-has-key? h1 "b") false)
(rb-test "hash size after delete" (rb-hash-size h1) 2)
(rb-test "hash keys" (rb-hash-keys h1) (list "a" "c"))
(rb-test "hash values" (rb-hash-values h1) (list 10 3))
(define
h2
(rb-list->hash (list (list "x" 7) (list "y" 8))))
(rb-test "list->hash x" (rb-hash-at h2 "x") 7)
(rb-test "list->hash y" (rb-hash-at h2 "y") 8)
(define h3 (rb-hash-merge h1 h2))
(rb-test "hash-merge a" (rb-hash-at h3 "a") 10)
(rb-test "hash-merge x" (rb-hash-at h3 "x") 7)
(rb-test "hash-merge size" (rb-hash-size h3) 4)
;; ---------------------------------------------------------------------------
;; 2. Set
;; ---------------------------------------------------------------------------
(define s1 (rb-set-new))
(rb-test "set? new" (rb-set? s1) true)
(rb-test "set? non-set" (rb-set? "hello") false)
(rb-test "set size empty" (rb-set-size s1) 0)
(rb-set-add! s1 1)
(rb-set-add! s1 2)
(rb-set-add! s1 3)
(rb-set-add! s1 2)
(rb-test "set include yes" (rb-set-include? s1 1) true)
(rb-test "set include no" (rb-set-include? s1 9) false)
(rb-test "set size dedup" (rb-set-size s1) 3)
(rb-set-delete! s1 2)
(rb-test "set delete" (rb-set-include? s1 2) false)
(rb-test "set size after delete" (rb-set-size s1) 2)
(define s2 (rb-set-new))
(rb-set-add! s2 2)
(rb-set-add! s2 3)
(rb-set-add! s2 4)
(define su (rb-set-union s1 s2))
(rb-test "set union includes 1" (rb-set-include? su 1) true)
(rb-test "set union includes 4" (rb-set-include? su 4) true)
(rb-test "set union size" (rb-set-size su) 4)
(define si (rb-set-intersection s1 s2))
(rb-test "set intersection includes 3" (rb-set-include? si 3) true)
(rb-test "set intersection excludes 1" (rb-set-include? si 1) false)
(rb-test "set intersection size" (rb-set-size si) 1)
(define sd (rb-set-difference s1 s2))
(rb-test "set difference includes 1" (rb-set-include? sd 1) true)
(rb-test "set difference excludes 3" (rb-set-include? sd 3) false)
;; ---------------------------------------------------------------------------
;; 3. Regexp
;; ---------------------------------------------------------------------------
(define rx1 (rb-regexp-new "hel+" ""))
(rb-test "regexp?" (rb-regexp? rx1) true)
(rb-test "regexp match? yes" (rb-regexp-match? rx1 "say hello") true)
(rb-test "regexp match? no" (rb-regexp-match? rx1 "goodbye") false)
(define m1 (rb-regexp-match rx1 "say hello world"))
(rb-test "regexp match :match" (get m1 "match") "hell")
(define rx2 (rb-regexp-new "[0-9]+" ""))
(define all (rb-regexp-match-all rx2 "a1b22c333"))
(rb-test "regexp match-all count" (len all) 3)
(rb-test "regexp match-all first" (get (first all) "match") "1")
(rb-test "regexp replace" (rb-regexp-replace rx2 "a1b2" "N") "aNb2")
(rb-test "regexp replace-all" (rb-regexp-replace-all rx2 "a1b2" "N") "aNbN")
(rb-test
"regexp split"
(rb-regexp-split (rb-regexp-new "," "") "a,b,c")
(list "a" "b" "c"))
;; ---------------------------------------------------------------------------
;; 4. StringIO
;; ---------------------------------------------------------------------------
(define sio1 (rb-string-io-new))
(rb-test "string-io?" (rb-string-io? sio1) true)
(rb-string-io-write! sio1 "hello")
(rb-string-io-write! sio1 " world")
(rb-test "string-io string" (rb-string-io-string sio1) "hello world")
(rb-string-io-rewind! sio1)
(rb-test "string-io eof? no" (rb-string-io-eof? sio1) false)
(define ch1 (rb-string-io-read-char sio1))
(define ch2 (rb-string-io-read-char sio1))
;; Compare char codepoints since = uses reference equality for chars
(rb-test "string-io read-char h" (char->integer ch1) 104)
(rb-test "string-io read-char e" (char->integer ch2) 101)
(rb-test "string-io read rest" (rb-string-io-read sio1) "llo world")
(rb-test "string-io eof? yes" (rb-string-io-eof? sio1) true)
(rb-test "string-io read at eof" (rb-string-io-read sio1) "")
;; ---------------------------------------------------------------------------
;; 5. Bytevectors
;; ---------------------------------------------------------------------------
(define bv1 (rb-bytes-new 4 0))
(rb-test "bytes?" (rb-bytes? bv1) true)
(rb-test "bytes length" (rb-bytes-length bv1) 4)
(rb-test "bytes get zero" (rb-bytes-get bv1 0) 0)
(rb-bytes-set! bv1 0 65)
(rb-bytes-set! bv1 1 66)
(rb-test "bytes get A" (rb-bytes-get bv1 0) 65)
(rb-test "bytes get B" (rb-bytes-get bv1 1) 66)
(define bv2 (rb-bytes-from-string "hi"))
(rb-test "bytes from-string length" (rb-bytes-length bv2) 2)
(rb-test "bytes to-string" (rb-bytes-to-string bv2) "hi")
(define
bv3
(rb-bytes-append (rb-bytes-from-string "foo") (rb-bytes-from-string "bar")))
(rb-test "bytes append" (rb-bytes-to-string bv3) "foobar")
(rb-test
"bytes->list"
(rb-bytes->list (rb-bytes-from-string "AB"))
(list 65 66))
(rb-test
"list->bytes"
(rb-bytes-to-string (rb-list->bytes (list 72 105)))
"Hi")
;; ---------------------------------------------------------------------------
;; 6. Fiber
;; Note: rb-fiber-yield from inside a letrec (JIT-compiled) doesn't
;; properly escape via call/cc continuations. Use top-level helper fns
;; or explicit sequential yields instead of letrec-bound recursion.
;; ---------------------------------------------------------------------------
(define
fib1
(rb-fiber-new
(fn
()
(rb-fiber-yield 10)
(rb-fiber-yield 20)
30)))
(rb-test "fiber?" (rb-fiber? fib1) true)
(rb-test "fiber alive? before" (rb-fiber-alive? fib1) true)
(define fr1 (rb-fiber-resume fib1))
(rb-test "fiber resume 1" fr1 10)
(rb-test "fiber alive? mid" (rb-fiber-alive? fib1) true)
(define fr2 (rb-fiber-resume fib1))
(rb-test "fiber resume 2" fr2 20)
(define fr3 (rb-fiber-resume fib1))
(rb-test "fiber resume 3 (completion)" fr3 30)
(rb-test "fiber alive? dead" (rb-fiber-alive? fib1) false)
;; Loop via a top-level helper (avoid letrec — see note above)
(define
(rb-fiber-loop-helper i)
(when
(<= i 3)
(rb-fiber-yield i)
(rb-fiber-loop-helper (+ i 1))))
(define
fib2
(rb-fiber-new (fn () (rb-fiber-loop-helper 1) "done")))
(rb-test "fiber loop resume 1" (rb-fiber-resume fib2) 1)
(rb-test "fiber loop resume 2" (rb-fiber-resume fib2) 2)
(rb-test "fiber loop resume 3" (rb-fiber-resume fib2) 3)
(rb-test "fiber loop resume done" (rb-fiber-resume fib2) "done")
(rb-test "fiber loop dead" (rb-fiber-alive? fib2) false)

210
lib/ruby/tests/tokenizer.sx Normal file
View File

@@ -0,0 +1,210 @@
;; Ruby tokenizer tests.
;; Final value: {:pass N :fail N :fails (list)}
(define rb-deep=?
(fn (a b)
(cond
((= a b) true)
((and (dict? a) (dict? b))
(let ((ak (keys a)) (bk (keys b)))
(if (not (= (len ak) (len bk)))
false
(every?
(fn (k) (and (has-key? b k) (rb-deep=? (get a k) (get b k))))
ak))))
((and (list? a) (list? b))
(if (not (= (len a) (len b)))
false
(let ((i 0) (ok true))
(define rb-de-loop
(fn ()
(when (and ok (< i (len a)))
(do
(when (not (rb-deep=? (nth a i) (nth b i)))
(set! ok false))
(set! i (+ i 1))
(rb-de-loop)))))
(rb-de-loop)
ok)))
(:else false))))
(define rb-test-pass 0)
(define rb-test-fail 0)
(define rb-test-fails (list))
(define rb-test
(fn (name actual expected)
(if (rb-deep=? actual expected)
(set! rb-test-pass (+ rb-test-pass 1))
(do
(set! rb-test-fail (+ rb-test-fail 1))
(append! rb-test-fails {:name name :actual actual :expected expected})))))
;; Helper: tokenize, drop newline+eof, return {:type :value} pairs
(define rb-toks
(fn (src)
(map
(fn (tok) {:value (get tok "value") :type (get tok "type")})
(filter
(fn (tok)
(let ((ty (get tok "type")))
(not (or (= ty "newline") (= ty "eof")))))
(rb-tokenize src)))))
;; Helper: get just types
(define rb-types
(fn (src) (map (fn (t) (get t "type")) (rb-toks src))))
;; Helper: get first token type
(define rb-first-type
(fn (src) (get (get (rb-tokenize src) 0) "type")))
(define rb-first-value
(fn (src) (get (get (rb-tokenize src) 0) "value")))
;; ── 1. Keywords ────────────────────────<E29480><E29480><EFBFBD>─────────────────────────
(rb-test "keyword def" (rb-toks "def") (list {:value "def" :type "keyword"}))
(rb-test "keyword end" (rb-toks "end") (list {:value "end" :type "keyword"}))
(rb-test "keyword class" (rb-toks "class") (list {:value "class" :type "keyword"}))
(rb-test "keyword if" (rb-toks "if") (list {:value "if" :type "keyword"}))
(rb-test "keyword while" (rb-toks "while") (list {:value "while" :type "keyword"}))
(rb-test "keyword nil" (rb-toks "nil") (list {:value "nil" :type "keyword"}))
(rb-test "keyword true" (rb-toks "true") (list {:value "true" :type "keyword"}))
(rb-test "keyword false" (rb-toks "false") (list {:value "false" :type "keyword"}))
(rb-test "keyword return" (rb-toks "return") (list {:value "return" :type "keyword"}))
(rb-test "keyword yield" (rb-toks "yield") (list {:value "yield" :type "keyword"}))
(rb-test "keyword begin" (rb-toks "begin") (list {:value "begin" :type "keyword"}))
(rb-test "keyword rescue" (rb-toks "rescue") (list {:value "rescue" :type "keyword"}))
(rb-test "keyword self" (rb-toks "self") (list {:value "self" :type "keyword"}))
(rb-test "keyword super" (rb-toks "super") (list {:value "super" :type "keyword"}))
;; ── 2. Identifiers ────────────────────────────────────────────────
(rb-test "ident simple" (rb-toks "foo") (list {:value "foo" :type "ident"}))
(rb-test "ident underscore" (rb-toks "_foo") (list {:value "_foo" :type "ident"}))
(rb-test "ident with digit" (rb-toks "foo2") (list {:value "foo2" :type "ident"}))
(rb-test "ident predicate" (rb-toks "empty?") (list {:value "empty?" :type "ident"}))
(rb-test "ident bang" (rb-toks "save!") (list {:value "save!" :type "ident"}))
(rb-test "defined?" (rb-toks "defined?") (list {:value "defined?" :type "keyword"}))
;; ── 3. Constants ──────────────────────────────────────────────────
(rb-test "const simple" (rb-toks "Foo") (list {:value "Foo" :type "const"}))
(rb-test "const upcase" (rb-toks "MY_CONST") (list {:value "MY_CONST" :type "const"}))
(rb-test "const class" (rb-toks "String") (list {:value "String" :type "const"}))
;; ── 4. Sigil variables ───────────────────────────────────────────
(rb-test "ivar" (rb-toks "@name") (list {:value "@name" :type "ivar"}))
(rb-test "cvar" (rb-toks "@@count") (list {:value "@@count" :type "cvar"}))
(rb-test "gvar" (rb-toks "$global") (list {:value "$global" :type "gvar"}))
;; ── 5. Integers ───────────────────────────────────────────────────
(rb-test "int decimal" (rb-first-value "42") 42)
(rb-test "int zero" (rb-first-value "0") 0)
(rb-test "int underscore" (rb-first-value "1_000") 1000)
(rb-test "int hex" (rb-first-value "0xFF") 255)
(rb-test "int hex lower" (rb-first-value "0xff") 255)
(rb-test "int octal" (rb-first-value "0o17") 15)
(rb-test "int binary" (rb-first-value "0b1010") 10)
(rb-test "int type" (rb-first-type "42") "int")
;; ── 6. Floats ─────────────────────────────────────────────────────
(rb-test "float simple" (rb-first-type "3.14") "float")
(rb-test "float value" (rb-first-value "3.14") "3.14")
(rb-test "float exp" (rb-first-type "1.5e10") "float")
(rb-test "float exp value" (rb-first-value "1.5e10") "1.5e10")
;; ── 7. Strings ────────────────────────────────────────────────────
(rb-test "dq string" (rb-first-value "\"hello\"") "hello")
(rb-test "dq string type" (rb-first-type "\"hello\"") "string")
(rb-test "sq string" (rb-first-value "'world'") "world")
(rb-test "dq escape nl" (rb-first-value "\"a\\nb\"") "a\nb")
(rb-test "dq escape tab" (rb-first-value "\"a\\tb\"") "a\tb")
(rb-test "dq escape quote" (rb-first-value "\"a\\\"b\"") "a\"b")
(rb-test "sq no escape" (rb-first-value "'a\\nb'") "a\\nb")
(rb-test "sq escape backslash" (rb-first-value "'a\\\\'") "a\\")
(rb-test "dq interp kept" (rb-first-value "\"#{x}\"") "#{x}")
;; ── 8. Symbols ────────────────────────────────────────────────────
(rb-test "symbol simple" (rb-first-type ":foo") "symbol")
(rb-test "symbol value" (rb-first-value ":foo") "foo")
(rb-test "symbol predicate" (rb-first-value ":empty?") "empty?")
(rb-test "symbol dq" (rb-first-value ":\"hello world\"") "hello world")
(rb-test "symbol sq" (rb-first-value ":'hello'") "hello")
;; ── 9. %w and %i literals ────────────────────────────────────────
(rb-test "%w bracket" (rb-first-type "%w[a b c]") "words")
(rb-test "%w value" (rb-first-value "%w[a b c]") (list "a" "b" "c"))
(rb-test "%w paren" (rb-first-value "%w(x y)") (list "x" "y"))
(rb-test "%i bracket" (rb-first-type "%i[a b]") "isymbols")
(rb-test "%i value" (rb-first-value "%i[foo bar]") (list "foo" "bar"))
;; ── 10. Punctuation ───────────────────────────────────────────────
(rb-test "dot" (rb-first-type ".") "dot")
(rb-test "dotdot" (rb-first-type "..") "dotdot")
(rb-test "dotdotdot" (rb-first-type "...") "dotdotdot")
(rb-test "dcolon" (rb-first-type "::") "dcolon")
(rb-test "comma" (rb-first-type ",") "comma")
(rb-test "semi" (rb-first-type ";") "semi")
(rb-test "lparen" (rb-first-type "(") "lparen")
(rb-test "rparen" (rb-first-type ")") "rparen")
(rb-test "lbracket" (rb-first-type "[") "lbracket")
(rb-test "rbracket" (rb-first-type "]") "rbracket")
(rb-test "lbrace" (rb-first-type "{") "lbrace")
(rb-test "rbrace" (rb-first-type "}") "rbrace")
(rb-test "pipe" (rb-first-type "|") "pipe")
;; ── 11. Operators ─────────────────────────────────────────────────
(rb-test "op plus" (rb-first-value "+") "+")
(rb-test "op minus" (rb-first-value "-") "-")
(rb-test "op star" (rb-first-value "*") "*")
(rb-test "op slash" (rb-first-value "/") "/")
(rb-test "op eq" (rb-first-value "=") "=")
(rb-test "op eqeq" (rb-first-value "==") "==")
(rb-test "op neq" (rb-first-value "!=") "!=")
(rb-test "op lt" (rb-first-value "<") "<")
(rb-test "op gt" (rb-first-value ">") ">")
(rb-test "op lte" (rb-first-value "<=") "<=")
(rb-test "op gte" (rb-first-value ">=") ">=")
(rb-test "op spaceship" (rb-first-value "<=>") "<=>")
(rb-test "op tripleq" (rb-first-value "===") "===")
(rb-test "op match" (rb-first-value "=~") "=~")
(rb-test "op nomatch" (rb-first-value "!~") "!~")
(rb-test "op lshift" (rb-first-value "<<") "<<")
(rb-test "op rshift" (rb-first-value ">>") ">>")
(rb-test "op and" (rb-first-value "&&") "&&")
(rb-test "op or" (rb-first-value "||") "||")
(rb-test "op power" (rb-first-value "**") "**")
(rb-test "op plus-eq" (rb-first-value "+=") "+=")
(rb-test "op minus-eq" (rb-first-value "-=") "-=")
(rb-test "op arrow" (rb-first-value "->") "->")
(rb-test "op hash-rocket" (rb-first-value "=>") "=>")
;; ── 12. Comments ──────────────────────────────────────────────────
(rb-test "comment skipped" (len (rb-toks "# this is a comment")) 0)
(rb-test "comment mid-line" (rb-types "x = 1 # comment") (list "ident" "op" "int"))
;; ── 13. Multi-token sequences ─────────────────────────────────────
(rb-test "method call" (rb-types "foo.bar")
(list "ident" "dot" "ident"))
(rb-test "class def" (rb-types "class Foo")
(list "keyword" "const"))
(rb-test "method def" (rb-types "def greet(name)")
(list "keyword" "ident" "lparen" "ident" "rparen"))
(rb-test "assignment" (rb-types "x = 42")
(list "ident" "op" "int"))
(rb-test "block params" (rb-types "|x, y|")
(list "pipe" "ident" "comma" "ident" "pipe"))
(rb-test "scope resolution" (rb-types "Foo::Bar")
(list "const" "dcolon" "const"))
(rb-test "range" (rb-types "1..10")
(list "int" "dotdot" "int"))
(rb-test "exclusive range" (rb-types "1...10")
(list "int" "dotdotdot" "int"))
;; ── 14. Line/col tracking ────────────────────────────────────────
(define rb-tok1 (get (rb-tokenize "hello\nworld") 0))
(define rb-tok2 (get (rb-tokenize "hello\nworld") 2))
(rb-test "line track start" (get rb-tok1 "line") 1)
(rb-test "line track second" (get rb-tok2 "line") 2)
(rb-test "col track start" (get rb-tok1 "col") 1)
(list rb-test-pass rb-test-fail)

549
lib/ruby/tokenizer.sx Normal file
View File

@@ -0,0 +1,549 @@
;; Ruby tokenizer for Ruby 2.7 subset.
;; Token: {:type T :value V :line L :col C}
;;
;; Types: keyword ident ivar cvar gvar const
;; int float string symbol
;; op dot dotdot dotdotdot dcolon colon
;; lparen rparen lbracket rbracket lbrace rbrace
;; comma semi pipe newline words isymbols eof
;; ── Character code table ──────────────────────────────────────────
(define rb-ord-table
(let ((t (dict)) (i 0))
(define rb-build-table
(fn ()
(when (< i 128)
(do
(dict-set! t (char-from-code i) i)
(set! i (+ i 1))
(rb-build-table)))))
(rb-build-table)
t))
(define rb-ord (fn (c) (or (get rb-ord-table c) 0)))
;; ── Character predicates ──────────────────────────────────────────
(define rb-digit?
(fn (c) (and (string? c) (>= (rb-ord c) 48) (<= (rb-ord c) 57))))
(define rb-hex-digit?
(fn (c)
(and (string? c)
(or (and (>= (rb-ord c) 48) (<= (rb-ord c) 57))
(and (>= (rb-ord c) 97) (<= (rb-ord c) 102))
(and (>= (rb-ord c) 65) (<= (rb-ord c) 70))))))
(define rb-octal-digit?
(fn (c) (and (string? c) (>= (rb-ord c) 48) (<= (rb-ord c) 55))))
(define rb-binary-digit? (fn (c) (or (= c "0") (= c "1"))))
(define rb-lower?
(fn (c) (and (string? c) (>= (rb-ord c) 97) (<= (rb-ord c) 122))))
(define rb-upper?
(fn (c) (and (string? c) (>= (rb-ord c) 65) (<= (rb-ord c) 90))))
(define rb-ident-start?
(fn (c) (or (rb-lower? c) (rb-upper? c) (= c "_"))))
(define rb-ident-cont?
(fn (c) (or (rb-lower? c) (rb-upper? c) (rb-digit? c) (= c "_"))))
(define rb-space? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
;; ── Reserved words ────────────────────────────────────────────────
(define rb-keywords
(list "__ENCODING__" "__LINE__" "__FILE__"
"BEGIN" "END"
"alias" "and"
"begin" "break"
"case" "class"
"def" "defined?" "do"
"else" "elsif" "end" "ensure"
"false" "for"
"if" "in"
"module"
"next" "nil" "not"
"or"
"redo" "rescue" "retry" "return"
"self" "super"
"then" "true"
"undef" "unless" "until"
"when" "while"
"yield"))
(define rb-keyword? (fn (w) (contains? rb-keywords w)))
;; ── Token constructor ─────────────────────────────────────────────
(define rb-make-token
(fn (type value line col) {:type type :value value :line line :col col}))
;; ── Radix number parser ───────────────────────────────────────────
(define rb-parse-radix
(fn (s radix)
(let ((n (len s)) (i 0) (acc 0))
(define rb-rad-loop
(fn ()
(when (< i n)
(do
(let ((c (substring s i (+ i 1))))
(cond
((and (>= (rb-ord c) 48) (<= (rb-ord c) 57))
(set! acc (+ (* acc radix) (- (rb-ord c) 48))))
((and (>= (rb-ord c) 97) (<= (rb-ord c) 102))
(set! acc (+ (* acc radix) (+ 10 (- (rb-ord c) 97)))))
((and (>= (rb-ord c) 65) (<= (rb-ord c) 70))
(set! acc (+ (* acc radix) (+ 10 (- (rb-ord c) 65)))))))
(set! i (+ i 1))
(rb-rad-loop)))))
(rb-rad-loop)
acc)))
;; ── Strip underscores from numeric literals ───────────────────────
(define rb-strip-underscores
(fn (s)
(let ((n (len s)) (i 0) (parts (list)))
(define rb-su-loop
(fn ()
(when (< i n)
(do
(let ((c (substring s i (+ i 1))))
(when (not (= c "_"))
(append! parts c)))
(set! i (+ i 1))
(rb-su-loop)))))
(rb-su-loop)
(join "" parts))))
;; ── Main tokenizer ────────────────────────────────────────────────
(define rb-tokenize
(fn (src)
(let ((tokens (list))
(pos 0)
(line 1)
(col 1)
(src-len (len src)))
(define rb-peek
(fn (offset)
(if (< (+ pos offset) src-len)
(substring src (+ pos offset) (+ pos offset 1))
nil)))
(define rb-cur (fn () (rb-peek 0)))
(define rb-advance!
(fn ()
(let ((c (rb-cur)))
(set! pos (+ pos 1))
(if (= c "\n")
(do (set! line (+ line 1)) (set! col 1))
(set! col (+ col 1))))))
(define rb-advance-n!
(fn (n)
(when (> n 0)
(do (rb-advance!) (rb-advance-n! (- n 1))))))
(define rb-push!
(fn (type value tok-line tok-col)
(append! tokens (rb-make-token type value tok-line tok-col))))
(define rb-read-while
(fn (pred)
(let ((start pos))
(define rb-rw-loop
(fn ()
(when (and (< pos src-len) (pred (rb-cur)))
(do (rb-advance!) (rb-rw-loop)))))
(rb-rw-loop)
(substring src start pos))))
(define rb-skip-line-comment!
(fn ()
(define rb-slc-loop
(fn ()
(when (and (< pos src-len) (not (= (rb-cur) "\n")))
(do (rb-advance!) (rb-slc-loop)))))
(rb-slc-loop)))
(define rb-read-escape
(fn ()
(rb-advance!)
(let ((c (rb-cur)))
(cond
((= c "n") (do (rb-advance!) "\n"))
((= c "t") (do (rb-advance!) "\t"))
((= c "r") (do (rb-advance!) "\r"))
((= c "\\") (do (rb-advance!) "\\"))
((= c "'") (do (rb-advance!) "'"))
((= c "\"") (do (rb-advance!) "\""))
((= c "a") (do (rb-advance!) (char-from-code 7)))
((= c "b") (do (rb-advance!) (char-from-code 8)))
((= c "f") (do (rb-advance!) (char-from-code 12)))
((= c "v") (do (rb-advance!) (char-from-code 11)))
((= c "e") (do (rb-advance!) (char-from-code 27)))
((= c "s") (do (rb-advance!) " "))
((= c "0") (do (rb-advance!) (char-from-code 0)))
(:else (do (rb-advance!) (str "\\" c)))))))
(define rb-read-sq-string
(fn ()
(let ((parts (list)))
(rb-advance!)
(define rb-sq-loop
(fn ()
(cond
((>= pos src-len) nil)
((= (rb-cur) "'") (rb-advance!))
((and (= (rb-cur) "\\")
(let ((n (rb-peek 1)))
(or (= n "\\") (= n "'"))))
(do
(rb-advance!)
(append! parts (rb-cur))
(rb-advance!)
(rb-sq-loop)))
(:else
(do
(append! parts (rb-cur))
(rb-advance!)
(rb-sq-loop))))))
(rb-sq-loop)
(join "" parts))))
(define rb-read-dq-string
(fn ()
(let ((parts (list)))
(rb-advance!)
(define rb-dq-loop
(fn ()
(cond
((>= pos src-len) nil)
((= (rb-cur) "\"") (rb-advance!))
((= (rb-cur) "\\")
(do
(append! parts (rb-read-escape))
(rb-dq-loop)))
((and (= (rb-cur) "#") (= (rb-peek 1) "{"))
(do
(append! parts "#{")
(rb-advance-n! 2)
(let ((depth 1))
(define rb-interp-inner
(fn ()
(when (and (< pos src-len) (> depth 0))
(do
(let ((c (rb-cur)))
(cond
((= c "{")
(do
(set! depth (+ depth 1))
(append! parts c)
(rb-advance!)))
((= c "}")
(do
(set! depth (- depth 1))
(when (> depth 0)
(do (append! parts c) (rb-advance!)))))
(:else
(do (append! parts c) (rb-advance!)))))
(rb-interp-inner)))))
(rb-interp-inner))
(when (= (rb-cur) "}")
(do (append! parts "}") (rb-advance!)))
(rb-dq-loop)))
(:else
(do
(append! parts (rb-cur))
(rb-advance!)
(rb-dq-loop))))))
(rb-dq-loop)
(join "" parts))))
(define rb-read-percent-words
(fn ()
(rb-advance-n! 2)
(let ((open-ch (rb-cur)))
(let ((close-ch
(cond
((= open-ch "[") "]")
((= open-ch "(") ")")
((= open-ch "{") "}")
((= open-ch "<") ">")
(:else open-ch))))
(rb-advance!)
(let ((items (list)))
(define rb-pw-skip
(fn ()
(when (and (< pos src-len) (or (rb-space? (rb-cur)) (= (rb-cur) "\n")))
(do (rb-advance!) (rb-pw-skip)))))
(define rb-pw-word
(fn (wparts)
(if (or (>= pos src-len)
(rb-space? (rb-cur))
(= (rb-cur) "\n")
(= (rb-cur) close-ch))
(append! items (join "" wparts))
(do
(append! wparts (rb-cur))
(rb-advance!)
(rb-pw-word wparts)))))
(define rb-pw-loop
(fn ()
(rb-pw-skip)
(when (and (< pos src-len) (not (= (rb-cur) close-ch)))
(do
(rb-pw-word (list))
(rb-pw-loop)))))
(rb-pw-loop)
(when (= (rb-cur) close-ch) (rb-advance!))
items)))))
(define rb-read-ident-word
(fn ()
(let ((start pos))
(rb-read-while rb-ident-cont?)
(when (and (= (rb-cur) "?") (not (= (rb-peek 1) "=")))
(rb-advance!))
(when (and (= (rb-cur) "!") (not (or (= (rb-peek 1) "=") (= (rb-peek 1) "~"))))
(rb-advance!))
(substring src start pos))))
(define rb-read-number!
(fn (tok-line tok-col)
(let ((start pos))
(cond
((and (= (rb-cur) "0") (let ((p (rb-peek 1))) (or (= p "b") (= p "B"))))
(do
(rb-advance-n! 2)
(let ((bin-str (rb-read-while rb-binary-digit?)))
(rb-push! "int" (rb-parse-radix bin-str 2) tok-line tok-col))))
((and (= (rb-cur) "0") (let ((p (rb-peek 1))) (or (= p "o") (= p "O"))))
(do
(rb-advance-n! 2)
(let ((oct-str (rb-read-while rb-octal-digit?)))
(rb-push! "int" (rb-parse-radix oct-str 8) tok-line tok-col))))
((and (= (rb-cur) "0") (let ((p (rb-peek 1))) (or (= p "x") (= p "X"))))
(do
(rb-advance-n! 2)
(let ((hex-str (rb-read-while rb-hex-digit?)))
(rb-push! "int" (rb-parse-radix hex-str 16) tok-line tok-col))))
(:else
(do
(rb-read-while (fn (c) (or (rb-digit? c) (= c "_"))))
(let ((is-float false))
(when (and (= (rb-cur) ".") (rb-digit? (rb-peek 1)))
(do
(set! is-float true)
(rb-advance!)
(rb-read-while (fn (c) (or (rb-digit? c) (= c "_"))))))
(when (or (= (rb-cur) "e") (= (rb-cur) "E"))
(do
(set! is-float true)
(rb-advance!)
(when (or (= (rb-cur) "+") (= (rb-cur) "-"))
(rb-advance!))
(rb-read-while rb-digit?)))
(let ((num-str (rb-strip-underscores (substring src start pos))))
(if is-float
(rb-push! "float" num-str tok-line tok-col)
(rb-push! "int" (parse-int num-str) tok-line tok-col))))))))))
(define rb-read-op!
(fn (tok-line tok-col)
(let ((c0 (rb-cur)) (c1 (rb-peek 1)) (c2 (rb-peek 2)))
(cond
((and (= c0 "<") (= c1 "=") (= c2 ">"))
(do (rb-advance-n! 3) (rb-push! "op" "<=>" tok-line tok-col)))
((and (= c0 "=") (= c1 "=") (= c2 "="))
(do (rb-advance-n! 3) (rb-push! "op" "===" tok-line tok-col)))
((and (= c0 "*") (= c1 "*") (= c2 "="))
(do (rb-advance-n! 3) (rb-push! "op" "**=" tok-line tok-col)))
((and (= c0 "<") (= c1 "<") (= c2 "="))
(do (rb-advance-n! 3) (rb-push! "op" "<<=" tok-line tok-col)))
((and (= c0 ">") (= c1 ">") (= c2 "="))
(do (rb-advance-n! 3) (rb-push! "op" ">>=" tok-line tok-col)))
((and (= c0 "&") (= c1 "&") (= c2 "="))
(do (rb-advance-n! 3) (rb-push! "op" "&&=" tok-line tok-col)))
((and (= c0 "|") (= c1 "|") (= c2 "="))
(do (rb-advance-n! 3) (rb-push! "op" "||=" tok-line tok-col)))
((and (= c0 "*") (= c1 "*"))
(do (rb-advance-n! 2) (rb-push! "op" "**" tok-line tok-col)))
((and (= c0 "=") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "==" tok-line tok-col)))
((and (= c0 "!") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "!=" tok-line tok-col)))
((and (= c0 "<") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "<=" tok-line tok-col)))
((and (= c0 ">") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" ">=" tok-line tok-col)))
((and (= c0 "=") (= c1 "~"))
(do (rb-advance-n! 2) (rb-push! "op" "=~" tok-line tok-col)))
((and (= c0 "!") (= c1 "~"))
(do (rb-advance-n! 2) (rb-push! "op" "!~" tok-line tok-col)))
((and (= c0 "<") (= c1 "<"))
(do (rb-advance-n! 2) (rb-push! "op" "<<" tok-line tok-col)))
((and (= c0 ">") (= c1 ">"))
(do (rb-advance-n! 2) (rb-push! "op" ">>" tok-line tok-col)))
((and (= c0 "&") (= c1 "&"))
(do (rb-advance-n! 2) (rb-push! "op" "&&" tok-line tok-col)))
((and (= c0 "|") (= c1 "|"))
(do (rb-advance-n! 2) (rb-push! "op" "||" tok-line tok-col)))
((and (= c0 "+") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "+=" tok-line tok-col)))
((and (= c0 "-") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "-=" tok-line tok-col)))
((and (= c0 "*") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "*=" tok-line tok-col)))
((and (= c0 "/") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "/=" tok-line tok-col)))
((and (= c0 "%") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "%=" tok-line tok-col)))
((and (= c0 "&") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "&=" tok-line tok-col)))
((and (= c0 "|") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "|=" tok-line tok-col)))
((and (= c0 "^") (= c1 "="))
(do (rb-advance-n! 2) (rb-push! "op" "^=" tok-line tok-col)))
((and (= c0 "-") (= c1 ">"))
(do (rb-advance-n! 2) (rb-push! "op" "->" tok-line tok-col)))
((and (= c0 "=") (= c1 ">"))
(do (rb-advance-n! 2) (rb-push! "op" "=>" tok-line tok-col)))
((and (= c0 "|") (nil? c1))
(do (rb-advance!) (rb-push! "pipe" "|" tok-line tok-col)))
((= c0 "|")
(do (rb-advance!) (rb-push! "pipe" "|" tok-line tok-col)))
(:else
(do (rb-advance!) (rb-push! "op" c0 tok-line tok-col)))))))
(define rb-scan!
(fn ()
(cond
((>= pos src-len) nil)
((rb-space? (rb-cur)) (do (rb-advance!) (rb-scan!)))
((= (rb-cur) "#") (do (rb-skip-line-comment!) (rb-scan!)))
((= (rb-cur) "\n")
(do
(let ((l line) (c col))
(rb-advance!)
(rb-push! "newline" nil l c))
(rb-scan!)))
((rb-digit? (rb-cur))
(do
(let ((l line) (c col))
(rb-read-number! l c))
(rb-scan!)))
((rb-ident-start? (rb-cur))
(do
(let ((l line) (c col))
(let ((w (rb-read-ident-word)))
(if (rb-keyword? w)
(rb-push! "keyword" w l c)
(if (rb-upper? (substring w 0 1))
(rb-push! "const" w l c)
(rb-push! "ident" w l c)))))
(rb-scan!)))
((= (rb-cur) "@")
(do
(let ((l line) (c col))
(if (= (rb-peek 1) "@")
(do
(rb-advance-n! 2)
(let ((name (rb-read-while rb-ident-cont?)))
(rb-push! "cvar" (str "@@" name) l c)))
(do
(rb-advance!)
(let ((name (rb-read-while rb-ident-cont?)))
(rb-push! "ivar" (str "@" name) l c)))))
(rb-scan!)))
((= (rb-cur) "$")
(do
(let ((l line) (c col))
(rb-advance!)
(let ((name (rb-read-while rb-ident-cont?)))
(rb-push! "gvar" (str "$" name) l c)))
(rb-scan!)))
((= (rb-cur) "\"")
(do
(let ((l line) (c col))
(rb-push! "string" (rb-read-dq-string) l c))
(rb-scan!)))
((= (rb-cur) "'")
(do
(let ((l line) (c col))
(rb-push! "string" (rb-read-sq-string) l c))
(rb-scan!)))
((and (= (rb-cur) ":") (= (rb-peek 1) ":"))
(do
(let ((l line) (c col))
(rb-advance-n! 2)
(rb-push! "dcolon" "::" l c))
(rb-scan!)))
((= (rb-cur) ":")
(do
(let ((l line) (c col))
(rb-advance!)
(cond
((= (rb-cur) "\"")
(rb-push! "symbol" (rb-read-dq-string) l c))
((= (rb-cur) "'")
(rb-push! "symbol" (rb-read-sq-string) l c))
((rb-ident-start? (rb-cur))
(let ((name (rb-read-ident-word)))
(rb-push! "symbol" name l c)))
(:else
(rb-push! "colon" ":" l c))))
(rb-scan!)))
((and (= (rb-cur) "%")
(let ((p (rb-peek 1)))
(or (= p "w") (= p "W") (= p "i") (= p "I"))))
(do
(let ((l line) (c col))
(let ((kind (rb-peek 1)))
(let ((items (rb-read-percent-words)))
(if (or (= kind "i") (= kind "I"))
(rb-push! "isymbols" items l c)
(rb-push! "words" items l c)))))
(rb-scan!)))
((= (rb-cur) ".")
(do
(let ((l line) (c col))
(cond
((and (= (rb-peek 1) ".") (= (rb-peek 2) "."))
(do (rb-advance-n! 3) (rb-push! "dotdotdot" "..." l c)))
((= (rb-peek 1) ".")
(do (rb-advance-n! 2) (rb-push! "dotdot" ".." l c)))
(:else
(do (rb-advance!) (rb-push! "dot" "." l c)))))
(rb-scan!)))
((= (rb-cur) ",")
(do
(let ((l line) (c col)) (rb-push! "comma" "," l c) (rb-advance!))
(rb-scan!)))
((= (rb-cur) ";")
(do
(let ((l line) (c col)) (rb-push! "semi" ";" l c) (rb-advance!))
(rb-scan!)))
((= (rb-cur) "(")
(do
(let ((l line) (c col)) (rb-push! "lparen" "(" l c) (rb-advance!))
(rb-scan!)))
((= (rb-cur) ")")
(do
(let ((l line) (c col)) (rb-push! "rparen" ")" l c) (rb-advance!))
(rb-scan!)))
((= (rb-cur) "[")
(do
(let ((l line) (c col)) (rb-push! "lbracket" "[" l c) (rb-advance!))
(rb-scan!)))
((= (rb-cur) "]")
(do
(let ((l line) (c col)) (rb-push! "rbracket" "]" l c) (rb-advance!))
(rb-scan!)))
((= (rb-cur) "{")
(do
(let ((l line) (c col)) (rb-push! "lbrace" "{" l c) (rb-advance!))
(rb-scan!)))
((= (rb-cur) "}")
(do
(let ((l line) (c col)) (rb-push! "rbrace" "}" l c) (rb-advance!))
(rb-scan!)))
((or (= (rb-cur) "+") (= (rb-cur) "-") (= (rb-cur) "*")
(= (rb-cur) "/") (= (rb-cur) "%") (= (rb-cur) "=")
(= (rb-cur) "!") (= (rb-cur) "<") (= (rb-cur) ">")
(= (rb-cur) "&") (= (rb-cur) "^") (= (rb-cur) "~")
(= (rb-cur) "|"))
(do
(let ((l line) (c col)) (rb-read-op! l c))
(rb-scan!)))
(:else (do (rb-advance!) (rb-scan!))))))
(rb-scan!)
(rb-push! "eof" nil line col)
tokens)))

View File

@@ -1,370 +0,0 @@
;; lib/smalltalk/runtime.sx — Smalltalk primitives on SX
;;
;; Provides Smalltalk-idiomatic wrappers over SX built-ins.
;; Primitives used:
;; make-set/set-add!/set-member?/set-remove!/set->list (Phase 18)
;; char->integer/integer->char/list->string (Phase 5)
;; bitwise-and/or/xor/not/arithmetic-shift (Phase 7)
;; gcd/lcm/quotient/remainder/modulo (Phase 15)
;; ---------------------------------------------------------------------------
;; 0. Internal list helpers (used by Array and Dictionary)
;; ---------------------------------------------------------------------------
(define
(st-list-set-nth lst i newval)
(letrec
((go (fn (ps j) (if (= (len ps) 0) (list) (cons (if (= j i) newval (first ps)) (go (rest ps) (+ j 1)))))))
(go lst 0)))
(define
(st-list-remove-nth lst i)
(letrec
((go (fn (ps j) (if (= (len ps) 0) (list) (if (= j i) (go (rest ps) (+ j 1)) (cons (first ps) (go (rest ps) (+ j 1))))))))
(go lst 0)))
;; ---------------------------------------------------------------------------
;; 1. Numeric helpers
;; Thin wrappers or direct aliases for Smalltalk Number protocol.
;; ---------------------------------------------------------------------------
(define (st-abs x) (abs x))
(define (st-max a b) (if (> a b) a b))
(define (st-min a b) (if (< a b) a b))
(define (st-gcd a b) (gcd a b))
(define (st-lcm a b) (lcm a b))
(define (st-quo a b) (quotient a b))
(define (st-rem a b) (remainder a b))
(define (st-mod a b) (modulo a b))
(define (st-even? n) (= (remainder n 2) 0))
(define (st-odd? n) (not (st-even? n)))
(define (st-sqrt x) (sqrt x))
(define (st-floor x) (floor x))
(define (st-ceiling x) (ceil x))
(define (st-truncated x) (truncate x))
(define (st-rounded x) (round x))
;; ---------------------------------------------------------------------------
;; 2. Character
;; Smalltalk $A = char 65. Operations mirror Character class.
;; ---------------------------------------------------------------------------
(define (st-char-value c) (char->integer c))
(define (st-char-from-int n) (integer->char n))
(define (st-char? v) (= (type-of v) "char"))
(define
(st-char-is-letter? c)
(let
((n (char->integer c)))
(or
(and (>= n 65) (<= n 90))
(and (>= n 97) (<= n 122)))))
(define
(st-char-is-digit? c)
(let ((n (char->integer c))) (and (>= n 48) (<= n 57))))
(define
(st-char-is-uppercase? c)
(let ((n (char->integer c))) (and (>= n 65) (<= n 90))))
(define
(st-char-is-lowercase? c)
(let ((n (char->integer c))) (and (>= n 97) (<= n 122))))
(define
(st-char-is-separator? c)
(let
((n (char->integer c)))
(or
(= n 32)
(= n 9)
(= n 10)
(= n 13))))
(define
(st-char-as-uppercase c)
(let
((n (char->integer c)))
(if
(and (>= n 97) (<= n 122))
(integer->char (- n 32))
c)))
(define
(st-char-as-lowercase c)
(let
((n (char->integer c)))
(if
(and (>= n 65) (<= n 90))
(integer->char (+ n 32))
c)))
(define (st-char-digit-value c) (- (char->integer c) 48))
;; ---------------------------------------------------------------------------
;; 3. Array (1-indexed, mutable, fixed-size)
;; Backed as {:__st_array__ true :size N "1" v1 "2" v2 ...}
;; Unset elements read as nil.
;; ---------------------------------------------------------------------------
(define
(st-array-new n)
(let
((a (dict)))
(dict-set! a "__st_array__" true)
(dict-set! a "size" n)
a))
(define (st-array? v) (and (dict? v) (dict-has? v "__st_array__")))
(define (st-array-size a) (get a "size"))
(define
(st-array-at a i)
(let ((v (get a (str i)))) (if (= v nil) nil v)))
(define (st-array-at-put! a i v) (dict-set! a (str i) v) a)
(define
(st-array-do a fn)
(letrec
((go (fn (i) (when (<= i (st-array-size a)) (fn (st-array-at a i)) (go (+ i 1))))))
(go 1)))
(define
(st-array->list a)
(letrec
((go (fn (i acc) (if (< i 1) acc (go (- i 1) (cons (st-array-at a i) acc))))))
(go (st-array-size a) (list))))
(define
(st-list->array xs)
(let
((a (st-array-new (len xs))))
(letrec
((go (fn (ys i) (when (> (len ys) 0) (st-array-at-put! a i (first ys)) (go (rest ys) (+ i 1))))))
(go xs 1))
a))
(define
(st-array-copy-from-to a start stop)
(let
((result (st-array-new (- stop start -1))))
(letrec
((go (fn (i j) (when (<= i stop) (st-array-at-put! result j (st-array-at a i)) (go (+ i 1) (+ j 1))))))
(go start 1))
result))
;; ---------------------------------------------------------------------------
;; 4. Dictionary (hash map with any key via linear scan)
;; {:__st_dict__ true :size N :_pairs ((key val) ...)}
;; ---------------------------------------------------------------------------
(define
(st-dict-new)
(let
((d (dict)))
(dict-set! d "__st_dict__" true)
(dict-set! d "size" 0)
(dict-set! d "_pairs" (list))
d))
(define (st-dict? v) (and (dict? v) (dict-has? v "__st_dict__")))
(define (st-dict-size d) (get d "size"))
(define
(st-dict-find-idx pairs k)
(letrec
((go (fn (ps i) (cond ((= (len ps) 0) -1) ((= (first (first ps)) k) i) (else (go (rest ps) (+ i 1)))))))
(go pairs 0)))
(define
(st-dict-at d k)
(letrec
((go (fn (ps) (if (= (len ps) 0) nil (if (= (first (first ps)) k) (nth (first ps) 1) (go (rest ps)))))))
(go (get d "_pairs"))))
(define
(st-dict-at-put! d k v)
(let
((pairs (get d "_pairs")) (idx (st-dict-find-idx (get d "_pairs") k)))
(if
(= idx -1)
(begin
(dict-set! d "_pairs" (append pairs (list (list k v))))
(dict-set! d "size" (+ (get d "size") 1)))
(dict-set! d "_pairs" (st-list-set-nth pairs idx (list k v)))))
d)
(define
(st-dict-includes-key? d k)
(not (= (st-dict-find-idx (get d "_pairs") k) -1)))
(define
(st-dict-at-default d k def)
(if (st-dict-includes-key? d k) (st-dict-at d k) def))
(define
(st-dict-remove-key! d k)
(let
((idx (st-dict-find-idx (get d "_pairs") k)))
(when
(not (= idx -1))
(dict-set! d "_pairs" (st-list-remove-nth (get d "_pairs") idx))
(dict-set! d "size" (- (get d "size") 1))))
d)
(define (st-dict-keys d) (map first (get d "_pairs")))
(define
(st-dict-values d)
(map (fn (p) (nth p 1)) (get d "_pairs")))
(define
(st-dict-do d fn)
(for-each (fn (p) (fn (nth p 1))) (get d "_pairs")))
(define
(st-dict-do-associations d fn)
(for-each (fn (p) (fn (first p) (nth p 1))) (get d "_pairs")))
;; ---------------------------------------------------------------------------
;; 5. Set (uniqueness via SX make-set)
;; Note: set-member?/set-add!/set-remove! take (set item) order.
;; ---------------------------------------------------------------------------
(define
(st-set-new)
(let
((s (dict)))
(dict-set! s "__st_set__" true)
(dict-set! s "size" 0)
(dict-set! s "_set" (make-set))
s))
(define (st-set? v) (and (dict? v) (dict-has? v "__st_set__")))
(define (st-set-size s) (get s "size"))
(define
(st-set-add! s v)
(let
((sx (get s "_set")))
(when
(not (set-member? sx v))
(set-add! sx v)
(dict-set! s "size" (+ (get s "size") 1))))
s)
(define (st-set-includes? s v) (set-member? (get s "_set") v))
(define
(st-set-remove! s v)
(let
((sx (get s "_set")))
(when
(set-member? sx v)
(set-remove! sx v)
(dict-set! s "size" (- (get s "size") 1))))
s)
(define (st-set->list s) (set->list (get s "_set")))
(define (st-set-do s fn) (for-each fn (st-set->list s)))
;; ---------------------------------------------------------------------------
;; 6. String / Stream utilities
;; ---------------------------------------------------------------------------
;; Join list of strings with separator
(define
(st-join-strings strs sep)
(if
(= (len strs) 0)
""
(letrec
((go (fn (ss acc) (if (= (len ss) 0) acc (go (rest ss) (str acc sep (first ss)))))))
(go (rest strs) (first strs)))))
;; printString — Smalltalk textual representation
(define
(st-print-string v)
(cond
((= v nil) "nil")
((= v true) "true")
((= v false) "false")
((= (type-of v) "number") (str v))
((= (type-of v) "string") (str "'" v "'"))
((= (type-of v) "symbol") (str "#" (str v)))
((= (type-of v) "char") (str "$" (list->string (list v))))
((= (type-of v) "list")
(str "(" (st-join-strings (map st-print-string v) " ") ")"))
((st-array? v)
(str
"(#("
(st-join-strings (map st-print-string (st-array->list v)) " ")
"))"))
(else (str v))))
;; WriteStream — accumulates strings/chars to a buffer
(define
(st-write-stream-new)
(let
((ws (dict)))
(dict-set! ws "__st_ws__" true)
(dict-set! ws "contents" "")
ws))
(define (st-write-stream? v) (and (dict? v) (dict-has? v "__st_ws__")))
(define
(st-write-stream-put-string! ws s)
(dict-set! ws "contents" (str (get ws "contents") s))
ws)
(define
(st-write-stream-next-put! ws c)
(st-write-stream-put-string! ws (list->string (list c))))
(define
(st-write-stream-print! ws v)
(st-write-stream-put-string! ws (st-print-string v)))
(define (st-write-stream-contents ws) (get ws "contents"))
;; ReadStream — reads characters from a string one at a time
(define
(st-read-stream-new s)
(let
((rs (dict)))
(dict-set! rs "__st_rs__" true)
(dict-set! rs "_chars" (string->list s))
(dict-set! rs "pos" 0)
rs))
(define (st-read-stream? v) (and (dict? v) (dict-has? v "__st_rs__")))
(define
(st-read-stream-at-end? rs)
(>= (get rs "pos") (len (get rs "_chars"))))
(define
(st-read-stream-next rs)
(if
(st-read-stream-at-end? rs)
nil
(let
((c (nth (get rs "_chars") (get rs "pos"))))
(dict-set! rs "pos" (+ (get rs "pos") 1))
c)))
(define
(st-read-stream-peek rs)
(if
(st-read-stream-at-end? rs)
nil
(nth (get rs "_chars") (get rs "pos"))))
(define (st-read-stream-source rs) (list->string (get rs "_chars")))

View File

@@ -1,71 +0,0 @@
#!/usr/bin/env bash
# lib/smalltalk/test.sh — smoke-test the Smalltalk runtime layer.
# Uses sx_server.exe epoch protocol.
#
# Usage:
# bash lib/smalltalk/test.sh
# bash lib/smalltalk/test.sh -v
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
exit 1
fi
VERBOSE="${1:-}"
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/smalltalk/runtime.sx")
(epoch 2)
(load "lib/smalltalk/tests/runtime.sx")
(epoch 3)
(eval "(list st-test-pass st-test-fail)")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"
echo "$OUTPUT" | tail -10
exit 1
fi
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
TOTAL=$((P + F))
if [ "$F" -eq 0 ]; then
echo "ok $P/$TOTAL lib/smalltalk tests passed"
else
echo "FAIL $P/$TOTAL passed, $F failed"
# Print failure details
TMPFILE2=$(mktemp)
cat > "$TMPFILE2" << 'EPOCHS2'
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/smalltalk/runtime.sx")
(epoch 2)
(load "lib/smalltalk/tests/runtime.sx")
(epoch 3)
(eval "(map (fn (f) (get f \"name\")) st-test-fails)")
EPOCHS2
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>/dev/null | grep -E '^\(ok 3 ' || true)
rm -f "$TMPFILE2"
echo " Failures: $FAILS"
fi
[ "$F" -eq 0 ]

View File

@@ -1,241 +0,0 @@
;; lib/smalltalk/tests/runtime.sx — Tests for lib/smalltalk/runtime.sx
;;
;; Uses the same hk-test framework as lib/haskell/tests/runtime.sx.
;; Load: lib/smalltalk/runtime.sx first.
;; --- Test framework ---
(define st-test-pass 0)
(define st-test-fail 0)
(define st-test-fails (list))
(define
(st-test name got expected)
(if
(= got expected)
(set! st-test-pass (+ st-test-pass 1))
(begin
(set! st-test-fail (+ st-test-fail 1))
(set! st-test-fails (append st-test-fails (list {:got got :expected expected :name name}))))))
;; ---------------------------------------------------------------------------
;; 1. Numeric helpers
;; ---------------------------------------------------------------------------
(st-test "abs -5" (st-abs -5) 5)
(st-test "abs 3" (st-abs 3) 3)
(st-test "max 3 7" (st-max 3 7) 7)
(st-test "min 3 7" (st-min 3 7) 3)
(st-test "gcd 12 8" (st-gcd 12 8) 4)
(st-test "lcm 4 6" (st-lcm 4 6) 12)
(st-test "quo 10 3" (st-quo 10 3) 3)
(st-test "quo -10 3" (st-quo -10 3) -3)
(st-test "rem 10 3" (st-rem 10 3) 1)
(st-test "rem -10 3" (st-rem -10 3) -1)
(st-test "mod 10 3" (st-mod 10 3) 1)
(st-test "mod -10 3" (st-mod -10 3) 2)
(st-test "even? 4" (st-even? 4) true)
(st-test "even? 3" (st-even? 3) false)
(st-test "odd? 7" (st-odd? 7) true)
(st-test "floor 3.7" (st-floor 3.7) 3)
(st-test "ceiling 3.2" (st-ceiling 3.2) 4)
(st-test "truncated 3.9" (st-truncated 3.9) 3)
(st-test "rounded 3.5" (st-rounded 3.5) 4)
;; ---------------------------------------------------------------------------
;; 2. Character
;; ---------------------------------------------------------------------------
(st-test
"char-value A"
(st-char-value (st-char-from-int 65))
65)
(st-test "char-from-int" (st-char? (st-char-from-int 65)) true)
(st-test "char? true" (st-char? (integer->char 65)) true)
(st-test "char? false" (st-char? 65) false)
(st-test "is-letter? A" (st-char-is-letter? (integer->char 65)) true)
(st-test
"is-letter? 1"
(st-char-is-letter? (integer->char 49))
false)
(st-test "is-digit? 5" (st-char-is-digit? (integer->char 53)) true)
(st-test "is-digit? A" (st-char-is-digit? (integer->char 65)) false)
(st-test
"is-uppercase? A"
(st-char-is-uppercase? (integer->char 65))
true)
(st-test
"is-uppercase? a"
(st-char-is-uppercase? (integer->char 97))
false)
(st-test
"is-lowercase? a"
(st-char-is-lowercase? (integer->char 97))
true)
(st-test
"is-lowercase? A"
(st-char-is-lowercase? (integer->char 65))
false)
(st-test
"is-separator? sp"
(st-char-is-separator? (integer->char 32))
true)
(st-test
"is-separator? A"
(st-char-is-separator? (integer->char 65))
false)
(st-test
"as-uppercase a"
(st-char-value (st-char-as-uppercase (integer->char 97)))
65)
(st-test
"as-uppercase A"
(st-char-value (st-char-as-uppercase (integer->char 65)))
65)
(st-test
"as-lowercase A"
(st-char-value (st-char-as-lowercase (integer->char 65)))
97)
(st-test
"digit-value 5"
(st-char-digit-value (integer->char 53))
5)
;; ---------------------------------------------------------------------------
;; 3. Array
;; ---------------------------------------------------------------------------
(st-test
"array-new size"
(st-array-size (st-array-new 5))
5)
(st-test "array? yes" (st-array? (st-array-new 3)) true)
(st-test "array? no" (st-array? 42) false)
(st-test
"array-at nil"
(st-array-at (st-array-new 3) 1)
nil)
(let
((a (st-array-new 3)))
(st-array-at-put! a 1 10)
(st-array-at-put! a 2 20)
(st-array-at-put! a 3 30)
(st-test "array-at 1" (st-array-at a 1) 10)
(st-test "array-at 2" (st-array-at a 2) 20)
(st-test "array-at 3" (st-array-at a 3) 30))
(st-test
"list->array->list"
(st-array->list (st-list->array (list 1 2 3)))
(list 1 2 3))
(let
((a (st-list->array (list 10 20 30 40 50))))
(st-test
"copy-from-to"
(st-array->list (st-array-copy-from-to a 2 4))
(list 20 30 40)))
;; ---------------------------------------------------------------------------
;; 4. Dictionary
;; ---------------------------------------------------------------------------
(st-test "dict? yes" (st-dict? (st-dict-new)) true)
(st-test "dict? no" (st-dict? 42) false)
(st-test "dict empty size" (st-dict-size (st-dict-new)) 0)
(st-test "dict at absent" (st-dict-at (st-dict-new) "k") nil)
(let
((d (st-dict-new)))
(st-dict-at-put! d "a" 1)
(st-dict-at-put! d "b" 2)
(st-test "dict at a" (st-dict-at d "a") 1)
(st-test "dict at b" (st-dict-at d "b") 2)
(st-test "dict size 2" (st-dict-size d) 2)
(st-test "includes-key? yes" (st-dict-includes-key? d "a") true)
(st-test "includes-key? no" (st-dict-includes-key? d "z") false)
(st-dict-at-put! d "a" 99)
(st-test "dict update" (st-dict-at d "a") 99)
(st-test "size unchanged" (st-dict-size d) 2)
(st-dict-remove-key! d "a")
(st-test "size after remove" (st-dict-size d) 1)
(st-test "at-default hit" (st-dict-at-default d "b" 0) 2)
(st-test "at-default miss" (st-dict-at-default d "z" -1) -1))
;; ---------------------------------------------------------------------------
;; 5. Set
;; ---------------------------------------------------------------------------
(st-test "set? yes" (st-set? (st-set-new)) true)
(st-test "set? no" (st-set? 42) false)
(st-test "set empty size" (st-set-size (st-set-new)) 0)
(let
((s (st-set-new)))
(st-set-add! s 1)
(st-set-add! s 2)
(st-set-add! s 1)
(st-test "set includes 1" (st-set-includes? s 1) true)
(st-test "set includes 2" (st-set-includes? s 2) true)
(st-test "set not includes 3" (st-set-includes? s 3) false)
(st-test "set dedup size" (st-set-size s) 2)
(st-set-remove! s 1)
(st-test "size after remove" (st-set-size s) 1)
(st-test "removed gone" (st-set-includes? s 1) false))
;; ---------------------------------------------------------------------------
;; 6. String / Stream
;; ---------------------------------------------------------------------------
(st-test "join-strings 3" (st-join-strings (list "a" "b" "c") "-") "a-b-c")
(st-test "join-strings 1" (st-join-strings (list "x") ",") "x")
(st-test "join-strings empty" (st-join-strings (list) ",") "")
(st-test "print nil" (st-print-string nil) "nil")
(st-test "print true" (st-print-string true) "true")
(st-test "print false" (st-print-string false) "false")
(st-test "print number" (st-print-string 42) "42")
(st-test "print string" (st-print-string "hi") "'hi'")
(st-test "print char" (st-print-string (integer->char 65)) "$A")
(st-test "print list" (st-print-string (list 1 2)) "(1 2)")
(let
((ws (st-write-stream-new)))
(st-write-stream-put-string! ws "hello")
(st-write-stream-put-string! ws " world")
(st-test
"write-stream contents"
(st-write-stream-contents ws)
"hello world"))
(let
((ws (st-write-stream-new)))
(st-write-stream-next-put! ws (integer->char 72))
(st-write-stream-next-put! ws (integer->char 105))
(st-test "write-stream next-put!" (st-write-stream-contents ws) "Hi"))
(let
((rs (st-read-stream-new "ABC")))
(st-test
"read-stream next A"
(st-char-value (st-read-stream-next rs))
65)
(st-test
"read-stream next B"
(st-char-value (st-read-stream-next rs))
66)
(st-test
"read-stream peek C"
(st-char-value (st-read-stream-peek rs))
67)
(st-test
"read-stream next C"
(st-char-value (st-read-stream-next rs))
67)
(st-test "read-stream at-end" (st-read-stream-at-end? rs) true))
;; ---------------------------------------------------------------------------
;; Summary (must be last form — test.sh reads this)
;; ---------------------------------------------------------------------------
(list st-test-pass st-test-fail)

View File

@@ -1,279 +0,0 @@
;; lib/tcl/runtime.sx — Tcl primitives on SX
;;
;; Provides Tcl-idiomatic wrappers over SX built-ins.
;; Primitives used:
;; make-regexp/regexp-match/regexp-match-all/... (Phase 19)
;; make-set/set-add!/set-member?/set-remove!/set->list (Phase 18)
;; call/cc (core evaluator)
;; quotient/remainder (Phase 15 / builtin)
;; string->list/list->string/char->integer (Phase 13)
;; ---------------------------------------------------------------------------
;; 1. String buffer — Tcl append / string accumulation
;; ---------------------------------------------------------------------------
(define
(tcl-sb-new)
(let
((sb (dict)))
(dict-set! sb "_tcl_sb" true)
(dict-set! sb "_buf" "")
sb))
(define (tcl-sb? v) (and (dict? v) (dict-has? v "_tcl_sb")))
(define
(tcl-sb-append! sb s)
(dict-set! sb "_buf" (str (get sb "_buf") s))
sb)
(define (tcl-sb-value sb) (get sb "_buf"))
(define (tcl-sb-clear! sb) (dict-set! sb "_buf" "") sb)
(define (tcl-sb-length sb) (len (get sb "_buf")))
;; ---------------------------------------------------------------------------
;; 2. String port (channel) — Tcl channel abstraction
;; Read channel: created from a string, supports gets/read.
;; Write channel: accumulates puts output, queryable via tcl-chan-string.
;; ---------------------------------------------------------------------------
(define
(tcl-chan-in-new str)
(let
((c (dict)))
(dict-set! c "_tcl_chan" true)
(dict-set! c "_mode" "read")
(dict-set! c "_chars" (string->list str))
(dict-set! c "_pos" 0)
c))
(define
(tcl-chan-out-new)
(let
((c (dict)))
(dict-set! c "_tcl_chan" true)
(dict-set! c "_mode" "write")
(dict-set! c "_buf" "")
c))
(define (tcl-chan? v) (and (dict? v) (dict-has? v "_tcl_chan")))
(define
(tcl-chan-eof? c)
(and
(= (get c "_mode") "read")
(>= (get c "_pos") (len (get c "_chars")))))
(define
(tcl-chan-read-char c)
(if
(tcl-chan-eof? c)
nil
(let
((ch (nth (get c "_chars") (get c "_pos"))))
(dict-set! c "_pos" (+ (get c "_pos") 1))
ch)))
;; gets — read one line (up to newline or EOF), return without trailing newline
(define
(tcl-chan-gets c)
(letrec
((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (cond ((= ch nil) (list->string (reverse acc))) ((= (char->integer ch) 10) (list->string (reverse acc))) (else (go (cons ch acc))))))))
(go (list))))
;; read — read all remaining chars
(define
(tcl-chan-read c)
(letrec
((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (if (= ch nil) (list->string (reverse acc)) (go (cons ch acc)))))))
(go (list))))
;; puts — write string to write channel (no newline)
(define
(tcl-chan-puts! c s)
(when
(= (get c "_mode") "write")
(dict-set! c "_buf" (str (get c "_buf") s)))
c)
;; puts-line — write string + newline (Tcl default puts behaviour)
(define (tcl-chan-puts-line! c s) (tcl-chan-puts! c (str s "\n")))
;; string — get accumulated content of write channel
(define (tcl-chan-string c) (get c "_buf"))
;; tell — current read position
(define (tcl-chan-tell c) (get c "_pos"))
;; ---------------------------------------------------------------------------
;; 3. Regexp — Tcl regexp / regsub wrappers
;; ---------------------------------------------------------------------------
(define (tcl-re-new pattern) (make-regexp pattern ""))
(define (tcl-re-new-flags pattern flags) (make-regexp pattern flags))
(define (tcl-re? v) (regexp? v))
(define (tcl-re-match? rx str) (not (= (regexp-match rx str) nil)))
(define (tcl-re-match rx str) (regexp-match rx str))
(define (tcl-re-match-all rx str) (regexp-match-all rx str))
(define (tcl-re-sub rx str replacement) (regexp-replace rx str replacement))
(define
(tcl-re-sub-all rx str replacement)
(regexp-replace-all rx str replacement))
(define (tcl-re-split rx str) (regexp-split rx str))
;; ---------------------------------------------------------------------------
;; 4. Format — Tcl format command (%s %d %f %x %o %%)
;; tcl-format takes a format string and a list of arguments.
;; Example: (tcl-format "%s is %d" (list "Alice" 30)) → "Alice is 30"
;; ---------------------------------------------------------------------------
;; Digit characters for base conversion
(define tcl-hex-chars (string->list "0123456789abcdef"))
(define
(tcl-digits-for-base n base digit-chars)
(let
((abs-n (if (< n 0) (- 0 n) n)))
(letrec
((go (fn (n acc) (if (= n 0) (if (= (len acc) 0) "0" (list->string acc)) (go (quotient n base) (cons (nth digit-chars (remainder n base)) acc))))))
(let
((unsigned (go abs-n (list))))
(if (< n 0) (str "-" unsigned) unsigned)))))
(define
(tcl-format-hex n)
(tcl-digits-for-base (truncate n) 16 tcl-hex-chars))
(define
(tcl-format-oct n)
(tcl-digits-for-base (truncate n) 8 (string->list "01234567")))
(define
(tcl-format fmt args)
(letrec
((chars (string->list fmt))
(go
(fn
(cs arg-list result)
(if
(= (len cs) 0)
result
(let
((c-int (char->integer (first cs))))
(if
(= c-int 37)
(if
(= (len (rest cs)) 0)
result
(let
((spec-int (char->integer (first (rest cs)))))
(cond
((= spec-int 37)
(go (rest (rest cs)) arg-list (str result "%")))
((= spec-int 115)
(go
(rest (rest cs))
(rest arg-list)
(str result (str (first arg-list)))))
((= spec-int 100)
(go
(rest (rest cs))
(rest arg-list)
(str result (str (truncate (first arg-list))))))
((= spec-int 102)
(go
(rest (rest cs))
(rest arg-list)
(str result (str (+ 0 (first arg-list))))))
((= spec-int 120)
(go
(rest (rest cs))
(rest arg-list)
(str result (tcl-format-hex (first arg-list)))))
((= spec-int 111)
(go
(rest (rest cs))
(rest arg-list)
(str result (tcl-format-oct (first arg-list)))))
(else
(go
(rest (rest cs))
arg-list
(str
result
"%"
(list->string (list (first (rest cs))))))))))
(go
(rest cs)
arg-list
(str result (list->string (list (first cs)))))))))))
(go chars args "")))
;; ---------------------------------------------------------------------------
;; 5. Coroutine — Tcl-style coroutine using call/cc
;; tcl-co-yield works reliably when called from top-level fns.
;; Avoid calling tcl-co-yield from letrec-bound lambdas (JIT limitation).
;; ---------------------------------------------------------------------------
(define tcl-current-co nil)
(define
(tcl-co-new body)
(let
((co (dict)))
(dict-set! co "_tcl_co" true)
(dict-set! co "_state" "new")
(dict-set! co "_cont" nil)
(dict-set! co "_resumer" nil)
(dict-set! co "_parent" nil)
(dict-set!
co
"_body"
(fn
()
(let
((result (body)))
(dict-set! co "_state" "dead")
(set! tcl-current-co (get co "_parent"))
((get co "_resumer") result))))
co))
(define (tcl-co? v) (and (dict? v) (dict-has? v "_tcl_co")))
(define (tcl-co-alive? co) (not (= (get co "_state") "dead")))
(define
(tcl-co-yield val)
(call/cc
(fn
(resume-k)
(let
((cur tcl-current-co))
(dict-set! cur "_cont" resume-k)
(dict-set! cur "_state" "suspended")
(set! tcl-current-co (get cur "_parent"))
((get cur "_resumer") val)))))
(define
(tcl-co-resume co)
(call/cc
(fn
(return-k)
(dict-set! co "_parent" tcl-current-co)
(dict-set! co "_resumer" return-k)
(set! tcl-current-co co)
(dict-set! co "_state" "running")
(if
(= (get co "_cont") nil)
((get co "_body"))
((get co "_cont") nil)))))

View File

@@ -1,62 +0,0 @@
#!/usr/bin/env bash
# lib/tcl/test.sh — smoke-test the Tcl runtime layer.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found."
exit 1
fi
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "lib/tcl/runtime.sx")
(epoch 2)
(load "lib/tcl/tests/runtime.sx")
(epoch 3)
(eval "(list tcl-test-pass tcl-test-fail)")
EPOCHS
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"
echo "$OUTPUT" | tail -20
exit 1
fi
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
TOTAL=$((P + F))
if [ "$F" -eq 0 ]; then
echo "ok $P/$TOTAL lib/tcl tests passed"
else
echo "FAIL $P/$TOTAL passed, $F failed"
TMPFILE2=$(mktemp)
cat > "$TMPFILE2" << 'EPOCHS2'
(epoch 1)
(load "lib/tcl/runtime.sx")
(epoch 2)
(load "lib/tcl/tests/runtime.sx")
(epoch 3)
(eval "(map (fn (f) (list (get f :name) (get f :got) (get f :expected))) tcl-test-fails)")
EPOCHS2
FAILS=$(timeout 60 "$SX_SERVER" < "$TMPFILE2" 2>/dev/null | grep -E '^\(ok-len 3' -A1 | tail -1 || true)
echo " Details: $FAILS"
rm -f "$TMPFILE2"
fi
[ "$F" -eq 0 ]

View File

@@ -1,146 +0,0 @@
;; lib/tcl/tests/runtime.sx — Tests for lib/tcl/runtime.sx
(define tcl-test-pass 0)
(define tcl-test-fail 0)
(define tcl-test-fails (list))
(define
(tcl-test name got expected)
(if
(= got expected)
(set! tcl-test-pass (+ tcl-test-pass 1))
(begin
(set! tcl-test-fail (+ tcl-test-fail 1))
(set! tcl-test-fails (append tcl-test-fails (list {:got got :expected expected :name name}))))))
;; ---------------------------------------------------------------------------
;; 1. String buffer
;; ---------------------------------------------------------------------------
(define sb1 (tcl-sb-new))
(tcl-test "sb? new" (tcl-sb? sb1) true)
(tcl-test "sb? non-sb" (tcl-sb? "hello") false)
(tcl-test "sb value empty" (tcl-sb-value sb1) "")
(tcl-test "sb length empty" (tcl-sb-length sb1) 0)
(tcl-sb-append! sb1 "hello")
(tcl-test "sb value after append" (tcl-sb-value sb1) "hello")
(tcl-sb-append! sb1 " ")
(tcl-sb-append! sb1 "world")
(tcl-test "sb value after multi-append" (tcl-sb-value sb1) "hello world")
(tcl-test "sb length" (tcl-sb-length sb1) 11)
(tcl-sb-clear! sb1)
(tcl-test "sb value after clear" (tcl-sb-value sb1) "")
(tcl-test "sb length after clear" (tcl-sb-length sb1) 0)
;; ---------------------------------------------------------------------------
;; 2. String port (channel)
;; ---------------------------------------------------------------------------
(define chin1 (tcl-chan-in-new "hello\nworld\nfoo"))
(tcl-test "chan? read" (tcl-chan? chin1) true)
(tcl-test "chan eof? no" (tcl-chan-eof? chin1) false)
(tcl-test "chan gets line1" (tcl-chan-gets chin1) "hello")
(tcl-test "chan gets line2" (tcl-chan-gets chin1) "world")
(tcl-test "chan gets line3" (tcl-chan-gets chin1) "foo")
(tcl-test "chan eof? yes" (tcl-chan-eof? chin1) true)
(tcl-test "chan gets at eof" (tcl-chan-gets chin1) "")
(define chin2 (tcl-chan-in-new "abcdef"))
(tcl-test "chan read all" (tcl-chan-read chin2) "abcdef")
(tcl-test "chan read empty" (tcl-chan-read chin2) "")
(define chout1 (tcl-chan-out-new))
(tcl-test "chan? write" (tcl-chan? chout1) true)
(tcl-chan-puts! chout1 "hello")
(tcl-chan-puts! chout1 " world")
(tcl-test "chan string" (tcl-chan-string chout1) "hello world")
(tcl-chan-puts-line! chout1 "!")
(tcl-test "chan string with newline" (tcl-chan-string chout1) "hello world!\n")
(define chout2 (tcl-chan-out-new))
(tcl-chan-puts-line! chout2 "line1")
(tcl-chan-puts-line! chout2 "line2")
(tcl-test "chan multi-line" (tcl-chan-string chout2) "line1\nline2\n")
;; ---------------------------------------------------------------------------
;; 3. Regexp
;; ---------------------------------------------------------------------------
(define rx1 (tcl-re-new "hel+o"))
(tcl-test "re? yes" (tcl-re? rx1) true)
(tcl-test "re? no" (tcl-re? "hello") false)
(tcl-test "re match? yes" (tcl-re-match? rx1 "say hello") true)
(tcl-test "re match? no" (tcl-re-match? rx1 "goodbye") false)
(define m1 (tcl-re-match rx1 "say hello world"))
(tcl-test "re match result" (get m1 "match") "hello")
(define rx2 (tcl-re-new "[0-9]+"))
(define all (tcl-re-match-all rx2 "a1b22c333"))
(tcl-test "re match-all count" (len all) 3)
(tcl-test "re match-all last" (get (nth all 2) "match") "333")
(tcl-test "re sub" (tcl-re-sub rx2 "a1b2" "N") "aNb2")
(tcl-test "re sub-all" (tcl-re-sub-all rx2 "a1b2" "N") "aNbN")
(define rx3 (tcl-re-new "[ ,]+"))
(tcl-test "re split" (tcl-re-split rx3 "a b,c") (list "a" "b" "c"))
;; ---------------------------------------------------------------------------
;; 4. Format
;; ---------------------------------------------------------------------------
(tcl-test "format %s" (tcl-format "hello %s" (list "world")) "hello world")
(tcl-test "format %d" (tcl-format "n=%d" (list 42)) "n=42")
(tcl-test "format %d truncates float" (tcl-format "n=%d" (list 3.9)) "n=3")
(tcl-test
"format %s %d"
(tcl-format "%s is %d" (list "age" 30))
"age is 30")
(tcl-test "format %%" (tcl-format "100%% done" (list)) "100% done")
(tcl-test "format %x" (tcl-format "%x" (list 255)) "ff")
(tcl-test "format %x 16" (tcl-format "0x%x" (list 16)) "0x10")
(tcl-test "format %o" (tcl-format "%o" (list 8)) "10")
(tcl-test "format %o 255" (tcl-format "%o" (list 255)) "377")
(tcl-test "format no spec" (tcl-format "plain text" (list)) "plain text")
(tcl-test
"format multiple"
(tcl-format "%s=%d (0x%x)" (list "val" 255 255))
"val=255 (0xff)")
;; ---------------------------------------------------------------------------
;; 5. Coroutine
;; tcl-co-yield works from top-level helper functions.
;; ---------------------------------------------------------------------------
(define
co1
(tcl-co-new
(fn () (tcl-co-yield 1) (tcl-co-yield 2) 3)))
(tcl-test "co? yes" (tcl-co? co1) true)
(tcl-test "co? no" (tcl-co? 42) false)
(tcl-test "co alive? before" (tcl-co-alive? co1) true)
(define cor1 (tcl-co-resume co1))
(tcl-test "co resume 1" cor1 1)
(tcl-test "co alive? mid" (tcl-co-alive? co1) true)
(define cor2 (tcl-co-resume co1))
(tcl-test "co resume 2" cor2 2)
(define cor3 (tcl-co-resume co1))
(tcl-test "co resume 3 completion" cor3 3)
(tcl-test "co alive? dead" (tcl-co-alive? co1) false)
;; Top-level helper for recursive yield (avoids JIT letrec limitation)
(define
(tcl-co-count-down i)
(when
(>= i 1)
(tcl-co-yield i)
(tcl-co-count-down (- i 1))))
(define co2 (tcl-co-new (fn () (tcl-co-count-down 3) "done")))
(tcl-test "co loop 3" (tcl-co-resume co2) 3)
(tcl-test "co loop 2" (tcl-co-resume co2) 2)
(tcl-test "co loop 1" (tcl-co-resume co2) 1)
(tcl-test "co loop done" (tcl-co-resume co2) "done")
(tcl-test "co loop dead" (tcl-co-alive? co2) false)

View File

@@ -1,789 +0,0 @@
# SX Primitives — Meta-Loop Briefing
Goal: add fundamental missing SX primitives in sequence, then sweep all language
implementations to replace their workarounds. Full rationale: vectors fix O(n) array
access across every language; numeric tower fixes float/int conflation; dynamic-wind
fixes cleanup semantics; coroutine primitive unifies Ruby/Lua/Tcl; string buffer fixes
O(n²) concat; algebraic data types eliminate the tagged-dict pattern everywhere.
**Each fire: find the first unchecked `[ ]`, do it, commit, tick it, stop.**
Sub-items within a Phase may span multiple fires — just commit progress and tick what's done.
---
## Phase 0 — Prep (gate)
- [x] Stop new-language loops: send `/exit` to sx-loops windows for the four blank-slate
languages that haven't committed workarounds yet:
```
tmux send-keys -t sx-loops:common-lisp "/exit" Enter
tmux send-keys -t sx-loops:apl "/exit" Enter
tmux send-keys -t sx-loops:ruby "/exit" Enter
tmux send-keys -t sx-loops:tcl "/exit" Enter
```
Verify all four windows are idle (claude prompt, no active task).
- [x] E38 + E39 landed: check both Bucket-E branches for implementation commits.
```
git log --oneline hs-e38-sourceinfo | head -5
git log --oneline hs-e39-webworker | head -5
```
If either branch has only its base commit (no impl work yet): note "pending" and stop —
next fire re-checks. Proceed only when both have at least one implementation commit.
---
## Phase 1 — Vectors
Native mutable integer-indexed arrays. Fix: Lua O(n) sort, APL rank polymorphism, Ruby
Array, Tcl lists, Common Lisp vectors, all using string-keyed dicts today.
Primitives to add:
- `make-vector` `n` `[fill]` → vector of length n
- `vector?` `v` → bool
- `vector-ref` `v` `i` → element at index i (0-based)
- `vector-set!` `v` `i` `x` → mutate in place
- `vector-length` `v` → integer
- `vector->list` `v` → list
- `list->vector` `lst` → vector
- `vector-fill!` `v` `x` → fill all elements
- `vector-copy` `v` `[start]` `[end]` → fresh copy of slice
Steps:
- [x] OCaml: add `SxVector of value array` to `hosts/ocaml/sx_types.ml`; implement all
primitives in `hosts/ocaml/sx_primitives.ml` (or equivalent); wire into evaluator.
Note: Vector type + most prims were already present; added bounds-checked vector-ref/set!
and optional start/end to vector-copy. 10/10 vector tests pass (r7rs suite).
- [x] Spec: add vector entries to `spec/primitives.sx` with type signatures and descriptions.
All 10 vector primitives now have :as type annotations, :returns, and :doc strings.
make-vector: optional fill param; vector-copy: optional start/end (done prev step).
- [x] JS bootstrapper: implement vectors in `hosts/javascript/platform.js` (or equivalent);
ensure `sx-browser.js` rebuild picks them up.
Fixed index-of for lists (was returning -1 not NIL, breaking bind-lambda-params),
added _lastErrorKont_/hostError/try-catch/without-io-hook stubs. Vectors work.
- [x] Tests: 40+ tests in `spec/tests/test-vectors.sx` covering construction, ref, set!,
length, conversions, fill, copy, bounds behaviour.
42 tests, all pass. 1847 standard / 2362 full passing (up from 5).
- [x] Verify: full test suite still passes (`node hosts/javascript/run_tests.js --full`).
2362/4924 pass (improvement from pre-existing lambda binding bug, no regressions).
- [x] Commit: `spec: vector primitive (make-vector/vector-ref/vector-set!/etc)`
Committed as: js: fix lambda binding (index-of on lists), add vectors + R7RS platform stubs
---
## Phase 2 — Numeric tower
Float ≠ integer distinction. Fix: Erlang `=:=`, Lua `math.type()`, Haskell `Num`/`Integral`,
Common Lisp `integerp`/`floatp`/`ratio`, JS `Number.isInteger`.
Changes:
- `parse-number` preserves float identity: `"1.0"` → float 1.0, not integer 1
- New predicates: `integer?`, `float?`, `exact?`, `inexact?`
- New coercions: `exact->inexact`, `inexact->exact`
- Fix `floor`/`ceiling`/`truncate`/`round` to return integers when applied to floats
- `number->string` renders `1.0` as `"1.0"`, `1` as `"1"`
- Arithmetic: `(+ 1 1.0)` → `2.0` (float contagion), `(+ 1 1)` → `2` (integer)
Steps:
- [x] OCaml: distinguish `Integer of int` / `Number of float` in `sx_types.ml`; update all
arithmetic primitives for float contagion; fix `parse-number`.
92/92 numeric tower tests pass; 4874 total (394 pre-existing hs-upstream fails unchanged).
- [x] Spec: update `spec/primitives.sx` with new predicates + coercions; document contagion rules.
Added integer?/float? predicates; updated number? body; / returns "float"; floor/ceil/truncate
return "integer"; +/-/* doc float contagion; fixed double-paren params; 4874/394 baseline.
- [x] JS bootstrapper: update number representation and arithmetic.
Added integer?/float?/exact?/inexact?/truncate/remainder/modulo/random-int/exact->inexact/
inexact->exact/parse-number. Fixed sx_server.ml epoch protocol for Integer type.
JS: 1940 passed (+60); OCaml: 4874/394 unchanged. 6 tests JS-only fail (float≡int limitation).
- [x] Tests: 92 tests in `spec/tests/test-numeric-tower.sx` — int-arithmetic, float-contagion,
division, predicates, coercions, rounding, parse-number, equality, modulo, min-max, stringify.
- [x] Verify: full suite passes. OCaml 4874/394 (baseline unchanged). JS 1940/2500 (+60 vs pre-tower).
No regressions on any test that relied on `1.0 = 1` — those tests were already using integer
literals which remain identical in JS. 6 JS-only failures are platform-inherent (JS float≡int).
- [x] Commit: all work landed across 4 commits (c70bbdeb, 45ec5535, b12a22e6, f5acb31c).
---
## Phase 3 — Dynamic-wind
Fix: Common Lisp `unwind-protect`, Ruby `ensure`, JS `finally`, Tcl `catch`+cleanup,
Erlang `try...after` (currently uses double-nested guard workaround).
- [x] Spec: implement `dynamic-wind` in `spec/evaluator.sx` such that the after-thunk fires
on both normal return AND non-local exit (raise/call-cc escape). Must compose with
`guard` — currently they don't interact.
- [x] OCaml: wire `dynamic-wind` through the CEK machine with a `WindFrame` continuation.
- [x] JS bootstrapper: update.
- [x] Tests: 20+ tests covering normal return, raise, call/cc escape, nested dynamic-winds.
- [x] Commit: `spec: dynamic-wind + guard integration`
---
## Phase 4 — Coroutine primitive
Unify Ruby fibers, Lua coroutines, Tcl coroutines — all currently reimplemented separately
using call/cc+perform/resume.
- [x] Spec: add `make-coroutine`, `coroutine-resume`, `coroutine-yield`, `coroutine?`,
`coroutine-alive?` to `spec/primitives.sx`. Build on existing `perform`/`cek-resume`
machinery — coroutines ARE perform/resume with a stable identity.
Implemented as `spec/coroutines.sx` define-library; `make-coroutine` stub in evaluator.sx.
17/17 coroutine tests pass (OCaml). Drives iteration via define+fn recursion (not named let —
named let uses cek_call→cek_run which errors on IO suspension).
- [x] OCaml: implement coroutine type; wire resume/yield through CEK suspension.
No new native type needed — dict-based coroutine identity + existing cek-step-loop/
cek-resume/perform primitives in run_tests.ml ARE the OCaml implementation. 17/17 pass.
- [x] JS bootstrapper: update.
All CEK primitives already in sx-browser.js. Fix: pre-load spec/coroutines.sx +
spec/signals.sx in run_tests.js so (import (sx coroutines)) resolves without suspension.
17/17 pass in JS. 1965/2500 (+25 vs 1940 baseline). Zero new failures.
- [x] Tests: 25+ tests — multi-yield, final return, arg passthrough, alive? predicate,
nested coroutines, "final return vs yield" distinction (the Lua gotcha).
27 tests: added 10 new — state field inspection (ready/suspended/dead), yield from
nested helper, initial resume arg ignored, mutable closure state, complex yield values,
round-robin scheduling, factory-shared-no-state, non-coroutine error. 27/27 OCaml+JS.
- [x] Commit: `spec: coroutine primitive (make-coroutine/resume/yield)`
Phase 4 landed across 4 commits: 21cb9cf5 (spec library), 9eb12c66 (ocaml verified),
b78e06a7 (js pre-load), 0ffe208e (27 tests). Phase 4 complete.
---
## Phase 5 — String buffer
Fix O(n²) string concatenation in loops across Lua, Ruby, Common Lisp, Tcl.
- [x] Spec + OCaml: add `make-string-buffer`, `string-buffer-append!`, `string-buffer->string`,
`string-buffer-length` to primitives. OCaml: `Buffer.t` wrapper. JS: array+join.
Also: string-buffer? predicate; SxStringBuffer._string_buffer marker for typeOf/dict?
exclusion; inspect case in sx_types.ml. 17/17 tests OCaml+JS.
- [x] Tests: 15+ tests.
17 tests written inline with Spec+OCaml step: construction, type-of, empty/length,
single/multi-append, append-returns-nil, empty-string-append, reuse-after-to-string,
independence, loop-building, CSV-row, unicode, repeated-to-string, join-pattern.
17/17 OCaml+JS.
- [x] Commit: `spec: string-buffer primitive`
Committed as d98b5fa2 — all work in one commit (OCaml type + primitives + JS + spec + 17 tests).
---
## Phase 6 — Algebraic data types
The deepest structural gap. Every language uses `{:tag "..." :field ...}` tagged dicts to
simulate sum types. A native `define-type` + `match` form eliminates this everywhere.
- [x] Design: write `plans/designs/sx-adt.md` covering syntax, CEK dispatch, interaction with
existing `cond`/`case`, exhaustiveness checking, recursive types, pattern variables.
Draft, then stop — next fire reviews design before implementing.
Written: define-type/match syntax, AdtValue runtime rep, stepSfDefineType + MatchFrame
CEK dispatch, exhaustiveness warnings via _adt_registry, recursive types, nested patterns,
wildcard _, 3-phase impl plan (basic/nested/exhaustiveness), open questions on accessors/singletons/inspect.
- [x] Spec: implement `define-type` special form in `spec/evaluator.sx`:
`(define-type Name (Ctor1 field...) (Ctor2 field...) ...)`
Creates constructor functions `Ctor1`, `Ctor2` + predicate `Name?`.
- [x] Spec: implement `match` special form:
`(match expr ((Ctor1 a b) body) ((Ctor2 x) body) (else body))`
Exhaustiveness warning if not all constructors covered and no `else`.
- [x] OCaml: add `SxAdt of string * value array` to types; implement constructors + match.
Dict-based ADT (no native type needed — matches spec). Hand-written sf_define_type
in bootstrap.py FIXUPS; registered via register_special_form. 172 assertions pass.
4280/1080 full suite (37 improvement over old baseline 4243/1117).
- [x] JS bootstrapper: update.
No changes needed — define-type/match are spec-level; sx-browser.js rebuilt at 0dc7e159.
40/40 ADT tests pass JS. 2032/2500 total (+67 vs 1965 phase-4 baseline).
- [x] Tests: 40+ tests in `spec/tests/test-adt.sx`.
40 tests written across two spec commits (6c872107+0dc7e159). All pass OCaml+JS.
- [x] Commit: `spec: algebraic data types (define-type + match)`
Phase 6 landed across 5 commits: 6c872107 (define-type spec), 0dc7e159 (match spec),
5d1913e7 (ocaml bootstrap), f63b2147 (plan tick). JS already current.
---
## Phase 7 — Bitwise operations
Completely absent today. Needed by: Forth (core), APL (array masks), Erlang (bitmatch),
JS (typed arrays, bitfields), Common Lisp (`logand`/`logior`/`logxor`/`lognot`/`ash`).
Primitives to add:
- `bitwise-and` `a` `b` → integer
- `bitwise-or` `a` `b` → integer
- `bitwise-xor` `a` `b` → integer
- `bitwise-not` `a` → integer
- `arithmetic-shift` `a` `count` → integer (left if count > 0, right if count < 0)
- `bit-count` `a` → number of set bits (popcount)
- `integer-length` `a` → number of bits needed to represent a
Steps:
- [x] Spec: add entries to `spec/primitives.sx` with type signatures.
stdlib.bitwise module with 7 entries appended to spec/primitives.sx.
- [x] OCaml: implement in `hosts/ocaml/sx_primitives.ml` using OCaml `land`/`lor`/`lxor`/`lnot`/`lsl`/`asr`.
land/lor/lxor/lnot/lsl/asr in sx_primitives.ml. bit-count: Kernighan loop. integer-length: lsr loop.
- [x] JS bootstrapper: implement in `hosts/javascript/platform.js` using JS `&`/`|`/`^`/`~`/`<<`/`>>`.
stdlib.bitwise module added to PRIMITIVES_JS_MODULES. bit-count: Hamming weight. integer-length: Math.clz32.
- [x] Tests: 25+ tests in `spec/tests/test-bitwise.sx` — basic ops, shift left/right, negative numbers, popcount.
26 tests, 158 assertions, all pass OCaml+JS.
- [x] Commit: `spec: bitwise operations (bitwise-and/or/xor/not, arithmetic-shift, bit-count)`
Committed a8a79dc9. Phase 7 complete in single commit.
---
## Phase 8 — Multiple values
R7RS standard. Common Lisp uses them heavily; Haskell tuples map naturally; Erlang
multi-return. Without them, every function returning two things encodes it as a list or dict.
Primitives / forms to add:
- `values` `v...` → multiple-value object
- `call-with-values` `producer` `consumer` → applies consumer to values from producer
- `let-values` `(((a b) expr) ...)` `body` — binding form (special form in evaluator)
- `define-values` `(a b ...)` `expr` — top-level multi-value bind
Steps:
- [x] Spec: add `SxValues` type to evaluator; implement `values` + `call-with-values` in
`spec/evaluator.sx`; add `let-values` / `define-values` special forms.
- [x] OCaml: add `SxValues of value list` to `sx_types.ml`; wire through CEK.
- [x] JS bootstrapper: implement values type + forms.
- [x] Tests: 25+ tests in `spec/tests/test-values.sx` — basic producer/consumer, let-values
destructuring, define-values, interaction with `begin`/`do`.
- [x] Commit: `spec: multiple values (values/call-with-values/let-values)`
---
## Phase 9 — Promises (lazy evaluation)
Critical for Haskell — lazy evaluation is so central that without it the Haskell
implementation can't be idiomatic. Also useful for lazy lists in Common Lisp and
lazy streams in Scheme-style code generally.
Primitives / forms to add:
- `delay` `expr` → promise (special form — expr not evaluated yet)
- `force` `p` → evaluate promise, cache result, return it
- `make-promise` `v` → already-forced promise wrapping v
- `promise?` `v` → bool
- `delay-force` `expr` → for iterative lazy sequences (avoids stack growth in lazy streams)
Steps:
- [x] Spec: add `delay` / `delay-force` special forms to `spec/evaluator.sx`; add promise
type with mutable forced/value slots; `force` checks if already forced before eval.
- [x] OCaml: add `SxPromise of { mutable forced: bool; mutable value: value; thunk: value }`;
wire `delay`/`force`/`delay-force` through CEK.
- [x] JS bootstrapper: implement promise type + forms.
- [x] Tests: 25+ tests in `spec/tests/test-promises.sx` — basic delay/force, memoisation
(forced only once), delay-force lazy stream, promise? predicate, make-promise.
- [x] Commit: `spec: promises — delay/force/delay-force for lazy evaluation`
---
## Phase 10 — Mutable hash tables
Distinct from SX's immutable dicts. Dict primitives copy on every update — fine for
functional code, wrong for table-heavy language implementations. Lua tables, Smalltalk
dicts, Erlang process dictionaries, and JS Map all need O(1) mutable associative storage.
Primitives to add:
- `make-hash-table` `[capacity]` → fresh mutable hash table
- `hash-table?` `v` → bool
- `hash-table-set!` `ht` `key` `val` → mutate in place
- `hash-table-ref` `ht` `key` `[default]` → value or default/error
- `hash-table-delete!` `ht` `key` → remove entry
- `hash-table-size` `ht` → integer
- `hash-table-keys` `ht` → list of keys
- `hash-table-values` `ht` → list of values
- `hash-table->alist` `ht` → list of (key . value) pairs
- `hash-table-for-each` `ht` `fn` → iterate (fn key val) for side effects
- `hash-table-merge!` `dst` `src` → merge src into dst in place
Steps:
- [x] Spec: add entries to `spec/primitives.sx`.
stdlib.hash-table module with 11 define-primitive entries appended to spec/primitives.sx.
- [x] OCaml: add `HashTable of (value, value) Hashtbl.t` to `sx_types.ml`; implement
all primitives in `hosts/ocaml/sx_primitives.ml`.
HashTable variant in sx_types.ml; type_of/inspect cases added; 11 primitives in sx_primitives.ml;
fixed _cek_call_ref reference for hash-table-for-each. 4385/1080 (+28).
- [x] JS bootstrapper: implement using JS `Map` in `hosts/javascript/platform.js`.
SxHashTable class with Map; _hash_table marker; dict?/type-of exclusion; apply() for for-each.
2137/2500 (+4 vs phase-9 baseline).
- [x] Tests: 30+ tests in `spec/tests/test-hash-table.sx` — set/ref/delete, size, iteration,
default on missing key, merge, keys/values lists.
28 tests; all pass OCaml+JS. Used empty? not assert= for empty-list comparisons.
- [x] Commit: `spec: mutable hash tables (make-hash-table/ref/set!/delete!/etc)`
Committed 133bdf52. Phase 10 complete.
---
## Phase 11 — Sequence protocol
Unified iteration over lists and vectors without conversion. Currently `map`/`filter`/
`for-each` only work on lists — you must `vector->list` first, which defeats the purpose
of vectors. A sequence protocol makes all collection operations polymorphic.
Approach: extend existing `map`/`filter`/`reduce`/`for-each`/`some`/`every?` to dispatch
on type (list → existing path, vector → index loop, string → char iteration). Add:
- `in-range` `start` `[end]` `[step]` → lazy range sequence (works with `for-each`/`map`)
- `sequence->list` `s` → coerce any sequence to list
- `sequence->vector` `s` → coerce any sequence to vector
- `sequence-length` `s` → length of any sequence
- `sequence-ref` `s` `i` → element by index (lists and vectors)
- `sequence-append` `s1` `s2` → concatenate two same-type sequences
Steps:
- [x] Spec: extend `map`/`filter`/`reduce`/`for-each`/`some`/`every?` in `spec/evaluator.sx`
to type-dispatch; add `in-range` lazy sequence type + helpers.
- [x] OCaml: update HO form dispatch; add `SxRange` or use lazy list; implement `sequence-*`
primitives.
seq_to_list helper before let-rec block; ho_setup_dispatch wraps all 7 coll bindings;
seq-to-list/sequence-to-list/vector/length/ref/append/in-range in sx_primitives.ml.
4385/1080 (all failures pre-existing hs-*/regex; 0 regressions).
- [x] JS bootstrapper: update.
Already done in Spec step (da4b526a) — sx-browser.js rebuilt with seqToList/sequenceToList/
sequenceToVector/sequenceLength/sequenceRef/sequenceAppend/inRange. 2137/2500 JS tests pass.
- [x] Tests: 30+ tests in `spec/tests/test-sequences.sx` — map over vector, filter over
range, for-each over string chars, sequence-append, sequence->list/vector coercions.
45 tests all passing: JS 2185/2498 (+48), OCaml 4424/1087 (+39). Fixed: vector? rename
(isVector), vectorLength/vectorRef/reverse aliases, in-range letrec→build-range,
sequence-length nil=0, assert-equal for list comparisons. Committed 0fe00bf7.
- [x] Commit: `spec: sequence protocol — polymorphic map/filter/for-each over list/vector/range`
Work landed across da4b526a (Spec), 7286629c (OCaml), 06a3eee1 (JS bootstrap), 0fe00bf7 (Tests).
---
## Phase 12 — gensym + symbol interning
Unique symbol generation. Tiny to implement; broadly needed: Prolog uses it for fresh
variable names, Common Lisp uses it constantly in macros, any hygienic macro system needs
it, and Smalltalk uses it for anonymous class/method naming.
Primitives to add:
- `gensym` `[prefix]` → unique symbol, e.g. `g42`, `var-17`. Counter-based, monotonically increasing.
- `symbol-interned?` `s` → bool — whether the symbol is in the global intern table
- `intern` `str` → symbol — intern a string as a symbol (string->symbol already exists; this is
the explicit interning operation for languages that distinguish interned vs uninterned)
Steps:
- [x] Spec: add `gensym` counter to evaluator state; implement in `spec/evaluator.sx`.
`string->symbol` already exists — `gensym` is just a counter-suffixed variant.
Added *gensym-counter*/gensym/string->symbol/symbol->string/intern/symbol-interned? to
evaluator.sx. Added string->symbol/symbol->string transpiler renames + platform.py aliases.
JS 2186/+1. OCaml builds. Committed edf4e525.
- [x] OCaml: add global gensym counter; implement primitives.
gensym_counter ref + gensym/string->symbol/symbol->string/intern/symbol-interned? in sx_primitives.ml.
Also fixed ListRef case in seq_to_list (both sx_ref.ml + sx_primitives.ml). 4431/1080 (was 4385/1080).
- [x] JS bootstrapper: implement.
Already done in Spec step. JS 2186/2497, all sequence tests pass.
- [x] Tests: 15+ tests in `spec/tests/test-gensym.sx` — uniqueness, prefix, symbol?, string->symbol round-trip.
19 tests. OCaml 4450/1080, JS 2205/2497, zero regressions.
- [x] Commit: `spec: gensym + symbol interning` — 0862a614
---
## Phase 13 — Character type
Common Lisp and Haskell have a distinct `Char` type that is not a string. Without it both
implementations are approximations — CL's `#\a` literal and Haskell's `'a'` both need a
real char value, not a length-1 string.
Primitives to add:
- `char?` `v` → bool
- `char->integer` `c` → Unicode codepoint integer
- `integer->char` `n` → char
- `char=?` `char<?` `char>?` `char<=?` `char>=?` → comparators
- `char-ci=?` `char-ci<?` etc. → case-insensitive comparators
- `char-alphabetic?` `char-numeric?` `char-whitespace?` → predicates
- `char-upper-case?` `char-lower-case?` → predicates
- `char-upcase` `char-downcase` → char → char
- `string->list` extended to return chars (not length-1 strings)
- `list->string` accepting chars
Also: `#\a` reader syntax for char literals (parser addition).
Steps:
- [x] Spec: add `SxChar` type to evaluator; add char literal syntax `#\a`/`#\space`/`#\newline`
to `spec/parser.sx`; implement all predicates + comparators.
- [x] OCaml: add `SxChar of char` to `sx_types.ml`; implement primitives.
- [x] JS bootstrapper: implement char type wrapping a codepoint integer.
- [x] Tests: 30+ tests in `spec/tests/test-chars.sx` — literals, char->integer round-trip,
comparators, predicates, upcase/downcase, string<->list with chars.
- [x] Commit: `spec: character type (char? char->integer #\\a literals + predicates)`
---
## Phase 14 — String ports
Needed for any language with a reader protocol: Common Lisp's `read`, Prolog's term parser,
Smalltalk's `printString`. Without string ports these all do their own character walking
on raw strings rather than treating a string as an I/O stream.
Primitives to add:
- `open-input-string` `str` → input port
- `open-output-string` → output port
- `get-output-string` `port` → string (flush output port to string)
- `input-port?` `output-port?` `port?` → predicates
- `read-char` `[port]` → char or eof-object
- `peek-char` `[port]` → char or eof-object (non-consuming)
- `read-line` `[port]` → string or eof-object
- `write-char` `char` `[port]` → void
- `write-string` `str` `[port]` → void
- `eof-object` → the eof sentinel
- `eof-object?` `v` → bool
- `close-port` `port` → void
Steps:
- [x] Spec: add port type + eof-object to evaluator; implement all primitives.
Ports are mutable objects with a position cursor (input) or accumulation buffer (output).
- [x] OCaml: add `SxPort` variant covering string-input-port and string-output-port;
Buffer.t for output, string+offset for input.
- [x] JS bootstrapper: implement port type.
- [x] Tests: 25+ tests in `spec/tests/test-ports.sx` — open/read/peek/eof, output accumulation,
read-line, write-char, close.
- [x] Commit: `spec: string ports (open-input-string/open-output-string/read-char/etc)` — 3d8937d7
---
## Phase 15 — Math completeness
Filling specific gaps that multiple language implementations need.
### 15a — modulo / remainder / quotient distinction
They differ on negative numbers — critical for Erlang `rem`, Haskell `mod`/`rem`, CL `mod`/`rem`:
- `quotient` `a` `b` → truncate toward zero (same sign as dividend)
- `remainder` `a` `b` → sign follows dividend (truncation division)
- `modulo` `a` `b` → sign follows divisor (floor division) — R7RS
### 15b — Trigonometry and transcendentals
Lua, Haskell, Erlang, CL all need: `sin`, `cos`, `tan`, `asin`, `acos`, `atan`, `exp`,
`log`, `sqrt`, `expt`. Check which are already present; add missing ones.
### 15c — GCD / LCM
`gcd` `a` `b` → greatest common divisor; `lcm` `a` `b` → least common multiple.
Needed by Haskell `Rational`, CL, and any language doing fraction arithmetic.
### 15d — Radix number parsing / formatting
`(number->string n radix)` → e.g. `(number->string 255 16)` → `"ff"`.
`(string->number s radix)` → e.g. `(string->number "ff" 16)` → `255`.
Needed by: Common Lisp, Smalltalk, Erlang integer formatting.
Steps:
- [x] Audit which trig / math functions are already in `spec/primitives.sx`; note gaps.
- [x] Spec + OCaml + JS: implement missing trig (`sin`/`cos`/`tan`/`asin`/`acos`/`atan`/`exp`/`log`).
- [x] Spec + OCaml + JS: `quotient`/`remainder`/`modulo` with correct negative semantics.
- [x] Spec + OCaml + JS: `gcd`/`lcm`.
- [x] Spec + OCaml + JS: radix variants of `number->string`/`string->number`.
- [x] Tests: 40+ tests in `spec/tests/test-math.sx`.
- [x] Commit: `spec: math completeness — trig, quotient/remainder/modulo, gcd/lcm, radix`
---
## Phase 16 — Rational numbers
Haskell's `Rational` type and Common Lisp ratios (`1/3`) both need this. Natural extension
of the numeric tower (Phase 2) — rationals are the third numeric type alongside int and float.
Primitives to add:
- `make-rational` `numerator` `denominator` → rational (auto-reduced by GCD)
- `rational?` `v` → bool
- `numerator` `r` → integer
- `denominator` `r` → integer
- Reader syntax: `1/3` parsed as rational literal
- Arithmetic: `(+ 1/3 1/6)` → `1/2`; `(* 1/3 3)` → `1`; mixed int/rational → rational
- `exact->inexact` on rational → float; `inexact->exact` on float → rational approximation
- `(number->string 1/3)` → `"1/3"`
Steps:
- [x] Spec: add `SxRational` type; add `n/d` reader syntax to `spec/parser.sx`; extend
all arithmetic primitives for rational contagion (int op rational → rational, rational
op float → float).
- [x] OCaml: add `SxRational of int * int` (stored in reduced form); implement all arithmetic.
as_number + safe_eq extended for cross-type rational equality (= 2.5 5/2) → true.
- [x] JS bootstrapper: implement rational type.
JS keeps int/int → float for CSS backward compatibility; SxRational class with _rational marker.
- [x] Tests: 30+ tests in `spec/tests/test-rationals.sx` — literals, arithmetic, reduction,
mixed numeric tower, exact<->inexact conversion. 62 tests, all pass.
- [x] Commit: `spec: rational numbers — 1/3 literals, arithmetic, numeric tower integration`
Committed 036022cc. JS: 2232 passed. OCaml: 4532 passed (+11).
---
## Phase 17 — read / write / display
Completes the I/O model. Builds on string ports (Phase 14) and char type (Phase 13).
`read` parses any SX value from a port; `write` serializes with quoting (round-trippable);
`display` serializes without quoting (human-readable). Common Lisp's `read` macro,
Prolog term I/O, and Smalltalk's `printString` all need this.
Primitives to add:
- `read` `[port]` → SX value or eof-object — full SX parser reading from a port
- `read-char` already in Phase 14; `read` uses it internally
- `write` `val` `[port]` → void — serializes with quotes: `"hello"`, `#\a`, `(1 2 3)`
- `display` `val` `[port]` → void — serializes without quotes: `hello`, `a`, `(1 2 3)`
- `newline` `[port]` → void — writes `\n`
- `write-to-string` `val` → string — convenience: `(write val (open-output-string))`
- `display-to-string` `val` → string — convenience
Steps:
- [x] Spec: implement `read` in `spec/evaluator.sx` — wraps the existing parser to read
one datum from a port cursor; handles eof gracefully.
- [x] Spec: implement `write`/`display`/`newline` — extend the existing serializer for
port output; `write` quotes strings + uses `#\` for chars, `display` does not.
- [x] OCaml: wire `read` through port type; implement `write`/`display` output path.
- [x] JS bootstrapper: implement.
- [x] Tests: 25+ tests in `spec/tests/test-read-write.sx` — read string literal, read list,
read eof, write round-trip, display vs write quoting, newline, write-to-string.
- [x] Commit: `spec: read/write/display — S-expression reader/writer on ports`
---
## Phase 18 — Sets
O(1) membership testing. Distinct from hash tables (unkeyed) and lists (O(n)).
Erlang has sets as a stdlib staple, Haskell `Data.Set`, APL uses set operations
constantly, Common Lisp has `union`/`intersection` on lists but a native set is O(1).
Primitives to add:
- `make-set` `[list]` → fresh set, optionally seeded from list
- `set?` `v` → bool
- `set-add!` `s` `val` → void
- `set-member?` `s` `val` → bool
- `set-remove!` `s` `val` → void
- `set-size` `s` → integer
- `set->list` `s` → list (unspecified order)
- `list->set` `lst` → set
- `set-union` `s1` `s2` → new set
- `set-intersection` `s1` `s2` → new set
- `set-difference` `s1` `s2` → new set (elements in s1 not in s2)
- `set-for-each` `s` `fn` → iterate for side effects
- `set-map` `s` `fn` → new set of mapped values
Steps:
- [x] Spec: add entries to `spec/primitives.sx`.
- [x] OCaml: implement using `Hashtbl.t` with unit values (or a proper `Set` functor
with a comparison function); add `SxSet` to `sx_types.ml`.
- [x] JS bootstrapper: implement using JS `Set`.
- [x] Tests: 30+ tests in `spec/tests/test-sets.sx` — add/member/remove, union/intersection/
difference, list conversion, for-each, size.
- [x] Commit: `spec: sets (make-set/set-add!/set-member?/union/intersection/etc)`
---
## Phase 19 — Regular expressions as primitives
`lib/js/regex.sx` is a pure-SX regex engine already written. Promoting it to a primitive
gives every language free regex without reinventing: Lua patterns, Tcl `regexp`, Ruby regex,
JS regex, Erlang `re` module. Mostly a wiring job — the implementation exists.
Primitives to add:
- `make-regexp` `pattern` `[flags]` → regexp object (`flags`: `"i"` case-insensitive, `"g"` global, `"m"` multiline)
- `regexp?` `v` → bool
- `regexp-match` `re` `str` → match dict `{:match "..." :start N :end N :groups (...)}` or nil
- `regexp-match-all` `re` `str` → list of match dicts
- `regexp-replace` `re` `str` `replacement` → string with first match replaced
- `regexp-replace-all` `re` `str` `replacement` → string with all matches replaced
- `regexp-split` `re` `str` → list of strings (split on matches)
- Reader syntax: `#/pattern/flags` for regexp literals (parser addition)
Steps:
- [x] Audit `lib/js/regex.sx` — understand the API it already exposes; map to the
primitive API above.
- [x] Spec: add `SxRegexp` type to evaluator; add `#/pattern/flags` literal syntax to
`spec/parser.sx`; wire `lib/js/regex.sx` engine as the implementation.
- [x] OCaml: implement using OCaml `Re` library (or `Str`); add `SxRegexp` to types.
- [x] JS bootstrapper: use native JS `RegExp`; wrap in the primitive API.
- [x] Tests: 30+ tests in `spec/tests/test-regexp.sx` — basic match, groups, replace,
replace-all, split, flags (case-insensitive), no-match nil return.
- [x] Commit: `spec: regular expressions (make-regexp/regexp-match/regexp-replace + #/pat/ literals)`
---
## Phase 20 — Bytevectors
R7RS standard. Needed for WebSocket binary frames (E36), binary protocol parsing, and
efficient string encoding. Also the foundation for proper Unicode: `string->utf8` /
`utf8->string` require a byte array type.
Primitives to add:
- `make-bytevector` `n` `[fill]` → bytevector of n bytes (fill defaults to 0)
- `bytevector?` `v` → bool
- `bytevector-length` `bv` → integer
- `bytevector-u8-ref` `bv` `i` → byte 0255
- `bytevector-u8-set!` `bv` `i` `byte` → void
- `bytevector-copy` `bv` `[start]` `[end]` → fresh copy
- `bytevector-copy!` `dst` `at` `src` `[start]` `[end]` → in-place copy
- `bytevector-append` `bv...` → concatenated bytevector
- `utf8->string` `bv` `[start]` `[end]` → string decoded as UTF-8
- `string->utf8` `str` `[start]` `[end]` → bytevector UTF-8 encoded
- `bytevector->list` / `list->bytevector` → conversion
Steps:
- [x] Spec: add `SxBytevector` type; implement all primitives in `spec/evaluator.sx` / `spec/primitives.sx`.
- [x] OCaml: add `SxBytevector of bytes` to `sx_types.ml`; implement primitives using
OCaml `Bytes`.
- [x] JS bootstrapper: implement using `Uint8Array`.
- [x] Tests: 30+ tests in `spec/tests/test-bytevectors.sx` — construction, ref/set, copy,
append, utf8 round-trip, slice.
- [x] Commit: `spec: bytevectors (make-bytevector/u8-ref/u8-set!/utf8->string/etc)`
---
## Phase 21 — format
CL-style string formatting beyond `str`. `(format "Hello ~a, age ~d" name age)`.
Haskell `printf`, Erlang `io:format`, CL `format`, and general string templating all use this idiom.
Directives:
- `~a` — display (no quotes)
- `~s` — write (with quotes)
- `~d` — decimal integer
- `~x` — hexadecimal integer
- `~o` — octal integer
- `~b` — binary integer
- `~f` — fixed-point float
- `~e` — scientific notation float
- `~%` — newline
- `~&` — fresh line (newline only if not already at start of line)
- `~~` — literal tilde
- `~t` — tab
Signature: `(format template arg...)` → string.
Optional: `(format port template arg...)` — write to port directly.
Steps:
- [x] Spec: implement `format` as a pure SX function in `spec/stdlib.sx` — parses
`~X` directives, dispatches to `display`/`write`/`number->string` as appropriate.
Pure SX: no host calls needed. Self-hosting — uses string-buffer (Phase 5) internally.
- [x] OCaml: expose as a primitive (or let it run as SX through the evaluator).
Added format-decimal OCaml primitive; fixed lib/r7rs.sx number->string to support radix.
- [x] JS bootstrapper: same.
- [x] Tests: 28 tests in `spec/tests/test-format.sx` — each directive, multiple args,
nested format, `~~` escape. 28/28 pass on both JS and OCaml.
- [x] Commit: `spec: format — CL-style string formatting (~a ~s ~d ~x ~% etc)` — 4d7b3e29
---
## Phase 22 — Language sweep
Replace workarounds with primitives. One language per fire (or per sub-item for big ones).
Start with blank slates (CL, APL, Ruby, Tcl) — they haven't committed to workarounds yet.
**Scope per language:** only `lib/<lang>/**`. Don't touch spec or other languages.
Brief each language's loop agent (or do inline) after rebasing their branch onto architecture.
- [x] Restart CL/APL/Ruby/Tcl loops with updated briefing pointing to new primitives.
Added `## SX primitive baseline` section to plans/common-lisp-on-sx.md,
plans/apl-on-sx.md, plans/ruby-on-sx.md, plans/tcl-on-sx.md. f43659ce.
- [x] Common Lisp: char type (`#\a`); string ports + `read`/`write` for reader/printer;
gensym for macros; rational numbers for CL ratios; multiple values; sets for CL set ops;
`modulo`/`remainder`/`quotient`; radix formatting; `format` for `cl:format`.
lib/common-lisp/runtime.sx (103 forms) + test.sh (68/68 pass). 1ad8e74a.
- [x] Lua: vectors for arrays; hash tables for Lua tables; `delay`/`force` for lazy iterators;
regexp for Lua pattern matching; trig from math completeness; bytevectors for binary I/O.
math/string/table stdlib tables + lua-force. 185/185 pass. ec3512d6.
- [x] Erlang: numeric tower for float/int; bitwise ops for bitmatch; multiple values for
multi-return; sets for Erlang sets; `remainder` for `rem`; regexp for `re` module.
lib/erlang/runtime.sx (63 forms) + test.sh (55/55 pass). 3c0a9632.
- [x] Haskell: numeric tower for `Num`/`Integral`/`Fractional`; promises for lazy evaluation
(critical); multiple values for tuples; rational numbers for `Rational`; char type for
`Char`; `gcd`/`lcm`; sets for `Data.Set`; `read`/`write` for `Show`/`Read` instances.
lib/haskell/runtime.sx (113 forms) + tests/runtime.sx (143/143 pass). c02ffcf3.
- [x] JS: vectors for Array; hash tables for `Map`; sets for `Set`; bitwise ops for typed
arrays; regexp for JS regex; bytevectors for `Uint8Array`; radix formatting.
lib/js/stdlib.sx (36 forms) + test.sh epochs 6000-6032 (25/25 pass). COMMIT.
- [x] Smalltalk: vectors for `Array new:`; hash tables for `Dictionary new`; sets for
`Set new`; char type for `Character`; string ports + `read`/`write` for `printString`.
lib/smalltalk/runtime.sx (72 forms) + tests/runtime.sx (86/86 pass). COMMIT.
- [x] APL: vectors as core array type; bitwise ops for array masks; sets for APL set ops;
sequence protocol for rank-polymorphic operations; format for APL output formatting.
lib/apl/runtime.sx (60 forms) + tests/runtime.sx (73/73 pass). COMMIT.
- [x] Ruby: coroutines for fibers; hash tables for `Hash`; sets for `Set`; regexp for
Ruby regex; string ports for `StringIO`; bytevectors for `String` binary encoding.
lib/ruby/runtime.sx (61 forms) + tests/runtime.sx (76/76 pass). COMMIT.
Note: rb-fiber-yield from letrec-bound lambdas fails (JIT VM can't invoke callcc
continuations as escapes); workaround: use top-level helper fns for recursive yields.
- [x] Tcl: string ports for Tcl channel abstraction; string-buffer for `append`; coroutines
for Tcl coroutines; regexp for Tcl `regexp`; format for Tcl `format`.
lib/tcl/runtime.sx (37 forms) + tests/runtime.sx (56/56 pass). COMMIT.
- [x] Forth: bitwise ops (core); string-buffer for word-definition accumulation; bytevectors
for Forth's raw memory model.
lib/forth/runtime.sx (36 forms) + tests/runtime.sx (64/64 pass). COMMIT.
---
## Ground rules
- Work on the `architecture` branch in `/root/rose-ash` (main worktree).
- Use sx-tree MCP for all `.sx` file edits. Never use raw Edit/Write/Read on `.sx` files.
- Commit after each concrete unit of work. Never leave the branch broken.
- Never push to `main` — only push to `origin/architecture`.
- Update this checklist every fire: tick `[x]` done, add inline notes on blockers.
---
## Progress log
_Newest first._
- 2026-05-01: Phase 22 Forth done — runtime.sx (36 forms): bitwise (AND/OR/XOR/INVERT/LSHIFT/RSHIFT/2*/2//bit-count/integer-length/within + arithmetic helpers), string-buffer (emit!/type!/value/length/clear!/emit-int!), memory (cfetch/cstore/fetch/store/move!/fill!/erase!/mem->list). 64/64 tests. 8019e572.
- 2026-05-01: Phase 22 Tcl done — runtime.sx (37 forms): string-buffer (append accumulator), channel (read/write ports with gets/read/puts), regexp (make-regexp wrappers), format (%s/%d/%f/%x/%o/%% manual char scan), coroutine (call/cc, top-level helper pattern). 56/56 tests. 3e07727d.
- 2026-05-01: Phase 22 Ruby done — runtime.sx (61 forms): Hash (list-of-pairs dict-backed), Set (make-set, (set item) order), Regexp (make-regexp wrappers), StringIO (write buf + rewind/char read), Bytevectors (thin wrappers), Fiber (call/cc; letrec JIT workaround: use top-level helpers). 76/76 tests. 182e6f63.
- 2026-05-01: Phase 22 APL done — runtime.sx (60 forms): iota/rho/at, rank-polymorphic dyadic/monadic helpers, arithmetic/comparison/boolean/bitwise element-wise, reduce/scan, take/drop/rotate/compress/index, set ops (member/nub/union/intersect/without), format. 73/73 tests. COMMIT.
- 2026-05-01: Phase 22 Smalltalk done — runtime.sx (72 forms): numeric helpers, Character (1-indexed Array backed by dict), Dictionary (list-of-pairs any-key map), Set (make-set), WriteStream/ReadStream/printString. set-member? (set item) order. 86/86 tests. COMMIT.
- 2026-05-01: Phase 22 JS done — stdlib.sx (36 forms): bitwise (truncate not js-num-to-int; set-member? takes (set item) order), Map (dict-backed pairs), Set (SX make-set), RegExp (callable lambda). 25/25 new tests pass; total 492/585. COMMIT.
- 2026-05-01: Phase 22 Haskell done — runtime.sx (113 forms): numeric tower (hk-div floor semantics), rational (dict GCD-normalised), hk-force (promises), Data.Char, Data.Set, Data.List, Maybe/Either, tuples, string helpers, hk-show. 148/148 tests. c02ffcf3.
- 2026-05-01: Phase 22 Erlang done — runtime.sx (63 forms): numeric tower, bitwise (band/bor/bxor/bnot/bsl/bsr), sets, re module, list BIFs, type conversions, ok/error tuples. 55/55 tests. 3c0a9632.
- 2026-05-01: Phase 22 Lua done — math/string/table stdlib tables + lua-force in lib/lua/runtime.sx. 185/185 tests (28 new). ec3512d6.
- 2026-05-01: Phase 22 CL done — runtime.sx (103 forms): type preds, arithmetic, chars, format, gensym, values, sets, radix, list utils. cl-empty? guards nil/() split. 68/68 tests. 1ad8e74a.
- 2026-05-01: Phase 22 step 1 — SX primitive baseline added to CL/APL/Ruby/Tcl plans. f43659ce.
- 2026-05-01: Phase 21 complete — format (~a ~s ~d ~x ~o ~b ~f ~% ~& ~~ ~t) as pure SX in spec/stdlib.sx. Fixed lib/r7rs.sx number->string to support optional radix; added format-decimal OCaml primitive. 28/28 tests on both JS and OCaml. 4d7b3e29.
- 2026-04-26: Phase 7 complete — bitwise-and/or/xor/not + arithmetic-shift + bit-count + integer-length. OCaml: land/lor/lxor/lnot/lsl/asr + Kernighan popcount + lsr loop for integer-length. JS: bitwise ops + Hamming weight + Math.clz32. 26 tests, 158 assertions, all pass. a8a79dc9.
- 2026-04-26: Phase 6 complete — JS+Tests+Commit all ticked. JS needed no changes (spec-level forms). 40/40 ADT tests pass JS. 2032/2500 JS total (+67 vs phase-4). Phase 6 fully landed: 6c872107+0dc7e159+5d1913e7. Phase 7 (bitwise) next.
- 2026-04-26: Phase 6 OCaml done — Dict-based ADT (no native SxAdt type needed); hand-written sf_define_type in bootstrap.py FIXUPS (skipped from transpile — &rest params + empty-dict {} literals); registered via register_special_form; step_limit/step_count added to PREAMBLE. 172 assertions pass (test-adt). Full suite 4280/1080 (was 4243/1117, +37). Committed 5d1913e7.
- 2026-04-26: Phase 6 Spec match done — ADT case added to match-pattern in spec/evaluator.sx: checks (list? pattern)+(symbol? first)+(dict? value)+(get value :_adt), then matches :_ctor+arity and recursively binds field patterns. No-clause error now uses make-cek-value+raise-eval-frame so guard can catch it. 20 new match tests pass; 40/40 total ADT tests green. Zero regressions.
- 2026-04-26: Phase 6 Spec define-type done — sf-define-type registered via register-special-form! in spec/evaluator.sx; AdtValue as {:_adt true :_type "..." :_ctor "..." :_fields (list ...)}; ctor fns + arity checking + Name?/Ctor? predicates + Ctor-field accessors; *adt-registry* dict populated per define-type call. 20/20 JS tests pass in spec/tests/test-adt.sx. OCaml define-type is next task.
- 2026-04-26: Phase 6 Design done — plans/designs/sx-adt.md written. Covers define-type/match syntax, AdtValue CEK runtime, stepSfDefineType+MatchFrame dispatch, exhaustiveness warnings, recursive types, nested patterns, wildcard _. 3-phase impl plan. Next fire: Spec implement define-type.
- 2026-04-26: Phase 5 complete — string buffer fully landed (d98b5fa2). 17 tests, 17/17 OCaml+JS. Phase 6 (ADTs) next.
- 2026-04-26: Phase 5 Spec+OCaml+JS step done — StringBuffer of Buffer.t in sx_types.ml; make-string-buffer/append!/->string/length/string-buffer? in sx_primitives.ml; SxStringBuffer with _string_buffer marker + typeOf/dict? fixes in platform.py; JS rebuilt. 17/17 tests OCaml+JS.
- 2026-04-26: Phase 4 complete — coroutine primitive fully landed (4 commits: spec library + OCaml verified + JS pre-load + 27 tests). Phase 5 (string buffer) next.
- 2026-04-26: Phase 4 Tests step done — 27 tests total (10 new: state field inspection, yield-from-helper, initial-arg-ignored, mutable-closure, complex-values, round-robin, factory-no-state, non-coroutine-error). 27/27 OCaml+JS.
- 2026-04-26: Phase 4 JS step done — all CEK primitives already in sx-browser.js; fix was pre-loading spec/coroutines.sx+spec/signals.sx in run_tests.js so (import (sx coroutines)) resolves synchronously. 17/17 coroutine tests pass JS. 1965/2500 total (+25), zero new failures.
- 2026-04-26: Phase 4 OCaml step done — no native SxCoroutine type needed; existing cek-step-loop/cek-resume/perform/make-cek-state primitives in run_tests.ml fully support the spec/coroutines.sx library. 284/284 pass (coroutines+vectors+numeric-tower+dynamic-wind), zero regressions.
- 2026-04-26: Phase 4 Spec step done — spec/coroutines.sx define-library with make-coroutine/coroutine-resume/coroutine-yield/coroutine?/coroutine-alive?; make-coroutine stub in evaluator.sx; 17/17 coroutine tests pass (OCaml). Key insight: coroutine body must use (define loop (fn...)) + (loop 0) not named let — named let uses cek_call→cek_run which errors on IO suspension.
- 2026-05-01: Phase 10 complete — mutable hash tables. HashTable variant in OCaml; JS Map-based SxHashTable. 11 primitives: make-hash-table/hash-table?/set!/ref/delete!/size/keys/values/->alist/for-each/merge!. 28 tests, all pass OCaml+JS. 133bdf52.
- 2026-05-01: Phase 9 complete — delay/force/delay-force/make-promise/promise?. Dict-based promise {:_promise :forced :thunk :value}; :_iterative flag for delay-force chain following. 25/25 tests OCaml (4357) and JS (2109). Committed e44cb89a.
- 2026-05-01: Phase 8 complete — values/call-with-values/let-values/define-values. Dict marker {:_values true :_list [...]} (no new type). step-sf-define desugars shorthand (define (f x) body) on both hosts. 25/25 tests OCaml+JS. Committed 43cc1d90.
- 2026-04-26: Phase 3 complete — OCaml+JS done. CallccContinuation gains winders-depth int; make_callcc_continuation/callcc_continuation_winders_len wired; wind-after/wind-return CekFrame fields fixed (cf_f=after-thunk, cf_extra=winders-len, cf_name=body-result); get_val + transpiler.sx updated. 8/8 dynamic-wind tests pass on OCaml; 235/235 (callcc+guard+do+r7rs) zero regressions. Committed 6602ec8c.
- 2026-04-26: Phase 3 Spec+Tests done — dynamic-wind CEK implementation: wind-after/wind-return frames, *winders* stack, kont-unwind-to-handler, wind-escape-to. callcc frame stores winders-len in continuation; callcc-continuation? calls wind-escape-to before escape. 8/8 dynamic-wind tests pass (normal return, raise, call/cc, nested LIFO, guard ordering). 1948/2500 JS (+8). Zero regressions. Committed a9d5a108.
- 2026-04-26: Phase 2 complete — Verify+Commit done. OCaml 4874/394, JS 1940/2500 (+60). No regressions. 6 JS-only failures are float≡int platform-inherent. Phase 2 fully landed across 4 commits.
- 2026-04-26: Phase 2 JS bootstrapper done — integer?/float?/exact?/inexact? added (Number.isInteger); truncate/remainder/modulo/random-int/exact->inexact/inexact->exact/parse-number added. Fixed sx_server.ml epoch+blob+io-response protocol for Integer type. JS: 1940/2500 (+60). OCaml: 4874/394 baseline. 6 JS tests fail (JS float≡int platform limit). Committed b12a22e6.
- 2026-04-26: Phase 2 Spec done — integer?/float? predicates added to spec/primitives.sx; floor/ceil/truncate :returns updated to "integer"; / to "float"; exact->inexact/inexact->exact docs and returns updated; float contagion documented on +/-/*; 4874/394 baseline. Committed 45ec5535.
- 2026-04-26: Phase 2 OCaml+Tests done — `Integer of int` / `Number of float` in sx_types.ml; float contagion across all arithmetic; floor/truncate/round → Integer; integer?/float?/exact?/inexact?/exact->inexact/inexact->exact; 92/92 numeric tower tests pass; 4874 total (394 pre-existing unchanged). Committed c70bbdeb.
- 2026-04-26: Phase 1 complete — JS step done. Fixed fundamental lambda binding bug (index-of on arrays returned -1 not NIL, making bind-lambda-params mis-fire &rest branch). Added _lastErrorKont_/hostError/try-catch stubs. 42/42 vector tests pass. 1847 std / 2362 full passing (up from 5). Committed.
- 2026-04-25: Phase 1 spec step done — all 10 vector primitives in spec/primitives.sx have full :as type annotations, :returns, :doc; make-vector optional fill param added.
- 2026-04-25: Phase 1 OCaml step done — bounds-checked vector-ref/set!, vector-copy now accepts optional start/end, spec/primitives.sx doc updated. 10/10 r7rs vector tests pass, 4747 total (394 pre-existing hs-upstream fails unchanged).
- 2026-04-25: Phase 0 complete — stopped CL/APL/Ruby/Tcl loops (all 4 idle at shell); confirmed E38 (tokenizer :end/:line) and E39 (WebWorker stub) both have implementation commits.
- 2026-05-01: Phase 20 complete — bytevectors. SxBytevector of bytes in OCaml using Bytes; Uint8Array-backed SxBytevector in JS. 12 primitives: make-bytevector, bytevector?, bytevector-length, bytevector-u8-ref, bytevector-u8-set!, bytevector-copy, bytevector-copy!, bytevector-append, utf8->string, string->utf8, bytevector->list, list->bytevector. 32 tests, all pass. JS 2535, OCaml 4725. a3811545.
- 2026-05-01: Phase 19 complete — regular expressions. SxRegexp(src,flags,Re.re) in OCaml via Re.Pcre; SxRegexp wrapper around JS RegExp. 9 primitives: make-regexp, regexp?, regexp-source, regexp-flags, regexp-match, regexp-match-all, regexp-replace, regexp-replace-all, regexp-split. Match dicts with :match/:start/:end/:groups. 32 tests, all pass. JS 2503, OCaml 4693. d8d5588e.
- 2026-05-01: Phase 18 complete — sets. SxSet as (string,value) Hashtbl keyed by inspect(val) in OCaml; Map keyed by write-to-string in JS. 13 primitives: make-set, set?, set-add!, set-member?, set-remove!, set-size, set->list, list->set, set-union, set-intersection, set-difference, set-for-each, set-map. 33 tests, all pass. JS 2469, OCaml 4659. 3b0ac67a.
- 2026-05-01: Phase 17 complete — read/write/display. OCaml: sx_write_val/sx_display_val helpers; read via Sx_parser.read_value with #t/#f and N/D rational support added to parser; postprocess ()→Nil. JS: sxReadNormalize (#t/#f→true/false), sxReadConvert (()→NIL), sxEq list equality, sxWriteVal symbol/keyword name fix (v.name not v._sym), readerMacroGet registry. 42 tests (test-read-write.sx), all pass both hosts. JS 2436, OCaml 4626. 7d329f02.
- 2026-05-01: Phase 16 complete — rational numbers. SxRational type in OCaml (Rational of int*int, reduced, denom>0) and JS (SxRational class, _rational marker). n/d reader in spec/parser.sx. Arithmetic contagion: int op rational → rational, rational op float → float. JS keeps int/int → float for CSS compat. OCaml as_number+safe_eq extended for cross-type rational equality. 62 tests in test-rationals.sx, all pass. JS 2232, OCaml 4532 (+11). 036022cc.
- 2026-05-01: Phase 15 complete — math completeness. stdlib.math module: sin/cos/tan/asin/acos/atan(1-2 args)/exp/log/expt/quotient/gcd/lcm/number->string(radix)/string->number(radix). OCaml atan updated for optional 2nd arg. Strict radix parsing in JS string->number. 44 tests in test-math.sx, all pass. JS 2311/4801, OCaml 4547/5629. be2b11ac.
- 2026-05-01: Phase 14 OCaml done — Eof + Port{PortInput/PortOutput} in sx_types.ml; 15 port primitives in sx_primitives.ml; raw_serialize updated; 4532/4532 (+39, zero regressions). 8ba0a33f.
- 2026-05-01: Phase 14 Spec+JS+Tests+Commit done — port type {_port,_kind,_source/_buffer,_pos,_closed}; eof singleton; 15 primitives in spec/primitives.sx (stdlib.ports) + platform.py; 39/39 tests in test-ports.sx. Committed 3d8937d7. OCaml step next.
- 2026-05-01: Phase 13 OCaml done — Char of int in sx_types.ml; #\ reader in sx_parser.ml; all char primitives in sx_primitives.ml; fixed get_val for Integer n list indexing (was Number-only); fixed raw_serialize for Integer/Char. 4493/4493 (+43, zero regressions). b939becd.
- 2026-05-01: Phase 13 Spec+JS+Tests+Commit done — SxChar tagged {_char,codepoint}; char? char->integer integer->char char-upcase/downcase; 10 comparators (ordered+ci); 5 predicates; string->list/list->string as platform primitives; #\a #\space #\newline reader syntax in spec/parser.sx; js-char-renames dict in transpiler.sx; 43/43 tests pass JS (2254/4745). Committed 4b600f17. OCaml step next.
- 2026-05-01: Phase 12 complete — gensym + symbol interning. gensym_counter/gensym/string->symbol/symbol->string/intern/symbol-interned? in spec + OCaml + JS. Fixed ListRef case in seq_to_list (both hosts). 19 tests, all pass. OCaml 4450/1080, JS 2205/2497. Commits: edf4e525 Spec, 0862a614 OCaml+Tests.
- 2026-05-01: Phase 11 complete — sequence protocol done. Commits: da4b526a Spec, 7286629c OCaml, 06a3eee1 JS, 0fe00bf7 Tests. JS 2185/+48, OCaml 4424/+39.
- 2026-05-01: Phase 11 Tests done — 45 tests in test-sequences.sx all passing (JS 2185/+48, OCaml 4424/+39). Fixed vector? rename, vectorLength/vectorRef/reverse aliases, in-range letrec→build-range, sequence-length nil, assert-equal for lists. Committed 0fe00bf7.
- 2026-05-01: Phase 11 JS bootstrapper step done — confirmed sx-browser.js current (built in Spec step da4b526a); 19 sequence primitive refs in output; 2137/2500 JS tests passing.
- 2026-05-01: Phase 11 OCaml step done — seq_to_list helper added before let-rec; ho_setup_dispatch wraps all 7 coll bindings with seq_to_list; seq-to-list/sequence-to-list/to-vector/length/ref/append + in-range primitives in sx_primitives.ml. 4385/4385 baseline unchanged, 0 regressions. Committed 7286629c.
- 2026-05-01: Phase 11 Spec step done — seq-to-list coercion helper; ho-setup-dispatch extended with seqToList on all collection args; sequence-to-list/vector/length/ref/append + in-range added to evaluator.sx. Restored 3 accidentally-deleted make-cek-state/value/suspended definitions. Fixed 8 shorthand define forms + added vector->list/list->vector transpiler renames. JS: 2137 passing (+28 vs HEAD baseline of 2109).

View File

@@ -11,7 +11,7 @@ isolation: worktree
## Prompt
You are the sole background agent working `/root/rose-ash/plans/ruby-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
You are the sole background agent working `/root/rose-ash/plans/ruby-on-sx.md`. Isolated worktree, forever, one commit per feature. Push to `origin/loops/ruby` after every commit.
## Restart baseline — check before iterating
@@ -42,7 +42,7 @@ Every iteration: implement → test → commit → tick `[ ]` → Progress log
- **Shared-file issues** → plan's Blockers with minimal repro.
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Worktree:** commit, then push to `origin/loops/ruby`. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.

View File

@@ -104,16 +104,6 @@ Core mapping:
- [ ] Drive corpus to 100+ green
- [ ] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms
## SX primitive baseline
Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data;
coroutines for fibers; string-buffer for mutable string building; bitwise ops for bit
manipulation; multiple values for multi-return; promises for lazy evaluation; hash tables
for mutable associative storage; sets for O(1) membership; sequence protocol for
polymorphic iteration; gensym for unique symbols; char type for characters; string ports
+ read/write for reader protocols; regexp for pattern matching; bytevectors for binary
data; format for string templating.
## Progress log
_Newest first._

View File

@@ -110,16 +110,6 @@ Core mapping:
- [ ] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural)
- [ ] Drive corpus to 200+ green
## SX primitive baseline
Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data;
coroutines for fibers; string-buffer for mutable string building; bitwise ops for bit
manipulation; multiple values for multi-return; promises for lazy evaluation; hash tables
for mutable associative storage; sets for O(1) membership; sequence protocol for
polymorphic iteration; gensym for unique symbols; char type for characters; string ports
+ read/write for reader protocols; regexp for pattern matching; bytevectors for binary
data; format for string templating.
## Progress log
_Newest first._

View File

@@ -1,257 +0,0 @@
# SX Algebraic Data Types — Design
## Motivation
Every language implementation currently uses `{:tag "..." :field ...}` tagged dicts to
simulate sum types. This is verbose, error-prone (typos in tag strings go undetected), and
produces no exhaustiveness warnings. Native ADTs eliminate the pattern everywhere.
Examples of current workarounds:
- Haskell `Maybe a``{:tag "Just" :value x}` / `{:tag "Nothing"}`
- Prolog terms → `{:tag "functor" :name "foo" :args (list x y)}`
- Lua result type → `{:tag "ok" :value v}` / `{:tag "err" :msg s}`
- Common Lisp `cons` pairs → `{:tag "cons" :car a :cdr b}`
---
## Syntax
### `define-type`
```lisp
(define-type Name
(Ctor1 field1 field2 ...)
(Ctor2 field1 ...)
...)
```
Creates:
- Constructor functions: `Ctor1`, `Ctor2`, … (callable like normal functions)
- Type predicate: `Name?` — returns true for any value of type `Name`
- Constructor predicates: `Ctor1?`, `Ctor2?`, … (optional, auto-generated)
- Field accessors: `Ctor1-field1`, `Ctor1-field2`, … (optional, auto-generated)
Examples:
```lisp
(define-type Maybe
(Just value)
(Nothing))
(define-type Result
(Ok value)
(Err message))
(define-type Tree
(Leaf)
(Node left value right))
(define-type List-of
(Nil-of)
(Cons-of head tail))
```
Constructors with no fields are zero-argument constructors (singletons by value):
```lisp
(Nothing) ; => #<Nothing>
(Leaf) ; => #<Leaf>
```
### `match`
```lisp
(match expr
((Ctor1 a b) body)
((Ctor2 x) body)
((Ctor3) body)
(else body))
```
- Clauses are tried in order; first match wins.
- `else` clause is optional but suppresses exhaustiveness warnings.
- Pattern variables (`a`, `b`, `x`) are bound in the body scope.
- Wildcard `_` discards the matched value.
- Literal patterns: `42`, `"str"`, `true`, `nil` — match by value equality.
- Nested patterns: `((Node left (Leaf) right) body)` — nested constructor patterns.
Examples:
```lisp
(match result
((Ok v) (str "got: " v))
((Err m) (str "error: " m)))
(match tree
((Leaf) 0)
((Node l v r) (+ 1 (tree-depth l) (tree-depth r))))
```
---
## CEK Dispatch
### Runtime representation
ADT values are OCaml records (not dicts) — opaque, non-inspectable via `get`:
```ocaml
type adt_value = {
av_type : string; (* type name, e.g. "Maybe" *)
av_ctor : string; (* constructor name, e.g. "Just" *)
av_fields: value array; (* positional fields *)
}
```
In JS: `{ _adt: true, _type: "Maybe", _ctor: "Just", _fields: [v] }`.
`typeOf` returns the ADT type name (e.g. `"Maybe"`).
### `define-type` — special form
`stepSfDefineType(args, env, kont)`:
1. Parse `Name` and list of `(CtorN field...)` clauses.
2. For each constructor `CtorK` with fields `[f1, f2, …]`:
- Register `CtorK` as a `NativeFn` that takes `|fields|` args and returns an `AdtValue`.
- Register `CtorK?` as a predicate (`AdtValue` with matching ctor name → `true`).
- Register `CtorK-fN` as field accessor (returns `av_fields[N]`).
3. Register `Name?` as a predicate (`AdtValue` with matching type name → `true`).
4. All bindings go into the current environment via `env-bind!`.
5. Returns `Nil`.
This is an environment mutation — no new frame needed. Evaluates in one step.
### `match` — special form
`stepSfMatch(args, env, kont)`:
1. Push `MatchFrame` with `clauses` and `env` onto kont.
2. Return state evaluating the scrutinee `expr`.
3. `MatchFrame` continue: receive scrutinee value, walk clauses:
- For each `((CtorN vars...) body)`:
- If scrutinee is an `AdtValue` with `av_ctor = "CtorN"` and `av_fields.length = |vars|`:
- Bind `vars[i]``av_fields[i]` in fresh child env.
- Return state evaluating `body` in that env.
- `(else body)` — always matches, body evaluated in current env.
- Literal `42`/`"str"` patterns: match by value equality.
- Wildcard `_`: always matches, binds nothing.
4. If no clause matched and no `else`: raise `"match: no clause matched <value>"`.
Frame type: `"match"` — stores `cf_remaining` (clauses), `cf_env` (enclosing env).
---
## Interaction with `cond` / `case`
`match` is the primary dispatch form for ADTs. `cond` / `case` remain unchanged:
- `cond` tests arbitrary boolean expressions — still useful for non-ADT dispatch.
- `case` matches on equality to literal values — unchanged.
- `match` is the new form: structural pattern matching on ADT constructors.
They are orthogonal. A `match` clause can contain a `cond`; a `cond` clause can contain a `match`.
---
## Exhaustiveness checking
Emit a **warning** (not an error) when:
- A `match` has no `else` clause, AND
- Not all constructors of the scrutinee's type are covered.
Detection: when `define-type` runs, it registers the constructor set in a global table
`_adt_registry: type_name → [ctor_names]`. At `match` compile/evaluation time:
- If the scrutinee's type is in `_adt_registry` and not all ctors appear as patterns:
- `console.warn("[sx] match: non-exhaustive — missing: Ctor3, Ctor4 for type Maybe")`
- Execution continues (warning, not error).
This is best-effort: the scrutinee type is only known at runtime. The warning fires on
first non-exhaustive match evaluation, not at definition time.
---
## Recursive types
Recursive types work because constructors are registered as functions, and function bodies
are evaluated lazily:
```lisp
(define-type Tree
(Leaf)
(Node left value right))
; Recursive function over a recursive type:
(define (depth tree)
(match tree
((Leaf) 0)
((Node l v r) (+ 1 (max (depth l) (depth r))))))
```
No special treatment needed — the type definition doesn't need to know about recursion.
The constructor `Node` accepts any values, including other `Node` or `Leaf` values.
---
## Pattern variables
In `match` clauses, identifiers in constructor position that are NOT constructor names are
treated as pattern variables (bound to matched field values):
```lisp
(match x
((Just v) v) ; v bound to the wrapped value
((Nothing) nil))
(match pair
((Cons-of h t) (list h t))) ; h, t bound to head and tail
```
**Wildcard**: `_` is always a wildcard — matches anything, binds nothing.
```lisp
(match x
((Just _) "has value")
((Nothing) "empty"))
```
**Nested patterns**:
```lisp
(match tree
((Node (Leaf) v (Leaf)) (str "leaf node: " v))
((Node l v r) (str "inner node: " v)))
```
Nested patterns are matched recursively: the inner `(Leaf)` pattern checks that the
`left` field is itself a `Leaf` ADT value.
---
## Implementation Plan
### Phase 6a — `define-type` + basic `match` (no nested patterns, no exhaustiveness)
1. OCaml: add `AdtValue of adt_value` to `sx_types.ml`.
2. Evaluator: add `step-sf-define-type` — parse clauses, register ctor fns + predicates + accessors.
3. Evaluator: add `step-sf-match` + `MatchFrame` — linear scan of clauses, flat patterns only.
4. JS: same (AdtValue as plain object with `_adt`/`_type`/`_ctor`/`_fields` props).
### Phase 6b — nested patterns (separate fire)
Recursive `matchPattern(pattern, value, env)` helper that:
- Returns `{matched: bool, bindings: map}`
- Recursively matches sub-patterns against ADT fields.
### Phase 6c — exhaustiveness warnings (separate fire)
`_adt_registry` global + warning emission on first non-exhaustive match.
---
## Open questions (deferred to review)
1. **Accessor auto-generation**: should `Ctor-field` accessors be generated always, or only on demand? Risk: name collisions if two types have constructors with same field names.
2. **Singleton constructors**: `(Nothing)` — zero-arg ctor — should these be interned (same object every call) or fresh each time? Interning enables `eq?` checks but requires a global table.
3. **Printing/inspect**: `inspect` on an AdtValue should show `(Just 42)` not `#<adt:Just>`. Implement in `inspect` function or via `display`/`write` (Phase 17 ports).
4. **Pattern-matching on non-ADT values**: should `match` handle list patterns `(a . b)` and literal patterns in clause heads? Deferred — add only if needed by a language implementation.

View File

@@ -125,7 +125,7 @@ Each item: implement → tests → update progress. Mark `[x]` when tests green.
- [x] Rest params (`...rest``&rest`)
- [x] Default parameters (desugar to `if (param === undefined) param = default`)
- [ ] `var` hoisting (deferred — treated as `let` for now)
- [x] `let`/`const` TDZ — sentinel infrastructure (`__js_tdz_sentinel__`, `js-tdz?`, `js-tdz-check` in runtime.sx)
- [ ] `let`/`const` TDZ (deferred)
### Phase 8 — Objects, prototypes, `this`
- [x] Property descriptors (simplified — plain-dict `__proto__` chain, `js-set-prop` mutates)
@@ -241,8 +241,6 @@ Append-only record of completed iterations. Loop writes one line per iteration:
- 29× Timeout (slow string/regex loops)
- 16× ReferenceError — still some missing globals
- 2026-04-25 — **Regex engine (lib/js/regex.sx) + let/const TDZ infrastructure.** New file `lib/js/regex.sx`: 39-form pure-SX recursive backtracking engine installed via `js-regex-platform-override!`. Covers literals, `.`, `\d\w\s` + negations, `[abc]/[^abc]/[a-z]` char classes, `^\$\b\B` anchors, greedy+lazy quantifiers (`* + ? {n,m} *? +? ??`), capturing groups, non-capturing `(?:...)`, alternation `a|b`, flags `i`/`g`/`m`. Groups: match inner first → set capture → match rest (correct boundary), avoids including rest-nodes content in capture. Greedy: expand-first then backtrack (correct longest-match semantics). `js-regex-match-all` for String.matchAll. Fixed `String.prototype.match` to use platform engine (was calling stub). TDZ infrastructure added to `runtime.sx`: `__js_tdz_sentinel__` (unique sentinel dict), `js-tdz?`, `js-tdz-check`. `transpile.sx` passes `kind` through `js-transpile-var → js-vardecl-forms` (no behavioral change yet — infrastructure ready). `test262-runner.py` and `conformance.sh` updated to load `regex.sx` as epoch 6/50. Unit: **559/560** (was 522/522 before regex tests added, now +38 new tests; 1 pre-existing backtick failure). Conformance: **148/148** (unchanged). Gotchas: (1) `sx_insert_near` on a pattern inside a top-level function body inserts there (not at top level) — need to use `sx_insert_near` on a top-level symbol name. (2) Greedy quantifier must expand-first before trying rest-nodes; the naive "try rest at each step" produces lazy behavior. (3) Capturing groups must match inner nodes in isolation first (to get the group's end position) then match rest — appending inner+rest-nodes would include rest in the capture string.
## Phase 3-5 gotchas
Worth remembering for later phases:
@@ -261,7 +259,17 @@ Anything that would require a change outside `lib/js/` goes here with a minimal
- **Pending-Promise await** — our `js-await-value` drains microtasks and unwraps *settled* Promises; it cannot truly suspend a JS fiber and resume later. Every Promise that settles eventually through the synchronous `resolve`/`reject` + microtask path works. A Promise that never settles without external input (e.g. a real `setTimeout` waiting on the event loop) would hit the `"await on pending Promise (no scheduler)"` error. Proper async suspension would need the JS eval path to run under `cek-step-loop` (not `eval-expr``cek-run`) and treat `await pending-Promise` as a `perform` that registers a resume thunk on the Promise's callback list. Non-trivial plumbing; out of scope for this phase. Consider it a Phase 9.5 item.
- ~~**Regex platform primitives**~~ **RESOLVED**`lib/js/regex.sx` ships a pure-SX recursive backtracking engine. Installs via `js-regex-platform-override!` at load. Covers: literals, `.`, `\d\w\s` and negations, `[abc]` / `[^abc]` / ranges, `^` `$` `\b \B`, `* + ? {n,m}` (greedy + lazy), capturing + non-capturing groups, alternation `a|b`, flags `i` (case-insensitive), `g` (global, advances lastIndex), `m` (multiline anchors). `js-regex-match-all` for String.matchAll. String.prototype.match regex path updated to use platform engine (was calling stub). 34 new unit tests added (50005033). Conformance: 148/148 (unchanged — slice had no regex fixtures).
- **Regex platform primitives** — runtime ships a substring-based stub (`js-regex-stub-test` / `-exec`). Overridable via `js-regex-platform-override!` so a real engine can be dropped in. Required platform-primitive surface:
- `regex-compile pattern flags` — build an opaque compiled handle
- `regex-test compiled s` → bool
- `regex-exec compiled s` → match dict `{match index input groups}` or nil
- `regex-match-all compiled s` → list of match dicts (or empty list)
- `regex-replace compiled s replacement` → string
- `regex-replace-fn compiled s fn` → string (fn receives match+groups, returns string)
- `regex-split compiled s` → list of strings
- `regex-source compiled` → string
- `regex-flags compiled` → string
Ideally a single `(js-regex-platform-install-all! platform)` entry point the host calls once at boot. OCaml would wrap `Str` / `Re` or a dedicated regex lib; JS host can just delegate to the native `RegExp`.
- **Math trig + transcendental primitives missing.** The scoreboard shows 34× "TypeError: not a function" across the Math category — every one a test calling `Math.sin/cos/tan/log/…` on our runtime. We shim `Math` via `js-global`; the SX runtime supplies `sqrt`, `pow`, `abs`, `floor`, `ceil`, `round` and a hand-rolled `trunc`/`sign`/`cbrt`/`hypot`. Nothing else. Missing platform primitives (each is a one-line OCaml/JS binding, but a primitive all the same — we can't land approximation polynomials from inside the JS shim, they'd blow `Math.sin(1e308)` precision):
- Trig: `sin`, `cos`, `tan`, `asin`, `acos`, `atan`, `atan2`

View File

@@ -51,11 +51,11 @@ Core mapping:
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: keywords (`def end class module if unless while until do return yield begin rescue ensure case when then else elsif`), identifiers (lowercase = local/method, `@` = ivar, `@@` = cvar, `$` = global, uppercase = constant), numbers (int, float, `0x` `0o` `0b`, `_` separators), strings (`"…"` interpolation, `'…'` literal, `%w[a b c]`, `%i[a b c]`), symbols `:foo` `:"…"`, operators (`+ - * / % ** == != < > <= >= <=> === =~ !~ << >> & | ^ ~ ! && || and or not`), `:: . , ; ( ) [ ] { } -> => |`, comments `#`
- [ ] Parser: program is sequence of statements separated by newlines or `;`; method def `def name(args) … end`; class `class Foo < Bar … end`; module `module M … end`; block `do |a, b| … end` and `{ |a, b| … }`; call sugar (no parens), `obj.method`, `Mod::Const`; arg shapes (positional, default, splat `*args`, double-splat `**opts`, block `&blk`)
- [x] Tokenizer: keywords (`def end class module if unless while until do return yield begin rescue ensure case when then else elsif`), identifiers (lowercase = local/method, `@` = ivar, `@@` = cvar, `$` = global, uppercase = constant), numbers (int, float, `0x` `0o` `0b`, `_` separators), strings (`"…"` interpolation, `'…'` literal, `%w[a b c]`, `%i[a b c]`), symbols `:foo` `:"…"`, operators (`+ - * / % ** == != < > <= >= <=> === =~ !~ << >> & | ^ ~ ! && || and or not`), `:: . , ; ( ) [ ] { } -> => |`, comments `#`
- [x] Parser: program is sequence of statements separated by newlines or `;`; method def `def name(args) … end`; class `class Foo < Bar … end`; module `module M … end`; block `do |a, b| … end` and `{ |a, b| … }`; call sugar (no parens), `obj.method`, `Mod::Const`; arg shapes (positional, default, splat `*args`, double-splat `**opts`, block `&blk`)
- [ ] If/while/case expressions (return values), `unless`/`until`, postfix modifiers
- [ ] Begin/rescue/ensure/retry, raise, raise with class+message
- [ ] Unit tests in `lib/ruby/tests/parse.sx`
- [x] Unit tests in `lib/ruby/tests/parse.sx`
### Phase 2 — object model + sequential eval
- [ ] Class table bootstrap: `BasicObject`, `Object`, `Kernel`, `Module`, `Class`, `Numeric`, `Integer`, `Float`, `String`, `Symbol`, `Array`, `Hash`, `Range`, `NilClass`, `TrueClass`, `FalseClass`, `Proc`, `Method`
@@ -113,21 +113,12 @@ Core mapping:
- [ ] `Integer`: `times`, `upto`, `downto`, `step`, `digits`, `gcd`, `lcm`
- [ ] Drive corpus to 200+ green
## SX primitive baseline
Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data;
coroutines for fibers; string-buffer for mutable string building; bitwise ops for bit
manipulation; multiple values for multi-return; promises for lazy evaluation; hash tables
for mutable associative storage; sets for O(1) membership; sequence protocol for
polymorphic iteration; gensym for unique symbols; char type for characters; string ports
+ read/write for reader protocols; regexp for pattern matching; bytevectors for binary
data; format for string templating.
## Progress log
_Newest first._
- _(none yet)_
- 2026-04-25: Phase 1 parser complete — `lib/ruby/parser.sx` (rb-parse/rb-parse-str) + `lib/ruby/tests/parse.sx` (83/83 tests). Program, method-def (all param shapes), class/module/sclass, blocks (do/brace), method calls (parens + no-parens + chains), const-path, assignment (=, op=, massign), binary/unary ops with precedence, array/hash literals, return/yield/break/next/redo/raise, indexing.
- 2026-04-25: Phase 1 tokenizer complete — `lib/ruby/tokenizer.sx` + `lib/ruby/tests/tokenizer.sx` (107/107 tests). Keywords, identifiers (@ivar @@cvar $gvar), numbers (dec/hex/octal/binary/float), strings (dq with interpolation kept raw, sq), symbols, %w/%i literals, operators (all compound forms), punctuation, comments, line/col tracking.
## Blockers

View File

@@ -116,16 +116,6 @@ Core mapping:
- [ ] Drive corpus to 150+ green
- [ ] Idiom corpus — `lib/tcl/tests/idioms.sx` covering classic Welch/Jones idioms
## SX primitive baseline
Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data;
coroutines for fibers; string-buffer for mutable string building; bitwise ops for bit
manipulation; multiple values for multi-return; promises for lazy evaluation; hash tables
for mutable associative storage; sets for O(1) membership; sequence protocol for
polymorphic iteration; gensym for unique symbols; char type for characters; string ports
+ read/write for reader protocols; regexp for pattern matching; bytevectors for binary
data; format for string templating.
## Progress log
_Newest first._

View File

@@ -1,121 +0,0 @@
#!/usr/bin/env bash
# Spawn a single claude session to implement SX primitives in sequence.
# Runs in its own git worktree on branch sx-primitives from architecture.
#
# Usage: ./scripts/sx-primitives-up.sh [interval]
# interval defaults to self-paced (omit to let model decide)
#
# After the script prints done:
# tmux a -t sx-primitives
# Ctrl-B + d to detach
#
# Stop: ./scripts/sx-primitives-down.sh
set -euo pipefail
ROOT="$(cd "$(dirname "$0")/.." && pwd)"
cd "$ROOT"
SESSION="sx-primitives"
WORKTREE="$ROOT" # runs in the main worktree — architecture branch
BRANCH="architecture"
INTERVAL="${1:-}"
BOOT_WAIT=20
if tmux has-session -t "$SESSION" 2>/dev/null; then
echo "Session '$SESSION' already exists."
echo " Attach: tmux a -t $SESSION"
echo " Kill: ./scripts/sx-primitives-down.sh"
exit 1
fi
# Write settings into the main worktree .claude dir
SETTINGS_DIR="$ROOT/.claude"
mkdir -p "$SETTINGS_DIR"
cat > "$SETTINGS_DIR/settings.local.json" <<'SETTINGS'
{
"permissions": {
"allow": [
"mcp__sx-tree__sx_summarise",
"mcp__sx-tree__sx_read_tree",
"mcp__sx-tree__sx_read_subtree",
"mcp__sx-tree__sx_get_context",
"mcp__sx-tree__sx_find_all",
"mcp__sx-tree__sx_find_across",
"mcp__sx-tree__sx_get_siblings",
"mcp__sx-tree__sx_validate",
"mcp__sx-tree__sx_replace_node",
"mcp__sx-tree__sx_insert_child",
"mcp__sx-tree__sx_insert_near",
"mcp__sx-tree__sx_delete_node",
"mcp__sx-tree__sx_wrap_node",
"mcp__sx-tree__sx_rename_symbol",
"mcp__sx-tree__sx_replace_by_pattern",
"mcp__sx-tree__sx_rename_across",
"mcp__sx-tree__sx_write_file",
"mcp__sx-tree__sx_pretty_print",
"mcp__sx-tree__sx_eval",
"mcp__sx-tree__sx_harness_eval",
"mcp__sx-tree__sx_macroexpand",
"mcp__sx-tree__sx_trace",
"mcp__sx-tree__sx_deps",
"mcp__sx-tree__sx_diff",
"mcp__sx-tree__sx_diff_branch",
"mcp__sx-tree__sx_changed",
"mcp__sx-tree__sx_blame",
"mcp__sx-tree__sx_build",
"mcp__sx-tree__sx_build_manifest",
"mcp__sx-tree__sx_build_bytecode",
"mcp__sx-tree__sx_test",
"mcp__sx-tree__sx_format_check",
"mcp__sx-tree__sx_comp_list",
"mcp__sx-tree__sx_comp_usage",
"mcp__sx-tree__sx_nav",
"mcp__sx-tree__sx_env",
"mcp__sx-tree__sx_playwright",
"mcp__hs-test__hs_test_run",
"mcp__hs-test__hs_test_regen",
"mcp__hs-test__hs_test_kill",
"mcp__hs-test__hs_test_status",
"Bash(node *)",
"Bash(python3 *)",
"Bash(bash *)",
"Bash(cp *)",
"Bash(git *)",
"Bash(tmux *)"
]
},
"enabledMcpjsonServers": [
"sx-tree",
"rose-ash-services",
"hs-test"
]
}
SETTINGS
echo "Creating tmux session '$SESSION' in $ROOT ..."
tmux new-session -d -s "$SESSION" -n "primitives" -c "$ROOT"
echo "Starting claude..."
tmux send-keys -t "$SESSION:primitives" "claude" C-m
echo "Waiting ${BOOT_WAIT}s for claude to boot..."
sleep "$BOOT_WAIT"
if [ -n "$INTERVAL" ]; then
preamble="/loop $INTERVAL "
else
preamble="/loop "
fi
cmd="${preamble}Read plans/agent-briefings/primitives-loop.md and do ONE step per fire: find the first unchecked [ ] task, implement it fully, run the relevant tests to verify, commit with a short factual message, push to origin/architecture, tick the box [x] in the plan, append one dated line to the Progress log (newest first), then stop. You are on branch architecture in /root/rose-ash. Use sx-tree MCP for all .sx edits. Never push to main."
tmux send-keys -t "$SESSION:primitives" "$cmd"
sleep 0.5
tmux send-keys -t "$SESSION:primitives" Enter
echo ""
echo "Done. SX primitives loop started in tmux session '$SESSION'."
echo ""
echo " Attach: tmux a -t $SESSION"
echo " Detach: Ctrl-B d"
echo " Stop: ./scripts/sx-primitives-down.sh"
echo ""

File diff suppressed because it is too large Load Diff

View File

@@ -1,56 +0,0 @@
(define-library
(sx coroutines)
(export
make-coroutine
coroutine?
coroutine-alive?
coroutine-yield
coroutine-handle-result
coroutine-resume)
(begin
(define make-coroutine (fn (thunk) {:suspension nil :thunk thunk :type "coroutine" :state "ready"}))
(define
coroutine?
(fn (v) (and (dict? v) (= (get v "type") "coroutine"))))
(define
coroutine-alive?
(fn (c) (and (coroutine? c) (not (= (get c "state") "dead")))))
(define coroutine-yield (fn (val) (perform {:value val :op "coroutine-yield"})))
(define
coroutine-handle-result
(fn
(c result)
(if
(cek-terminal? result)
(do (dict-set! c "state" "dead") {:done true :value (cek-value result)})
(let
((request (cek-io-request result)))
(if
(and (dict? request) (= (get request "op") "coroutine-yield"))
(do
(dict-set! c "state" "suspended")
(dict-set! c "suspension" result)
{:done false :value (get request "value")})
(perform request))))))
(define
coroutine-resume
(fn
(c val)
(cond
(not (coroutine? c))
(error "coroutine-resume: not a coroutine")
(= (get c "state") "dead")
(error "coroutine-resume: coroutine is dead")
(= (get c "state") "ready")
(do
(dict-set! c "state" "running")
(coroutine-handle-result
c
(cek-step-loop
(make-cek-state (list (get c "thunk")) (make-env) (list)))))
(= (get c "state") "suspended")
(do
(dict-set! c "state" "running")
(coroutine-handle-result c (cek-resume (get c "suspension") val)))
:else (error
(str "coroutine-resume: unexpected state: " (get c "state"))))))))

File diff suppressed because it is too large Load Diff

View File

@@ -14,15 +14,13 @@
;; list → '(' expr* ')'
;; vector → '[' expr* ']' (sugar for list)
;; map → '{' (key expr)* '}'
;; atom → string | number | rational | keyword | symbol | boolean | nil | char
;; atom → string | number | keyword | symbol | boolean | nil
;; string → '"' (char | escape)* '"'
;; number → '-'? digit+ ('.' digit+)? ([eE] [+-]? digit+)?
;; rational → integer '/' digit+
;; keyword → ':' ident
;; symbol → ident
;; boolean → 'true' | 'false'
;; nil → 'nil'
;; char → '#\' (ident | single-char)
;; ident → ident-start ident-char*
;; comment → ';' to end of line (discarded)
;;
@@ -36,8 +34,6 @@
;; #;expr → datum comment (read and discard expr)
;; #|raw chars| → raw string literal (no escape processing)
;; #'expr → (quote expr)
;; #\a → character literal (char value)
;; #\space → named character (space = 32)
;; #name expr → extensible dispatch (calls registered handler)
;;
;; Platform interface (each target implements natively):
@@ -46,11 +42,6 @@
;; (make-symbol name) → Symbol value
;; (make-keyword name) → Keyword value
;; (escape-string s) → string with " and \ escaped for serialization
;; (make-char n) → Char value from Unicode codepoint
;; (make-rational n d) → Rational value (auto-reduced by GCD)
;; (char->integer c) → Unicode codepoint of char c
;; (char-from-code n) → single-char string from codepoint
;; (char-code s) → codepoint of first char in string s
;; ==========================================================================
@@ -60,436 +51,308 @@
;; Returns a list of top-level AST expressions.
;; Parse SX source string into AST
(define
sx-parse
:effects ()
(fn
((source :as string))
(let
((pos 0) (len-src (len source)))
(define
skip-comment
:effects ()
(fn
()
(when
(and (< pos len-src) (not (= (nth source pos) "\n")))
(define sx-parse :effects []
(fn ((source :as string))
(let ((pos 0)
(len-src (len source)))
;; -- Cursor helpers (closure over pos, source, len-src) --
(define skip-comment :effects []
(fn ()
(when (and (< pos len-src) (not (= (nth source pos) "\n")))
(set! pos (inc pos))
(skip-comment))))
(define
skip-ws
:effects ()
(fn
()
(when
(< pos len-src)
(let
((ch (nth source pos)))
(define skip-ws :effects []
(fn ()
(when (< pos len-src)
(let ((ch (nth source pos)))
(cond
;; Whitespace
(or (= ch " ") (= ch "\t") (= ch "\n") (= ch "\r"))
(do (set! pos (inc pos)) (skip-ws))
(do (set! pos (inc pos)) (skip-ws))
;; Comment — skip to end of line
(= ch ";")
(do (set! pos (inc pos)) (skip-comment) (skip-ws))
(do (set! pos (inc pos))
(skip-comment)
(skip-ws))
;; Not whitespace or comment — stop
:else nil)))))
(define
hex-digit-value
:effects ()
;; -- Atom readers --
(define hex-digit-value :effects []
(fn (ch) (index-of "0123456789abcdef" (lower ch))))
(define
read-string
:effects ()
(fn
()
(set! pos (inc pos))
(let
((buf ""))
(define
read-str-loop
:effects ()
(fn
()
(if
(>= pos len-src)
(define read-string :effects []
(fn ()
(set! pos (inc pos)) ;; skip opening "
(let ((buf ""))
(define read-str-loop :effects []
(fn ()
(if (>= pos len-src)
(error "Unterminated string")
(let
((ch (nth source pos)))
(let ((ch (nth source pos)))
(cond
(= ch "\"")
(do (set! pos (inc pos)) nil)
(do (set! pos (inc pos)) nil) ;; done
(= ch "\\")
(do
(set! pos (inc pos))
(let
((esc (nth source pos)))
(if
(= esc "u")
(do
(set! pos (inc pos))
(let
((d0 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos)))
(d1 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos)))
(d2 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos)))
(d3 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos))))
(set!
buf
(str
buf
(char-from-code
(+
(* d0 4096)
(* d1 256)
(* d2 16)
d3))))
(read-str-loop)))
(do
(set!
buf
(str
buf
(cond
(= esc "n")
"\n"
(= esc "t")
"\t"
(= esc "r")
"\r"
:else esc)))
(set! pos (inc pos))
(read-str-loop)))))
:else (do
(set! buf (str buf ch))
(set! pos (inc pos))
(read-str-loop)))))))
(do (set! pos (inc pos))
(let ((esc (nth source pos)))
(if (= esc "u")
;; Unicode escape: \uXXXX → char
(do (set! pos (inc pos))
(let ((d0 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos)))
(d1 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos)))
(d2 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos)))
(d3 (hex-digit-value (nth source pos)))
(_ (set! pos (inc pos))))
(set! buf (str buf (char-from-code
(+ (* d0 4096) (* d1 256) (* d2 16) d3))))
(read-str-loop)))
;; Standard escapes: \n \t \r or literal
(do (set! buf (str buf
(cond
(= esc "n") "\n"
(= esc "t") "\t"
(= esc "r") "\r"
:else esc)))
(set! pos (inc pos))
(read-str-loop)))))
:else
(do (set! buf (str buf ch))
(set! pos (inc pos))
(read-str-loop)))))))
(read-str-loop)
buf)))
(define
read-ident
:effects ()
(fn
()
(let
((start pos))
(define
read-ident-loop
:effects ()
(fn
()
(when
(and (< pos len-src) (ident-char? (nth source pos)))
(define read-ident :effects []
(fn ()
(let ((start pos))
(define read-ident-loop :effects []
(fn ()
(when (and (< pos len-src)
(ident-char? (nth source pos)))
(set! pos (inc pos))
(read-ident-loop))))
(read-ident-loop)
(slice source start pos))))
(define
read-keyword
:effects ()
(fn () (set! pos (inc pos)) (make-keyword (read-ident))))
(define
read-number
:effects ()
(fn
()
(let
((start pos))
(when
(and (< pos len-src) (= (nth source pos) "-"))
(define read-keyword :effects []
(fn ()
(set! pos (inc pos)) ;; skip :
(make-keyword (read-ident))))
(define read-number :effects []
(fn ()
(let ((start pos))
;; Optional leading minus
(when (and (< pos len-src) (= (nth source pos) "-"))
(set! pos (inc pos)))
(define
read-digits
:effects ()
(fn
()
(when
(and
(< pos len-src)
(let
((c (nth source pos)))
(and (>= c "0") (<= c "9"))))
;; Integer digits
(define read-digits :effects []
(fn ()
(when (and (< pos len-src)
(let ((c (nth source pos)))
(and (>= c "0") (<= c "9"))))
(set! pos (inc pos))
(read-digits))))
(read-digits)
(if
(and
(< pos len-src)
(= (nth source pos) "/")
(< (inc pos) len-src)
(let
((nc (nth source (inc pos))))
(and (>= nc "0") (<= nc "9"))))
(let
((numer (parse-number (slice source start pos))))
(set! pos (inc pos))
(let
((denom-start pos))
(read-digits)
(make-rational
numer
(parse-number (slice source denom-start pos)))))
(do
(when
(and (< pos len-src) (= (nth source pos) "."))
(set! pos (inc pos))
(read-digits))
(when
(and
(< pos len-src)
(or (= (nth source pos) "e") (= (nth source pos) "E")))
(set! pos (inc pos))
(when
(and
(< pos len-src)
(or
(= (nth source pos) "+")
(= (nth source pos) "-")))
(set! pos (inc pos)))
(read-digits))
(parse-number (slice source start pos)))))))
(define
read-symbol
:effects ()
(fn
()
(let
((name (read-ident)))
;; Decimal part
(when (and (< pos len-src) (= (nth source pos) "."))
(set! pos (inc pos))
(read-digits))
;; Exponent
(when (and (< pos len-src)
(or (= (nth source pos) "e")
(= (nth source pos) "E")))
(set! pos (inc pos))
(when (and (< pos len-src)
(or (= (nth source pos) "+")
(= (nth source pos) "-")))
(set! pos (inc pos)))
(read-digits))
(parse-number (slice source start pos)))))
(define read-symbol :effects []
(fn ()
(let ((name (read-ident)))
(cond
(= name "true")
true
(= name "false")
false
(= name "nil")
nil
:else (make-symbol name)))))
(define
read-list
:effects ()
(fn
((close-ch :as string))
(let
((items (list)))
(define
read-list-loop
:effects ()
(fn
()
(= name "true") true
(= name "false") false
(= name "nil") nil
:else (make-symbol name)))))
;; -- Composite readers --
(define read-list :effects []
(fn ((close-ch :as string))
(let ((items (list)))
(define read-list-loop :effects []
(fn ()
(skip-ws)
(if
(>= pos len-src)
(if (>= pos len-src)
(error "Unterminated list")
(if
(= (nth source pos) close-ch)
(do (set! pos (inc pos)) nil)
(do (append! items (read-expr)) (read-list-loop))))))
(if (= (nth source pos) close-ch)
(do (set! pos (inc pos)) nil) ;; done
(do (append! items (read-expr))
(read-list-loop))))))
(read-list-loop)
items)))
(define
read-map
:effects ()
(fn
()
(let
((result (dict)))
(define
read-map-loop
:effects ()
(fn
()
(define read-map :effects []
(fn ()
(let ((result (dict)))
(define read-map-loop :effects []
(fn ()
(skip-ws)
(if
(>= pos len-src)
(if (>= pos len-src)
(error "Unterminated map")
(if
(= (nth source pos) "}")
(do (set! pos (inc pos)) nil)
(let
((key-expr (read-expr))
(key-str
(if
(= (type-of key-expr) "keyword")
(keyword-name key-expr)
(str key-expr)))
(val-expr (read-expr)))
(if (= (nth source pos) "}")
(do (set! pos (inc pos)) nil) ;; done
(let ((key-expr (read-expr))
(key-str (if (= (type-of key-expr) "keyword")
(keyword-name key-expr)
(str key-expr)))
(val-expr (read-expr)))
(dict-set! result key-str val-expr)
(read-map-loop))))))
(read-map-loop)
result)))
(define
read-raw-string
:effects ()
(fn
()
(let
((buf ""))
(define
raw-loop
:effects ()
(fn
()
(if
(>= pos len-src)
;; -- Raw string reader (for #|...|) --
(define read-raw-string :effects []
(fn ()
(let ((buf ""))
(define raw-loop :effects []
(fn ()
(if (>= pos len-src)
(error "Unterminated raw string")
(let
((ch (nth source pos)))
(if
(= ch "|")
(do (set! pos (inc pos)) nil)
(do
(set! buf (str buf ch))
(set! pos (inc pos))
(raw-loop)))))))
(let ((ch (nth source pos)))
(if (= ch "|")
(do (set! pos (inc pos)) nil) ;; done
(do (set! buf (str buf ch))
(set! pos (inc pos))
(raw-loop)))))))
(raw-loop)
buf)))
(define
read-char-literal
:effects ()
(fn
()
(if
(>= pos len-src)
(error "Unexpected end of input after #\\")
(let
((first-ch (nth source pos)))
(if
(ident-start? first-ch)
(let
((char-start pos))
(define
read-char-name-loop
:effects ()
(fn
()
(when
(and (< pos len-src) (ident-char? (nth source pos)))
(set! pos (inc pos))
(read-char-name-loop))))
(read-char-name-loop)
(let
((char-name (slice source char-start pos)))
(make-char
(cond
(= char-name "space")
32
(= char-name "newline")
10
(= char-name "tab")
9
(= char-name "nul")
0
(= char-name "null")
0
(= char-name "return")
13
(= char-name "escape")
27
(= char-name "delete")
127
(= char-name "backspace")
8
(= char-name "altmode")
27
(= char-name "rubout")
127
:else (char-code first-ch)))))
(do (set! pos (inc pos)) (make-char (char-code first-ch))))))))
(define
read-expr
:effects ()
(fn
()
;; -- Main expression reader --
(define read-expr :effects []
(fn ()
(skip-ws)
(if
(>= pos len-src)
(if (>= pos len-src)
(error "Unexpected end of input")
(let
((ch (nth source pos)))
(let ((ch (nth source pos)))
(cond
;; Lists
(= ch "(")
(do (set! pos (inc pos)) (read-list ")"))
(do (set! pos (inc pos)) (read-list ")"))
(= ch "[")
(do (set! pos (inc pos)) (read-list "]"))
(do (set! pos (inc pos)) (read-list "]"))
;; Map
(= ch "{")
(do (set! pos (inc pos)) (read-map))
(do (set! pos (inc pos)) (read-map))
;; String
(= ch "\"")
(read-string)
(read-string)
;; Keyword
(= ch ":")
(read-keyword)
(read-keyword)
;; Quote sugar
(= ch "'")
(do
(set! pos (inc pos))
(list (make-symbol "quote") (read-expr)))
(do (set! pos (inc pos))
(list (make-symbol "quote") (read-expr)))
;; Quasiquote sugar
(= ch "`")
(do
(set! pos (inc pos))
(list (make-symbol "quasiquote") (read-expr)))
(do (set! pos (inc pos))
(list (make-symbol "quasiquote") (read-expr)))
;; Unquote / splice-unquote
(= ch ",")
(do
(set! pos (inc pos))
(if
(and (< pos len-src) (= (nth source pos) "@"))
(do
(set! pos (inc pos))
(list (make-symbol "splice-unquote") (read-expr)))
(list (make-symbol "unquote") (read-expr))))
(do (set! pos (inc pos))
(if (and (< pos len-src) (= (nth source pos) "@"))
(do (set! pos (inc pos))
(list (make-symbol "splice-unquote") (read-expr)))
(list (make-symbol "unquote") (read-expr))))
;; Reader macros: #
(= ch "#")
(do
(set! pos (inc pos))
(if
(>= pos len-src)
(error "Unexpected end of input after #")
(let
((dispatch-ch (nth source pos)))
(cond
(= dispatch-ch ";")
(do (set! pos (inc pos)) (read-expr) (read-expr))
(= dispatch-ch "|")
(do (set! pos (inc pos)) (read-raw-string))
(= dispatch-ch "'")
(do
(set! pos (inc pos))
(list (make-symbol "quote") (read-expr)))
(= dispatch-ch "\\")
(do (set! pos (inc pos)) (read-char-literal))
(ident-start? dispatch-ch)
(let
((macro-name (read-ident)))
(let
((handler (reader-macro-get macro-name)))
(if
handler
(handler (read-expr))
(error
(str "Unknown reader macro: #" macro-name)))))
:else (error (str "Unknown reader macro: #" dispatch-ch))))))
(or
(and (>= ch "0") (<= ch "9"))
(and
(= ch "-")
(< (inc pos) len-src)
(let
((next-ch (nth source (inc pos))))
(and (>= next-ch "0") (<= next-ch "9")))))
(read-number)
(and
(= ch ".")
(< (+ pos 2) len-src)
(= (nth source (+ pos 1)) ".")
(= (nth source (+ pos 2)) "."))
(do (set! pos (+ pos 3)) (make-symbol "..."))
(do (set! pos (inc pos))
(if (>= pos len-src)
(error "Unexpected end of input after #")
(let ((dispatch-ch (nth source pos)))
(cond
;; #; — datum comment: read and discard next expr
(= dispatch-ch ";")
(do (set! pos (inc pos))
(read-expr) ;; read and discard
(read-expr)) ;; return the NEXT expr
;; #| — raw string
(= dispatch-ch "|")
(do (set! pos (inc pos))
(read-raw-string))
;; #' — quote shorthand
(= dispatch-ch "'")
(do (set! pos (inc pos))
(list (make-symbol "quote") (read-expr)))
;; #name — extensible dispatch
(ident-start? dispatch-ch)
(let ((macro-name (read-ident)))
(let ((handler (reader-macro-get macro-name)))
(if handler
(handler (read-expr))
(error (str "Unknown reader macro: #" macro-name)))))
:else
(error (str "Unknown reader macro: #" dispatch-ch))))))
;; Number (or negative number)
(or (and (>= ch "0") (<= ch "9"))
(and (= ch "-")
(< (inc pos) len-src)
(let ((next-ch (nth source (inc pos))))
(and (>= next-ch "0") (<= next-ch "9")))))
(read-number)
;; Ellipsis (... as a symbol)
(and (= ch ".")
(< (+ pos 2) len-src)
(= (nth source (+ pos 1)) ".")
(= (nth source (+ pos 2)) "."))
(do (set! pos (+ pos 3))
(make-symbol "..."))
;; Symbol (must be ident-start char)
(ident-start? ch)
(read-symbol)
:else (error (str "Unexpected character: " ch)))))))
(let
((exprs (list)))
(define
parse-loop
:effects ()
(fn
()
(read-symbol)
;; Unexpected
:else
(error (str "Unexpected character: " ch)))))))
;; -- Entry point: parse all top-level expressions --
(let ((exprs (list)))
(define parse-loop :effects []
(fn ()
(skip-ws)
(when (< pos len-src) (append! exprs (read-expr)) (parse-loop))))
(when (< pos len-src)
(append! exprs (read-expr))
(parse-loop))))
(parse-loop)
exprs))))
@@ -499,77 +362,30 @@
;; --------------------------------------------------------------------------
;; Serialize AST value back to SX source
(define
sx-serialize
:effects ()
(fn
(val)
(case
(type-of val)
"nil"
"nil"
"boolean"
(if val "true" "false")
"number"
(str val)
"rational"
(str (numerator val) "/" (denominator val))
"string"
(str "\"" (escape-string val) "\"")
"symbol"
(symbol-name val)
"keyword"
(str ":" (keyword-name val))
"list"
(str "(" (join " " (map sx-serialize val)) ")")
"dict"
(sx-serialize-dict val)
"sx-expr"
(sx-expr-source val)
"spread"
(str "(make-spread " (sx-serialize-dict (spread-attrs val)) ")")
"char"
(let
((n (char->integer val)))
(str
"#\\"
(cond
(= n 32)
"space"
(= n 10)
"newline"
(= n 9)
"tab"
(= n 13)
"return"
(= n 0)
"nul"
(= n 27)
"escape"
(= n 127)
"delete"
(= n 8)
"backspace"
:else (char-from-code n))))
:else (str val))))
(define sx-serialize :effects []
(fn (val)
(case (type-of val)
"nil" "nil"
"boolean" (if val "true" "false")
"number" (str val)
"string" (str "\"" (escape-string val) "\"")
"symbol" (symbol-name val)
"keyword" (str ":" (keyword-name val))
"list" (str "(" (join " " (map sx-serialize val)) ")")
"dict" (sx-serialize-dict val)
"sx-expr" (sx-expr-source val)
"spread" (str "(make-spread " (sx-serialize-dict (spread-attrs val)) ")")
:else (str val))))
;; Serialize a dict to SX {:key val} format
(define
sx-serialize-dict
:effects ()
(fn
((d :as dict))
(str
"{"
(join
" "
(define sx-serialize-dict :effects []
(fn ((d :as dict))
(str "{"
(join " "
(reduce
(fn
((acc :as list) (key :as string))
(concat
acc
(list (str ":" key) (sx-serialize (dict-get d key)))))
(fn ((acc :as list) (key :as string))
(concat acc (list (str ":" key) (sx-serialize (dict-get d key)))))
(list)
(keys d)))
"}")))
@@ -591,18 +407,13 @@
;; True for: ident-start chars plus: 0-9 . : / # ,
;;
;; Constructors (provided by the SX runtime):
;; (make-symbol name) → Symbol value
;; (make-keyword name) → Keyword value
;; (parse-number s) → number (int or float from string)
;; (make-char n) → Char value from Unicode codepoint n
;; (make-rational n d) → Rational value (auto-reduced by GCD; d=0 is an error)
;; (char->integer c) → Unicode codepoint of char c
;; (make-symbol name) → Symbol value
;; (make-keyword name) → Keyword value
;; (parse-number s) → number (int or float from string)
;;
;; String utilities:
;; (escape-string s) → string with " and \ escaped
;; (sx-expr-source e) → unwrap SxExpr to its source string
;; (char-from-code n) → single-char string from codepoint n
;; (char-code s) → codepoint of first char in string s
;;
;; Reader macro registry:
;; (reader-macro-get name) → handler fn or nil

View File

@@ -43,35 +43,35 @@
"+"
:params (&rest (args :as number))
:returns "number"
:doc "Sum all arguments. Returns integer iff all args are exact integers (float contagion)."
:doc "Sum all arguments."
:body (reduce (fn (a b) (native-add a b)) 0 args))
(define-primitive
"-"
:params ((a :as number) &rest (b :as number))
:returns "number"
:doc "Subtract. Unary: negate. Binary: a - b. Float contagion: returns integer iff all args are integers."
:doc "Subtract. Unary: negate. Binary: a - b."
:body (if (empty? b) (native-neg a) (native-sub a (first b))))
(define-primitive
"*"
:params (&rest (args :as number))
:returns "number"
:doc "Multiply all arguments. Float contagion: integer result iff all args are exact integers."
:doc "Multiply all arguments."
:body (reduce (fn (a b) (native-mul a b)) 1 args))
(define-primitive
"/"
:params ((a :as number) (b :as number))
:returns "float"
:doc "Divide a by b. Always returns inexact float."
:returns "number"
:doc "Divide a by b."
:body (native-div a b))
(define-primitive
"mod"
:params ((a :as number) (b :as number))
:returns "number"
:doc "Modulo a % b. Returns integer iff both args are integers."
:doc "Modulo a % b."
:body (native-mod a b))
(define-primitive
@@ -108,26 +108,26 @@
(define-primitive
"floor"
:params ((x :as number))
:returns "integer"
:doc "Floor toward negative infinity — returns exact integer.")
:returns "number"
:doc "Floor to integer.")
(define-primitive
"ceil"
:params ((x :as number))
:returns "integer"
:doc "Ceiling toward positive infinity — returns exact integer.")
:returns "number"
:doc "Ceiling to integer.")
(define-primitive
"round"
:params ((x :as number) &rest (ndigits :as number))
:returns "number"
:doc "Round to ndigits decimal places (default 0). Returns integer when ndigits is 0.")
:doc "Round to ndigits decimal places (default 0).")
(define-primitive
"truncate"
:params ((x :as number))
:returns "integer"
:doc "Truncate toward zero — returns exact integer.")
:params (((x :as number)))
:returns "number"
:doc "Truncate toward zero.")
(define-primitive
"remainder"
@@ -143,42 +143,42 @@
(define-primitive
"exact?"
:params ((x :as number))
:params (((x :as number)))
:returns "boolean"
:doc "True if x is an exact integer (not an inexact float).")
:doc "True if x is exact (integer-valued).")
(define-primitive
"inexact?"
:params ((x :as number))
:params (((x :as number)))
:returns "boolean"
:doc "True if x is an inexact float (not an exact integer).")
:doc "True if x is inexact (non-integer).")
;; --------------------------------------------------------------------------
;; Core — Comparison
;; --------------------------------------------------------------------------
(define-primitive
"exact->inexact"
:params ((x :as number))
:returns "float"
:doc "Convert exact integer to inexact float. Floats pass through unchanged.")
:params (((x :as number)))
:returns "number"
:doc "Convert exact to inexact (identity for float tower).")
(define-primitive
"inexact->exact"
:params ((x :as number))
:returns "integer"
:doc "Convert inexact float to nearest exact integer (truncates). Integers pass through unchanged.")
:params (((x :as number)))
:returns "number"
:doc "Convert inexact to nearest exact integer.")
(define-primitive
"make-vector"
:params ((n :as number) (fill :as any :optional true))
:params ((n :as number))
:returns "vector"
:doc "Create vector of length n, each element initialised to fill (default nil).")
:doc "Create vector of size n, optionally filled.")
(define-primitive
"vector"
:params (:rest (elts :as any))
:params ()
:returns "vector"
:doc "Construct a vector from its arguments.")
:doc "Create vector from arguments.")
(define-primitive
"vector?"
@@ -190,31 +190,31 @@
"vector-length"
:params ((v :as vector))
:returns "number"
:doc "Number of elements in vector v.")
:doc "Number of elements.")
(define-primitive
"vector-ref"
:params ((v :as vector) (i :as number))
:returns "any"
:doc "Element at 0-based index i. Error if out of bounds.")
:doc "Element at index.")
(define-primitive
"vector-set!"
:params ((v :as vector) (i :as number) (val :as any))
:returns "nil"
:doc "Mutate element at index i to val. Error if out of bounds.")
:doc "Set element at index.")
(define-primitive
"vector->list"
:params ((v :as vector))
:returns "list"
:doc "Convert vector to a fresh list.")
:doc "Convert vector to list.")
(define-primitive
"list->vector"
:params ((l :as list))
:returns "vector"
:doc "Convert list to a fresh vector.")
:doc "Convert list to vector.")
;; --------------------------------------------------------------------------
;; Core — Predicates
@@ -223,15 +223,13 @@
"vector-fill!"
:params ((v :as vector) (val :as any))
:returns "nil"
:doc "Set every element of v to val in place.")
:doc "Fill all elements.")
(define-primitive
"vector-copy"
:params ((v :as vector)
(start :as number :optional true)
(end :as number :optional true))
:params ((v :as vector))
:returns "vector"
:doc "Shallow copy of vector, optionally sliced from start (inclusive) to end (exclusive).")
:doc "Independent shallow copy.")
(define-primitive
"min"
@@ -374,20 +372,8 @@
"number?"
:params (x)
:returns "boolean"
:doc "True if x is any number — exact integer or inexact float."
:body (or (= (type-of x) "number") (integer? x)))
(define-primitive
"integer?"
:params (x)
:returns "boolean"
:doc "True if x is an exact integer, or a float with no fractional part (e.g. 1.0).")
(define-primitive
"float?"
:params (x)
:returns "boolean"
:doc "True if x is an inexact float (Number type). Does not match exact integers.")
:doc "True if x is a number (int or float)."
:body (= (type-of x) "number"))
(define-primitive
"string?"
@@ -492,12 +478,6 @@
:returns "string"
:doc "Convert Unicode code point to single-character string.")
(define-primitive
"char-code"
:params ((s :as string))
:returns "number"
:doc "Unicode codepoint of the first character of string s.")
(define-primitive
"substring"
:params ((s :as string) (start :as number) (end :as number))
@@ -552,15 +532,15 @@
:returns "boolean"
:doc "True if string s starts with prefix.")
;; --------------------------------------------------------------------------
;; Core — Dict operations
;; --------------------------------------------------------------------------
(define-primitive
"ends-with?"
:params ((s :as string) (suffix :as string))
:returns "boolean"
:doc "True if string s ends with suffix.")
;; --------------------------------------------------------------------------
;; Core — Dict operations
;; --------------------------------------------------------------------------
(define-module :core.collections)
(define-primitive
@@ -605,15 +585,15 @@
:returns "any"
:doc "Last element, or nil if empty.")
;; --------------------------------------------------------------------------
;; Stdlib — Format
;; --------------------------------------------------------------------------
(define-primitive
"rest"
:params ((coll :as list))
:returns "list"
:doc "All elements except the first.")
;; --------------------------------------------------------------------------
;; Stdlib — Format
;; --------------------------------------------------------------------------
(define-primitive
"nth"
:params ((coll :as list) (n :as number))
@@ -638,15 +618,15 @@
:returns "list"
:doc "Mutate coll by appending x in-place. Returns coll.")
;; --------------------------------------------------------------------------
;; Stdlib — Text
;; --------------------------------------------------------------------------
(define-primitive
"reverse"
:params ((coll :as list))
:returns "list"
:doc "Return coll in reverse order.")
;; --------------------------------------------------------------------------
;; Stdlib — Text
;; --------------------------------------------------------------------------
(define-primitive
"flatten"
:params ((coll :as list))
@@ -665,29 +645,29 @@
:returns "list"
:doc "Consecutive pairs: (1 2 3 4) → ((1 2) (2 3) (3 4)).")
(define-module :core.dict)
;; --------------------------------------------------------------------------
;; Stdlib — Style
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; Stdlib — Debug
;; --------------------------------------------------------------------------
(define-module :core.dict)
(define-primitive
"keys"
:params ((d :as dict))
:returns "list"
:doc "List of dict keys.")
;; --------------------------------------------------------------------------
;; Type introspection — platform primitives
;; --------------------------------------------------------------------------
(define-primitive
"vals"
:params ((d :as dict))
:returns "list"
:doc "List of dict values.")
;; --------------------------------------------------------------------------
;; Type introspection — platform primitives
;; --------------------------------------------------------------------------
(define-primitive
"merge"
:params (&rest (dicts :as dict))
@@ -803,532 +783,3 @@
:params ((source :as string))
:returns "list"
:doc "Parse SX source string into a list of AST expressions.")
(define-primitive
"make-string-buffer"
:params ()
:returns "string-buffer"
:doc "Create a new empty mutable string buffer for O(1) amortised append.")
(define-module :stdlib.coroutines)
(define-module :stdlib.bitwise)
(define-primitive
"bitwise-and"
:params (((a :as number) (b :as number)))
:returns "number"
:doc "Bitwise AND of two integers.")
(define-primitive
"bitwise-or"
:params (((a :as number) (b :as number)))
:returns "number"
:doc "Bitwise OR of two integers.")
(define-primitive
"bitwise-xor"
:params (((a :as number) (b :as number)))
:returns "number"
:doc "Bitwise XOR of two integers.")
(define-primitive
"bitwise-not"
:params ((a :as number))
:returns "number"
:doc "Bitwise NOT (one's complement) of an integer.")
(define-primitive
"arithmetic-shift"
:params (((a :as number) (count :as number)))
:returns "number"
:doc "Arithmetic shift: left if count > 0, right if count < 0.")
(define-primitive
"bit-count"
:params ((a :as number))
:returns "number"
:doc "Count set bits (popcount) in a non-negative integer.")
(define-primitive
"integer-length"
:params ((a :as number))
:returns "number"
:doc "Number of bits needed to represent integer a (excluding sign).")
(define-module :stdlib.ports)
(define-primitive
"eof-object"
:params ()
:returns "eof-object"
:doc "The EOF sentinel value.")
(define-primitive
"eof-object?"
:params (v)
:returns "boolean"
:doc "True if v is the EOF sentinel.")
(define-primitive
"open-input-string"
:params ((s :as string))
:returns "input-port"
:doc "Open a string as an input port.")
(define-primitive
"open-output-string"
:params ()
:returns "output-port"
:doc "Open a fresh output string port.")
(define-primitive
"get-output-string"
:params ((p :as output-port))
:returns "string"
:doc "Flush output port contents to a string.")
(define-primitive
"port?"
:params (v)
:returns "boolean"
:doc "True if v is any port.")
(define-primitive
"input-port?"
:params (v)
:returns "boolean"
:doc "True if v is an input port.")
(define-primitive
"output-port?"
:params (v)
:returns "boolean"
:doc "True if v is an output port.")
(define-primitive
"close-port"
:params ((p :as port))
:returns "nil"
:doc "Close a port.")
(define-primitive
"read-char"
:params (&rest (p :as input-port))
:returns "any"
:doc "Read next char from port; returns eof-object at end.")
(define-primitive
"peek-char"
:params (&rest (p :as input-port))
:returns "any"
:doc "Peek next char without consuming; returns eof-object at end.")
(define-primitive
"read-line"
:params (&rest (p :as input-port))
:returns "any"
:doc "Read a line from port; returns eof-object at end.")
(define-primitive
"write-char"
:params ((c :as char) &rest (p :as output-port))
:returns "nil"
:doc "Write a char to output port.")
(define-primitive
"write-string"
:params ((s :as string) &rest (p :as output-port))
:returns "nil"
:doc "Write a string to output port.")
(define-primitive
"char-ready?"
:params (&rest (p :as input-port))
:returns "boolean"
:doc "True if a char is immediately available on the port.")
(define-primitive
"read"
:params (&rest (p :as input-port))
:returns "any"
:doc "Read one datum from port; returns eof-object at end.")
(define-primitive
"write"
:params (v &rest (p :as output-port))
:returns "nil"
:doc "Serialize v to port with quoting — strings quoted, chars as #\\a notation.")
(define-primitive
"display"
:params (v &rest (p :as output-port))
:returns "nil"
:doc "Serialize v to port without quoting — strings unquoted, chars as characters.")
(define-primitive
"newline"
:params (&rest (p :as output-port))
:returns "nil"
:doc "Write a newline to port.")
(define-primitive
"write-to-string"
:params (v)
:returns "string"
:doc "Serialize v with write quoting, return as string.")
(define-primitive
"display-to-string"
:params (v)
:returns "string"
:doc "Serialize v with display format, return as string.")
(define-primitive
"current-input-port"
:params ()
:returns "any"
:doc "Return current default input port.")
(define-primitive
"current-output-port"
:params ()
:returns "any"
:doc "Return current default output port.")
(define-primitive
"current-error-port"
:params ()
:returns "any"
:doc "Return current error port.")
(define-module :stdlib.math)
(define-primitive
"sin"
:params ((x :as number))
:returns "float"
:doc "Sine of x (radians).")
(define-primitive
"cos"
:params ((x :as number))
:returns "float"
:doc "Cosine of x (radians).")
(define-primitive
"tan"
:params ((x :as number))
:returns "float"
:doc "Tangent of x (radians).")
(define-primitive
"asin"
:params ((x :as number))
:returns "float"
:doc "Arc sine of x; result in radians.")
(define-primitive
"acos"
:params ((x :as number))
:returns "float"
:doc "Arc cosine of x; result in radians.")
(define-primitive
"atan"
:params ((x :as number) &rest (y :as number))
:returns "float"
:doc "Arc tangent. (atan x) → radians in (-π/2, π/2). (atan y x) → atan2(y, x).")
(define-primitive
"exp"
:params ((x :as number))
:returns "float"
:doc "e raised to the power x.")
(define-primitive
"log"
:params ((x :as number))
:returns "float"
:doc "Natural logarithm of x.")
(define-primitive
"expt"
:params ((base :as number) (exp :as number))
:returns "number"
:doc "base raised to the power exp. Alias: pow.")
(define-primitive
"quotient"
:params ((a :as number) (b :as number))
:returns "integer"
:doc "Integer quotient: truncate(a / b) toward zero. Sign follows dividend.")
(define-primitive
"gcd"
:params ((a :as number) (b :as number))
:returns "integer"
:doc "Greatest common divisor of a and b.")
(define-primitive
"lcm"
:params ((a :as number) (b :as number))
:returns "integer"
:doc "Least common multiple of a and b.")
(define-primitive
"number->string"
:params ((n :as number) &rest (radix :as number))
:returns "string"
:doc "Convert number n to string. Optional radix (default 10). E.g. (number->string 255 16) → \"ff\".")
(define-primitive
"string->number"
:params ((s :as string) &rest (radix :as number))
:returns "any"
:doc "Parse string s as a number. Optional radix (default 10). Returns nil on failure.")
(define-module :stdlib.rational)
(define-primitive
"make-rational"
:params (n d)
:returns "rational"
:doc "Rational n/d, auto-reduced by GCD. Error if d=0.")
(define-primitive
"rational?"
:params (v)
:returns "boolean"
:doc "True if v is a rational number.")
(define-primitive
"numerator"
:params ((r :as rational))
:returns "integer"
:doc "Numerator of rational r (after reduction).")
(define-primitive
"denominator"
:params ((r :as rational))
:returns "integer"
:doc "Denominator of rational r (after reduction, always positive).")
(define-module :stdlib.hash-table)
(define-module :stdlib.sets)
(define-primitive
"make-set"
:params (&rest (lst :as list))
:returns "set"
:doc "Create a fresh empty set. Optional list argument seeds the set: (make-set '(1 2 3)).")
(define-primitive
"set?"
:params (v)
:returns "boolean"
:doc "True if v is a set.")
(define-primitive
"set-add!"
:params (s val)
:returns "nil"
:doc "Add val to set s in place. No-op if already present.")
(define-primitive
"set-member?"
:params (s val)
:returns "boolean"
:doc "True if val is in set s.")
(define-primitive
"set-remove!"
:params (s val)
:returns "nil"
:doc "Remove val from set s in place. No-op if absent.")
(define-primitive
"set-size"
:params (s)
:returns "integer"
:doc "Number of elements in set s.")
(define-primitive
"set->list"
:params (s)
:returns "list"
:doc "All elements of set s as a list (unspecified order).")
(define-primitive
"list->set"
:params (lst)
:returns "set"
:doc "Create a new set containing all elements of lst.")
(define-primitive
"set-union"
:params (s1 s2)
:returns "set"
:doc "New set with all elements from s1 and s2.")
(define-primitive
"set-intersection"
:params (s1 s2)
:returns "set"
:doc "New set with elements present in both s1 and s2.")
(define-primitive
"set-difference"
:params (s1 s2)
:returns "set"
:doc "New set with elements in s1 that are not in s2.")
(define-primitive
"set-for-each"
:params (s fn)
:returns "nil"
:doc "Call (fn val) for each element in set s. Order unspecified.")
(define-primitive
"set-map"
:params (s fn)
:returns "set"
:doc "New set of results of (fn val) for each element in s.")
(define-module :stdlib.regexp)
(define-primitive
"make-regexp"
:params ((pattern :as string) &rest (flags :as string))
:returns "regexp"
:doc "Compile regexp from pattern string and optional flags string (\"i\" case-insensitive, \"m\" multiline, \"s\" dotall).")
(define-primitive
"regexp?"
:params (v)
:returns "boolean"
:doc "True if v is a compiled regexp.")
(define-primitive
"regexp-source"
:params ((re :as regexp))
:returns "string"
:doc "Pattern string of a regexp.")
(define-primitive
"regexp-flags"
:params ((re :as regexp))
:returns "string"
:doc "Flags string of a regexp.")
(define-primitive
"regexp-match"
:params ((re :as regexp) (str :as string))
:returns "any"
:doc "First match of re in str. Returns {:match \"...\" :start N :end N :groups (...)} or nil.")
(define-primitive
"regexp-match-all"
:params ((re :as regexp) (str :as string))
:returns "list"
:doc "All non-overlapping matches of re in str as a list of match dicts.")
(define-primitive
"regexp-replace"
:params ((re :as regexp) (str :as string) (replacement :as string))
:returns "string"
:doc "Replace first match of re in str with replacement. $& = whole match, $1..$9 = groups.")
(define-primitive
"regexp-replace-all"
:params ((re :as regexp) (str :as string) (replacement :as string))
:returns "string"
:doc "Replace all matches of re in str with replacement.")
(define-primitive
"regexp-split"
:params ((re :as regexp) (str :as string))
:returns "list"
:doc "Split str on every match of re; returns list of strings.")
(define-module :stdlib.bytevectors)
(define-primitive
"make-bytevector"
:params (n &rest fill)
:returns "bytevector"
:doc "Create a bytevector of n bytes, all initialised to fill (default 0).")
(define-primitive
"bytevector?"
:params (v)
:returns "boolean"
:doc "True if v is a bytevector.")
(define-primitive
"bytevector-length"
:params ((bv :as bytevector))
:returns "number"
:doc "Number of bytes in bv.")
(define-primitive
"bytevector-u8-ref"
:params ((bv :as bytevector) (i :as number))
:returns "number"
:doc "Byte value 0-255 at index i.")
(define-primitive
"bytevector-u8-set!"
:params ((bv :as bytevector) (i :as number) (byte :as number))
:returns "nil"
:doc "Set byte at index i to byte 0-255. Mutates bv.")
(define-primitive
"bytevector-copy"
:params ((bv :as bytevector) &rest bounds)
:returns "bytevector"
:doc "Fresh copy of bv, optionally sliced to [start, end).")
(define-primitive
"bytevector-copy!"
:params ((dst :as bytevector) (at :as number) (src :as bytevector) &rest bounds)
:returns "nil"
:doc "Copy bytes from src[start..end) into dst starting at at. Mutates dst.")
(define-primitive
"bytevector-append"
:params (&rest bvs)
:returns "bytevector"
:doc "Concatenate bytevectors into a new bytevector.")
(define-primitive
"utf8->string"
:params ((bv :as bytevector) &rest bounds)
:returns "string"
:doc "Decode bv[start..end) as UTF-8 and return the string.")
(define-primitive
"string->utf8"
:params ((s :as string) &rest bounds)
:returns "bytevector"
:doc "Encode s[start..end) as UTF-8 and return a bytevector.")
(define-primitive
"bytevector->list"
:params ((bv :as bytevector))
:returns "list"
:doc "Convert bytevector to a list of byte integers.")
(define-primitive
"list->bytevector"
:params ((lst :as list))
:returns "bytevector"
:doc "Build a bytevector from a list of byte integers 0-255.")
(define-primitive
"format"
:params ((template :as string) &rest args)
:returns "string"
:doc "CL-style format string. Directives: ~a display, ~s write, ~d decimal, ~x hex, ~o octal, ~b binary, ~f fixed-point, ~e scientific, ~% newline, ~& fresh-line, ~~ tilde, ~t tab. Optional first arg: output-port.")

View File

@@ -1,134 +0,0 @@
;; ==========================================================================
;; stdlib.sx — Pure SX standard library functions
;;
;; Loaded by test runners after primitives. These functions are implemented
;; in SX and require no host-specific code.
;;
;; IMPORTANT: SX let/when bodies evaluate only the LAST expression.
;; Multi-step bodies must be wrapped in (do expr1 expr2 ...).
;; ==========================================================================
;; --------------------------------------------------------------------------
;; format — CL-style string formatting
;;
;; Directives:
;; ~a display (no quotes) ~s write (with quotes)
;; ~d decimal ~x hex ~o octal ~b binary
;; ~f fixed-point (6dp) ~% newline
;; ~& fresh line ~~ literal tilde
;; ~t tab
;;
;; Signature: (format template arg...) -> string
;; --------------------------------------------------------------------------
(define
(format template &rest args)
(let
((buf (make-string-buffer)) (n (string-length template)))
(define
(consume-arg args)
(if
(nil? args)
(list "" nil)
(list (display-to-string (first args)) (rest args))))
(define
(consume-num args radix)
(if
(nil? args)
(list "" nil)
(list (number->string (first args) radix) (rest args))))
(define
(loop i args)
(cond
((>= i n) (string-buffer->string buf))
((and (= (substring template i (+ i 1)) "~") (< (+ i 1) n))
(let
((dir (substring template (+ i 1) (+ i 2))))
(cond
((= dir "a")
(let
((p (consume-arg args)))
(do
(string-buffer-append! buf (first p))
(loop (+ i 2) (first (rest p))))))
((= dir "s")
(if
(nil? args)
(loop (+ i 2) args)
(do
(string-buffer-append!
buf
(write-to-string (first args)))
(loop (+ i 2) (rest args)))))
((= dir "d")
(let
((p (consume-num args 10)))
(do
(string-buffer-append! buf (first p))
(loop (+ i 2) (first (rest p))))))
((= dir "x")
(let
((p (consume-num args 16)))
(do
(string-buffer-append! buf (first p))
(loop (+ i 2) (first (rest p))))))
((= dir "o")
(let
((p (consume-num args 8)))
(do
(string-buffer-append! buf (first p))
(loop (+ i 2) (first (rest p))))))
((= dir "b")
(let
((p (consume-num args 2)))
(do
(string-buffer-append! buf (first p))
(loop (+ i 2) (first (rest p))))))
((= dir "f")
(if
(nil? args)
(loop (+ i 2) args)
(do
(string-buffer-append!
buf
(format-decimal (first args) 6))
(loop (+ i 2) (rest args)))))
((= dir "%")
(do
(string-buffer-append! buf "\n")
(loop (+ i 2) args)))
((= dir "&")
(do
(let
((so-far (string-buffer->string buf)))
(when
(or
(= (string-length so-far) 0)
(not
(=
(substring
so-far
(- (string-length so-far) 1)
(string-length so-far))
"\n")))
(string-buffer-append! buf "\n")))
(loop (+ i 2) args)))
((= dir "~")
(do
(string-buffer-append! buf "~")
(loop (+ i 2) args)))
((= dir "t")
(do
(string-buffer-append! buf "\t")
(loop (+ i 2) args)))
(else
(do
(string-buffer-append! buf "~")
(loop (+ i 1) args))))))
(else
(do
(string-buffer-append!
buf
(substring template i (+ i 1)))
(loop (+ i 1) args)))))
(loop 0 args)))

View File

@@ -1,278 +0,0 @@
(defsuite
"algebraic-data-types"
(deftest
"constructor creates dict with adt marker"
(do
(define-type Maybe (Just value) (Nothing))
(assert= true (get (Just 42) :_adt))))
(deftest
"constructor stores type name"
(do
(define-type Shape (Circle radius) (Square side))
(assert= "Shape" (get (Circle 5) :_type))
(assert= "Shape" (get (Square 3) :_type))))
(deftest
"constructor stores constructor name"
(do
(define-type Opt (Some val) (None))
(assert= "Some" (get (Some 1) :_ctor))
(assert= "None" (get (None) :_ctor))))
(deftest
"constructor stores fields as list"
(do
(define-type Pair (Pair-of fst snd))
(assert-equal
(list 1 2)
(get (Pair-of 1 2) :_fields))))
(deftest
"zero-arg constructor has empty fields"
(do
(define-type Flag (Set) (Unset))
(assert-equal (list) (get (Set) :_fields))
(assert-equal (list) (get (Unset) :_fields))))
(deftest
"type predicate true for all constructors"
(do
(define-type Expr (Num n) (Add left right) (Neg e))
(assert= true (Expr? (Num 5)))
(assert= true (Expr? (Add (Num 1) (Num 2))))
(assert= true (Expr? (Neg (Num 3))))))
(deftest
"type predicate false for non-adt values"
(do
(define-type Box (Box-of x))
(assert= false (Box? 42))
(assert= false (Box? "hello"))
(assert= false (Box? nil))
(assert= false (Box? (list 1 2)))
(assert= false (Box? {}))))
(deftest
"type predicate false for wrong adt type"
(do
(define-type AT (AV x))
(define-type BT (BV x))
(assert= false (AT? (BV 1)))
(assert= false (BT? (AV 1)))))
(deftest
"constructor predicate true for matching constructor"
(do
(define-type Result (Ok value) (Err msg))
(assert= true (Ok? (Ok 42)))
(assert= true (Err? (Err "bad")))))
(deftest
"constructor predicate false for wrong constructor"
(do
(define-type Coin (Heads) (Tails))
(assert= false (Heads? (Tails)))
(assert= false (Tails? (Heads)))))
(deftest
"constructor predicate false for non-adt"
(do
(define-type Wrap (Wrapped x))
(assert= false (Wrapped? 42))
(assert= false (Wrapped? nil))
(assert= false (Wrapped? "str"))))
(deftest
"single-field accessor returns field value"
(do
(define-type Holder (Held content))
(assert= 99 (Held-content (Held 99)))
(assert= "hello" (Held-content (Held "hello")))))
(deftest
"multi-field accessors return correct fields"
(do
(define-type Triple (Triple-of a b c))
(let
((t (Triple-of 10 20 30)))
(assert= 10 (Triple-of-a t))
(assert= 20 (Triple-of-b t))
(assert= 30 (Triple-of-c t)))))
(deftest
"tree constructors and accessors"
(do
(define-type Tree (Leaf) (Node left val right))
(let
((t (Node (Leaf) 5 (Node (Leaf) 3 (Leaf)))))
(assert= true (Node? t))
(assert= 5 (Node-val t))
(assert= true (Leaf? (Node-left t)))
(assert= true (Node? (Node-right t)))
(assert= 3 (Node-val (Node-right t))))))
(deftest
"arity error on too few args"
(do
(define-type Pair2 (Pair2-of a b))
(let
((ok false))
(guard (exn (else (set! ok true))) (Pair2-of 1))
(assert ok))))
(deftest
"arity error on too many args"
(do
(define-type Single (Single-of x))
(let
((ok false))
(guard
(exn (else (set! ok true)))
(Single-of 1 2))
(assert ok))))
(deftest
"multiple types are independent"
(do
(define-type Color2 (Red2) (Green2) (Blue2))
(define-type Suit (Hearts) (Diamonds) (Clubs) (Spades))
(assert= false (Color2? (Hearts)))
(assert= false (Suit? (Red2)))
(assert= true (Color2? (Blue2)))
(assert= true (Suit? (Spades)))))
(deftest
"adt fields can hold any value"
(do
(define-type Container (Hold x))
(assert-equal
(list 1 2 3)
(Hold-x (Hold (list 1 2 3))))
(assert-equal {:a 1} (Hold-x (Hold {:a 1})))))
(deftest
"adt-registry tracks type constructor names"
(do
(define-type Days (Mon) (Tue) (Wed) (Thu) (Fri))
(assert-equal
(list "Mon" "Tue" "Wed" "Thu" "Fri")
(get *adt-registry* "Days"))))
(deftest
"constructors with same field name in different types are independent"
(do
(define-type P1 (P1-ctor value))
(define-type P2 (P2-ctor value))
(assert= 10 (P1-ctor-value (P1-ctor 10)))
(assert= 20 (P2-ctor-value (P2-ctor 20)))))
(deftest
"match dispatches on first matching constructor"
(do
(define-type Color (Red) (Green) (Blue))
(assert= "red" (match (Red) ((Red) "red") ((Green) "green") ((Blue) "blue")))
(assert= "green" (match (Green) ((Red) "red") ((Green) "green") ((Blue) "blue")))
(assert= "blue" (match (Blue) ((Red) "red") ((Green) "green") ((Blue) "blue")))))
(deftest
"match binds field to variable"
(do
(define-type Wrapper (Wrap val))
(assert= 42 (match (Wrap 42) ((Wrap v) v)))
(assert= "hi" (match (Wrap "hi") ((Wrap v) v)))))
(deftest
"match zero-arg constructor"
(do
(define-type Signal (On) (Off))
(assert= "on" (match (On) ((On) "on") ((Off) "off")))
(assert= "off" (match (Off) ((On) "on") ((Off) "off")))))
(deftest
"match multi-field constructor binds all fields"
(do
(define-type Vec2 (V2 x y))
(let ((v (V2 3 4)))
(assert= 7 (match v ((V2 a b) (+ a b)))))))
(deftest
"match with else clause"
(do
(define-type Opt2 (Some2 val) (None2))
(assert= 10 (match (Some2 10) ((Some2 v) v) (else 0)))
(assert= 0 (match (None2) ((Some2 v) v) (else 0)))))
(deftest
"match else catches non-adt values"
(do
(assert= "other" (match 42 ((else) "other") (else "other")))
(assert= "other" (match "str" (else "other")))))
(deftest
"match returns body expression value"
(do
(define-type Num (Num-of n))
(assert= 100 (match (Num-of 10) ((Num-of n) (* n n))))))
(deftest
"match second arm fires when first does not match"
(do
(define-type Either (Left val) (Right val))
(assert= "left-1" (match (Left 1) ((Left v) (str "left-" v)) ((Right v) (str "right-" v))))
(assert= "right-2" (match (Right 2) ((Left v) (str "left-" v)) ((Right v) (str "right-" v))))))
(deftest
"match wildcard _ in constructor pattern"
(do
(define-type Pair3 (Pair3-of a b))
(assert= 5 (match (Pair3-of 5 99) ((Pair3-of x _) x)))
(assert= 99 (match (Pair3-of 5 99) ((Pair3-of _ y) y)))))
(deftest
"match nested adt constructor pattern"
(do
(define-type Tree2 (Leaf2) (Node2 left val right))
(let ((t (Node2 (Leaf2) 7 (Leaf2))))
(assert= 7 (match t ((Node2 _ v _) v)))
(assert= true (match t ((Node2 (Leaf2) _ _) true) (else false))))))
(deftest
"match literal pattern"
(do
(assert= "zero" (match 0 (0 "zero") (else "nonzero")))
(assert= "hello" (match "hello" ("hello" "hello") (else "other")))))
(deftest
"match symbol binding pattern"
(do
(assert= 42 (match 42 (x x)))))
(deftest
"match no matching clause raises error"
(do
(define-type AB (A-val) (B-val))
(let ((ok false))
(guard (exn (else (set! ok true)))
(match (A-val) ((B-val) "b")))
(assert ok))))
(deftest
"match result used in further computation"
(do
(define-type Num2 (N v))
(assert= 30
(+
(match (N 10) ((N v) v))
(match (N 20) ((N v) v))))))
(deftest
"match with define"
(do
(define-type Tag (Tagged label value))
(define get-label (fn (t) (match t ((Tagged lbl _) lbl))))
(define get-value (fn (t) (match t ((Tagged _ val) val))))
(let ((t (Tagged "name" 99)))
(assert= "name" (get-label t))
(assert= 99 (get-value t)))))
(deftest
"match three-field constructor"
(do
(define-type Triple2 (T3 a b c))
(assert= 6 (match (T3 1 2 3) ((T3 a b c) (+ a b c))))))
(deftest
"match clauses tried in order"
(do
(define-type Expr2 (Lit n) (Add l r) (Mul l r))
(define eval-expr2 (fn (e)
(match e
((Lit n) n)
((Add l r) (+ (eval-expr2 l) (eval-expr2 r)))
((Mul l r) (* (eval-expr2 l) (eval-expr2 r))))))
(assert= 7 (eval-expr2 (Add (Lit 3) (Lit 4))))
(assert= 12 (eval-expr2 (Mul (Lit 3) (Lit 4))))
(assert= 11 (eval-expr2 (Add (Lit 2) (Mul (Lit 3) (Lit 3)))))))
(deftest
"match else binding captures value"
(do
(define-type Coin2 (Heads2) (Tails2))
(assert= "Tails2" (match (Tails2) ((Heads2) "Heads2") (x (get x :_ctor))))))
(deftest
"match on adt with string field"
(do
(define-type Msg (Hello name) (Bye name))
(assert= "Hello, Alice" (match (Hello "Alice") ((Hello n) (str "Hello, " n)) ((Bye n) (str "Bye, " n))))
(assert= "Bye, Bob" (match (Bye "Bob") ((Hello n) (str "Hello, " n)) ((Bye n) (str "Bye, " n))))))
(deftest
"match nested pattern with variable binding"
(do
(define-type Box2 (Box2-of v))
(define-type Inner (Inner-of n))
(assert= 5 (match (Box2-of (Inner-of 5)) ((Box2-of (Inner-of n)) n)))))
)

View File

@@ -1,157 +0,0 @@
(defsuite
"bitwise-operations"
(deftest
"bitwise-and basic"
(do
(assert= 0 (bitwise-and 0 0))
(assert= 1 (bitwise-and 3 1))
(assert= 0 (bitwise-and 5 2))
(assert= 4 (bitwise-and 12 6))))
(deftest
"bitwise-and identity and zero"
(do
(assert= 255 (bitwise-and 255 255))
(assert= 0 (bitwise-and 255 0))))
(deftest
"bitwise-or basic"
(do
(assert= 0 (bitwise-or 0 0))
(assert= 3 (bitwise-or 1 2))
(assert= 7 (bitwise-or 5 3))
(assert= 15 (bitwise-or 9 6))))
(deftest
"bitwise-or identity"
(do
(assert= 255 (bitwise-or 255 0))
(assert= 255 (bitwise-or 0 255))))
(deftest
"bitwise-xor basic"
(do
(assert= 0 (bitwise-xor 0 0))
(assert= 3 (bitwise-xor 1 2))
(assert= 6 (bitwise-xor 3 5))
(assert= 0 (bitwise-xor 255 255))))
(deftest
"bitwise-xor toggle bits"
(do
(assert= 14 (bitwise-xor 10 4))
(assert= 10 (bitwise-xor 14 4))))
(deftest
"bitwise-not zero"
(do (assert= -1 (bitwise-not 0))))
(deftest
"bitwise-not positive"
(do
(assert= -2 (bitwise-not 1))
(assert= -5 (bitwise-not 4))
(assert= -256 (bitwise-not 255))))
(deftest
"bitwise-not negative"
(do
(assert= 0 (bitwise-not -1))
(assert= 1 (bitwise-not -2))
(assert= 4 (bitwise-not -5))))
(deftest
"bitwise-not double negation"
(do
(assert= 42 (bitwise-not (bitwise-not 42)))
(assert= 0 (bitwise-not (bitwise-not 0)))))
(deftest
"arithmetic-shift left"
(do
(assert= 2 (arithmetic-shift 1 1))
(assert= 4 (arithmetic-shift 1 2))
(assert= 16 (arithmetic-shift 1 4))
(assert= 8 (arithmetic-shift 2 2))))
(deftest
"arithmetic-shift right"
(do
(assert= 1 (arithmetic-shift 2 -1))
(assert= 1 (arithmetic-shift 4 -2))
(assert= 5 (arithmetic-shift 10 -1))
(assert= 2 (arithmetic-shift 16 -3))))
(deftest
"arithmetic-shift by zero"
(do
(assert= 42 (arithmetic-shift 42 0))
(assert= 0 (arithmetic-shift 0 5))))
(deftest
"arithmetic-shift negative value right preserves sign"
(do
(assert= -1 (arithmetic-shift -1 -1))
(assert= -2 (arithmetic-shift -4 -1))))
(deftest
"bit-count zero"
(do (assert= 0 (bit-count 0))))
(deftest
"bit-count powers of two"
(do
(assert= 1 (bit-count 1))
(assert= 1 (bit-count 2))
(assert= 1 (bit-count 4))
(assert= 1 (bit-count 128))))
(deftest
"bit-count all-ones values"
(do
(assert= 8 (bit-count 255))
(assert= 4 (bit-count 15))
(assert= 2 (bit-count 3))))
(deftest
"bit-count mixed"
(do
(assert= 3 (bit-count 7))
(assert= 2 (bit-count 5))
(assert= 3 (bit-count 11))
(assert= 4 (bit-count 30))))
(deftest
"integer-length zero"
(do (assert= 0 (integer-length 0))))
(deftest
"integer-length powers of two"
(do
(assert= 1 (integer-length 1))
(assert= 2 (integer-length 2))
(assert= 3 (integer-length 4))
(assert= 4 (integer-length 8))
(assert= 8 (integer-length 128))))
(deftest
"integer-length non-powers"
(do
(assert= 2 (integer-length 3))
(assert= 3 (integer-length 5))
(assert= 3 (integer-length 7))
(assert= 8 (integer-length 255))
(assert= 9 (integer-length 256))))
(deftest
"bitwise ops compose"
(do
(assert=
5
(bitwise-and
(bitwise-or 5 3)
(bitwise-xor 7 2)))
(assert= 0 (bitwise-and 170 85))))
(deftest
"arithmetic-shift round-trip"
(do
(assert=
10
(arithmetic-shift (arithmetic-shift 10 3) -3))))
(deftest
"extract bits with mask"
(do
(let
((x 52))
(assert=
5
(bitwise-and (arithmetic-shift x -2) 7)))))
(deftest
"clear low bits with bitwise-not mask"
(do
(assert= 252 (bitwise-and 255 (bitwise-not 3)))))
(deftest
"integer-length after shift"
(do
(assert=
4
(integer-length (arithmetic-shift 1 3))))))

View File

@@ -1,236 +0,0 @@
;; ==========================================================================
;; test-bytevectors.sx — Tests for bytevector primitives
;; ==========================================================================
;; --------------------------------------------------------------------------
;; make-bytevector / bytevector?
;; --------------------------------------------------------------------------
(defsuite
"bv:create"
(deftest
"make-bytevector returns bytevector"
(assert (bytevector? (make-bytevector 4))))
(deftest
"make-bytevector zeroes by default"
(let
((bv (make-bytevector 3)))
(assert
(and
(= (bytevector-u8-ref bv 0) 0)
(= (bytevector-u8-ref bv 1) 0)
(= (bytevector-u8-ref bv 2) 0)))))
(deftest
"make-bytevector with fill"
(let
((bv (make-bytevector 3 42)))
(assert
(and
(= (bytevector-u8-ref bv 0) 42)
(= (bytevector-u8-ref bv 1) 42)
(= (bytevector-u8-ref bv 2) 42)))))
(deftest
"make-bytevector length 0"
(assert= (bytevector-length (make-bytevector 0)) 0))
(deftest
"bytevector? true for bytevector"
(assert (bytevector? (make-bytevector 2))))
(deftest
"bytevector? false for string"
(assert (not (bytevector? "hello"))))
(deftest "bytevector? false for nil" (assert (not (bytevector? nil))))
(deftest
"bytevector? false for list"
(assert (not (bytevector? (list 1 2 3))))))
;; --------------------------------------------------------------------------
;; bytevector-length / u8-ref / u8-set!
;; --------------------------------------------------------------------------
(defsuite
"bv:access"
(deftest
"bytevector-length"
(assert= (bytevector-length (make-bytevector 5)) 5))
(deftest
"u8-ref reads fill byte"
(assert=
(bytevector-u8-ref (make-bytevector 4 99) 2)
99))
(deftest
"u8-set! mutates"
(let
((bv (make-bytevector 3 0)))
(bytevector-u8-set! bv 1 200)
(assert= (bytevector-u8-ref bv 1) 200)))
(deftest
"u8-set! boundary byte 255"
(let
((bv (make-bytevector 1 0)))
(bytevector-u8-set! bv 0 255)
(assert= (bytevector-u8-ref bv 0) 255)))
(deftest
"u8-set! byte 0"
(let
((bv (make-bytevector 1 255)))
(bytevector-u8-set! bv 0 0)
(assert= (bytevector-u8-ref bv 0) 0))))
;; --------------------------------------------------------------------------
;; bytevector-copy
;; --------------------------------------------------------------------------
(defsuite
"bv:copy"
(deftest
"copy produces equal content"
(let
((bv (make-bytevector 3 7)))
(let
((bv2 (bytevector-copy bv)))
(assert
(and
(= (bytevector-u8-ref bv2 0) 7)
(= (bytevector-u8-ref bv2 1) 7)
(= (bytevector-u8-ref bv2 2) 7))))))
(deftest
"copy is independent"
(let
((bv (make-bytevector 2 0)))
(let
((bv2 (bytevector-copy bv)))
(bytevector-u8-set! bv2 0 99)
(assert= (bytevector-u8-ref bv 0) 0))))
(deftest
"copy with start"
(let
((bv (list->bytevector (list 10 20 30 40))))
(let
((bv2 (bytevector-copy bv 2)))
(assert
(and
(= (bytevector-length bv2) 2)
(= (bytevector-u8-ref bv2 0) 30))))))
(deftest
"copy with start and end"
(let
((bv (list->bytevector (list 10 20 30 40))))
(let
((bv2 (bytevector-copy bv 1 3)))
(assert
(and
(= (bytevector-length bv2) 2)
(= (bytevector-u8-ref bv2 0) 20)
(= (bytevector-u8-ref bv2 1) 30)))))))
;; --------------------------------------------------------------------------
;; bytevector-copy!
;; --------------------------------------------------------------------------
(defsuite
"bv:copy-bang"
(deftest
"copy! overwrites dst region"
(let
((dst (make-bytevector 4 0)))
(let
((src (list->bytevector (list 1 2 3))))
(bytevector-copy! dst 1 src)
(assert
(and
(= (bytevector-u8-ref dst 0) 0)
(= (bytevector-u8-ref dst 1) 1)
(= (bytevector-u8-ref dst 2) 2)
(= (bytevector-u8-ref dst 3) 3))))))
(deftest
"copy! with src bounds"
(let
((dst (make-bytevector 2 0)))
(let
((src (list->bytevector (list 10 20 30 40))))
(bytevector-copy! dst 0 src 1 3)
(assert
(and
(= (bytevector-u8-ref dst 0) 20)
(= (bytevector-u8-ref dst 1) 30)))))))
;; --------------------------------------------------------------------------
;; bytevector-append
;; --------------------------------------------------------------------------
(defsuite
"bv:append"
(deftest
"append two bytevectors"
(let
((bv (bytevector-append (list->bytevector (list 1 2)) (list->bytevector (list 3 4)))))
(assert
(and
(= (bytevector-length bv) 4)
(= (bytevector-u8-ref bv 0) 1)
(= (bytevector-u8-ref bv 3) 4)))))
(deftest
"append three bytevectors"
(let
((bv (bytevector-append (list->bytevector (list 1)) (list->bytevector (list 2)) (list->bytevector (list 3)))))
(assert= (bytevector-length bv) 3)))
(deftest
"append empty"
(assert=
(bytevector-length
(bytevector-append
(make-bytevector 0)
(make-bytevector 0)))
0)))
;; --------------------------------------------------------------------------
;; list->bytevector / bytevector->list
;; --------------------------------------------------------------------------
(defsuite
"bv:conversion"
(deftest
"list->bytevector roundtrip"
(let
((lst (list 10 20 30)))
(assert= (bytevector->list (list->bytevector lst)) lst)))
(deftest
"list->bytevector empty"
(assert= (bytevector-length (list->bytevector nil)) 0))
(deftest
"bytevector->list from make-bytevector"
(let
((lst (bytevector->list (make-bytevector 3 5))))
(assert= lst (list 5 5 5)))))
;; --------------------------------------------------------------------------
;; utf8 roundtrip
;; --------------------------------------------------------------------------
(defsuite
"bv:utf8"
(deftest
"string->utf8 returns bytevector"
(assert (bytevector? (string->utf8 "hello"))))
(deftest
"string->utf8 length"
(assert= (bytevector-length (string->utf8 "abc")) 3))
(deftest
"utf8->string roundtrip"
(assert= (utf8->string (string->utf8 "hello")) "hello"))
(deftest
"utf8->string with slice"
(let
((bv (string->utf8 "hello")))
(assert= (utf8->string bv 1 4) "ell")))
(deftest
"string->utf8 with start"
(assert= (utf8->string (string->utf8 "hello" 2)) "llo"))
(deftest
"string->utf8 with start and end"
(assert=
(utf8->string (string->utf8 "hello" 1 4))
"ell"))
(deftest
"empty string round-trips"
(assert= (utf8->string (string->utf8 "")) "")))

View File

@@ -1,185 +0,0 @@
;; Tests for character type (Phase 13)
;; Uses (make-char n) and (char-code "x") instead of #\x literals
;; (char literal parser syntax tested via sx-parse call)
(deftest
"make-char produces a char"
(assert= true (char? (make-char 97))))
(deftest "char? false for string" (assert= false (char? "a")))
(deftest "char? false for number" (assert= false (char? 65)))
(deftest "char? false for nil" (assert= false (char? nil)))
(deftest
"char->integer extracts codepoint"
(assert= 97 (char->integer (make-char 97))))
(deftest
"integer->char alias for make-char"
(assert= 65 (char->integer (integer->char 65))))
(deftest
"char->integer round-trip"
(assert= 122 (char->integer (make-char 122))))
(deftest
"char=? equal"
(assert= true (char=? (make-char 97) (make-char 97))))
(deftest
"char=? unequal"
(assert= false (char=? (make-char 97) (make-char 98))))
(deftest
"char<? ordering"
(assert= true (char<? (make-char 97) (make-char 98))))
(deftest
"char>? ordering"
(assert= true (char>? (make-char 98) (make-char 97))))
(deftest
"char<=? equal"
(assert= true (char<=? (make-char 65) (make-char 65))))
(deftest
"char>=? greater"
(assert= true (char>=? (make-char 90) (make-char 65))))
(deftest
"char-ci=? ignores case (a vs A)"
(assert= true (char-ci=? (make-char 97) (make-char 65))))
(deftest
"char-ci<? a < b case-insensitive"
(assert= true (char-ci<? (make-char 97) (make-char 98))))
(deftest
"char-ci>? b > a case-insensitive"
(assert= true (char-ci>? (make-char 66) (make-char 65))))
(deftest
"char-alphabetic? true for a"
(assert= true (char-alphabetic? (make-char 97))))
(deftest
"char-alphabetic? true for Z"
(assert= true (char-alphabetic? (make-char 90))))
(deftest
"char-alphabetic? false for digit"
(assert= false (char-alphabetic? (make-char 48))))
(deftest
"char-numeric? true for 0"
(assert= true (char-numeric? (make-char 48))))
(deftest
"char-numeric? true for 9"
(assert= true (char-numeric? (make-char 57))))
(deftest
"char-numeric? false for letter"
(assert= false (char-numeric? (make-char 65))))
(deftest
"char-whitespace? true for space"
(assert= true (char-whitespace? (make-char 32))))
(deftest
"char-whitespace? true for newline"
(assert= true (char-whitespace? (make-char 10))))
(deftest
"char-whitespace? false for letter"
(assert= false (char-whitespace? (make-char 65))))
(deftest
"char-upper-case? true for A"
(assert= true (char-upper-case? (make-char 65))))
(deftest
"char-upper-case? false for a"
(assert= false (char-upper-case? (make-char 97))))
(deftest
"char-lower-case? true for a"
(assert= true (char-lower-case? (make-char 97))))
(deftest
"char-lower-case? false for A"
(assert= false (char-lower-case? (make-char 65))))
(deftest
"char-upcase converts a to A"
(assert= 65 (char->integer (char-upcase (make-char 97)))))
(deftest
"char-downcase converts A to a"
(assert=
97
(char->integer (char-downcase (make-char 65)))))
(deftest
"char-upcase idempotent on uppercase"
(assert= 65 (char->integer (char-upcase (make-char 65)))))
(deftest
"string->list returns list of chars"
(assert= 3 (len (string->list "abc"))))
(deftest
"string->list element 0 is char"
(assert= true (char? (get (string->list "abc") 0))))
(deftest
"string->list codepoints correct"
(assert= 97 (char->integer (get (string->list "abc") 0))))
(deftest
"list->string from chars produces string"
(assert=
"abc"
(list->string
(list
(make-char 97)
(make-char 98)
(make-char 99)))))
(deftest
"string->list list->string round-trip"
(let ((s "hello")) (assert= s (list->string (string->list s)))))
(deftest
"char literal parsed via sx-parse"
(let
((ast (sx-parse "#\\a")))
(assert= true (char? (get ast 0)))))
(deftest
"char literal codepoint via sx-parse"
(let
((ast (sx-parse "#\\a")))
(assert= 97 (char->integer (get ast 0)))))
(deftest
"named char space via sx-parse"
(let
((ast (sx-parse "#\\space")))
(assert= 32 (char->integer (get ast 0)))))
(deftest
"named char newline via sx-parse"
(let
((ast (sx-parse "#\\newline")))
(assert= 10 (char->integer (get ast 0)))))
(deftest
"char-ci<=? equal case-insensitive"
(assert= true (char-ci<=? (make-char 65) (make-char 97))))
(deftest
"char-ci>=? equal case-insensitive"
(assert= true (char-ci>=? (make-char 97) (make-char 65))))

View File

@@ -1,305 +0,0 @@
(import (sx coroutines))
(defsuite
"coroutine"
(deftest
"coroutine? recognizes coroutine objects"
(let
((co (make-coroutine (fn () nil))))
(assert (coroutine? co))
(assert= false (coroutine? 42))
(assert= false (coroutine? "hello"))
(assert= false (coroutine? nil))
(assert= false (coroutine? (list)))))
(deftest
"coroutine-alive? true for ready coroutine"
(let
((co (make-coroutine (fn () nil))))
(assert (coroutine-alive? co))))
(deftest
"coroutine-alive? false for non-coroutine"
(assert= false (coroutine-alive? 42)))
(deftest
"immediate return — done true, value is body result"
(let
((co (make-coroutine (fn () 42))))
(let
((r (coroutine-resume co nil)))
(assert= true (get r "done"))
(assert= 42 (get r "value")))))
(deftest
"immediate nil return"
(let
((co (make-coroutine (fn () nil))))
(let
((r (coroutine-resume co nil)))
(assert= true (get r "done"))
(assert= nil (get r "value")))))
(deftest
"coroutine-alive? false after completion"
(let
((co (make-coroutine (fn () nil))))
(coroutine-resume co nil)
(assert= false (coroutine-alive? co))))
(deftest
"single yield — done false on yield, done true on finish"
(let
((co (make-coroutine (fn () (coroutine-yield 10) 20))))
(let
((r1 (coroutine-resume co nil)))
(let
((r2 (coroutine-resume co nil)))
(assert= false (get r1 "done"))
(assert= 10 (get r1 "value"))
(assert= true (get r2 "done"))
(assert= 20 (get r2 "value"))))))
(deftest
"coroutine-alive? true between yield and next resume"
(let
((co (make-coroutine (fn () (coroutine-yield nil) nil))))
(assert (coroutine-alive? co))
(coroutine-resume co nil)
(assert (coroutine-alive? co))
(coroutine-resume co nil)
(assert= false (coroutine-alive? co))))
(deftest
"three yields then return"
(let
((co (make-coroutine (fn () (coroutine-yield "a") (coroutine-yield "b") (coroutine-yield "c") "z"))))
(let
((r1 (coroutine-resume co nil)))
(let
((r2 (coroutine-resume co nil)))
(let
((r3 (coroutine-resume co nil)))
(let
((r4 (coroutine-resume co nil)))
(assert= "a" (get r1 "value"))
(assert= false (get r1 "done"))
(assert= "b" (get r2 "value"))
(assert= false (get r2 "done"))
(assert= "c" (get r3 "value"))
(assert= false (get r3 "done"))
(assert= "z" (get r4 "value"))
(assert= true (get r4 "done"))))))))
(deftest
"final return vs yield — done flag distinguishes them"
(let
((co (make-coroutine (fn () (coroutine-yield "yielded") "returned"))))
(let
((y (coroutine-resume co nil)))
(let
((r (coroutine-resume co nil)))
(assert= false (get y "done"))
(assert= "yielded" (get y "value"))
(assert= true (get r "done"))
(assert= "returned" (get r "value"))))))
(deftest
"resume val becomes yield return value"
(let
((co (make-coroutine (fn () (let ((received (coroutine-yield "first"))) received)))))
(let
((r1 (coroutine-resume co nil)))
(let
((r2 (coroutine-resume co 99)))
(assert= "first" (get r1 "value"))
(assert= false (get r1 "done"))
(assert= 99 (get r2 "value"))
(assert= true (get r2 "done"))))))
(deftest
"multiple resume values passed through yields"
(let
((co (make-coroutine (fn () (let ((a (coroutine-yield 1))) (let ((b (coroutine-yield 2))) (+ a b)))))))
(let
((r1 (coroutine-resume co nil)))
(let
((r2 (coroutine-resume co 10)))
(let
((r3 (coroutine-resume co 20)))
(assert= 1 (get r1 "value"))
(assert= 2 (get r2 "value"))
(assert= true (get r3 "done"))
(assert= 30 (get r3 "value")))))))
(deftest
"coroutine captures lexical environment"
(let
((x 10)
(co
(make-coroutine
(fn () (coroutine-yield (* x 2)) (* x 3)))))
(let
((r1 (coroutine-resume co nil)))
(let
((r2 (coroutine-resume co nil)))
(assert= 20 (get r1 "value"))
(assert= 30 (get r2 "value"))))))
(deftest
"resuming dead coroutine raises error"
(let
((co (make-coroutine (fn () nil))))
(coroutine-resume co nil)
(assert-throws (fn () (coroutine-resume co nil)))))
(deftest
"coroutine drives iteration via recursive body"
(let
((co (make-coroutine (fn () (define loop (fn (i) (when (< i 4) (coroutine-yield i) (loop (+ i 1))))) (loop 0))))
(results (list)))
(let
drive
()
(let
((r (coroutine-resume co nil)))
(when
(not (get r "done"))
(append! results (get r "value"))
(drive))))
(assert= 4 (len results))
(assert= 0 (nth results 0))
(assert= 1 (nth results 1))
(assert= 2 (nth results 2))
(assert= 3 (nth results 3))))
(deftest
"nested coroutine — inner resumed from outer body"
(let
((inner (make-coroutine (fn () (coroutine-yield "inner-a") "inner-done")))
(outer
(make-coroutine
(fn
()
(let
((i1 (coroutine-resume inner nil)))
(coroutine-yield (get i1 "value")))
(let ((i2 (coroutine-resume inner nil))) (get i2 "value"))))))
(let
((o1 (coroutine-resume outer nil)))
(let
((o2 (coroutine-resume outer nil)))
(assert= false (get o1 "done"))
(assert= "inner-a" (get o1 "value"))
(assert= true (get o2 "done"))
(assert= "inner-done" (get o2 "value"))))))
(deftest
"two independent coroutines interleave correctly"
(let
((co1 (make-coroutine (fn () (coroutine-yield 1) 5)))
(co2
(make-coroutine (fn () (coroutine-yield 2) 6))))
(let
((a (coroutine-resume co1 nil)))
(let
((b (coroutine-resume co2 nil)))
(let
((c (coroutine-resume co1 nil)))
(let
((d (coroutine-resume co2 nil)))
(assert= false (get a "done"))
(assert= 1 (get a "value"))
(assert= false (get b "done"))
(assert= 2 (get b "value"))
(assert= true (get c "done"))
(assert= 5 (get c "value"))
(assert= true (get d "done"))
(assert= 6 (get d "value"))))))))
(deftest
"coroutine state field is ready before first resume"
(let
((co (make-coroutine (fn () (coroutine-yield 1)))))
(assert= "ready" (get co "state"))))
(deftest
"coroutine state field is suspended between yields"
(let
((co (make-coroutine (fn () (coroutine-yield 1) 2))))
(coroutine-resume co nil)
(assert= "suspended" (get co "state"))))
(deftest
"coroutine state field is dead after completion"
(let
((co (make-coroutine (fn () nil))))
(coroutine-resume co nil)
(assert= "dead" (get co "state"))))
(deftest
"yield works when called from nested helper function"
(let
((co (make-coroutine (fn () (define helper (fn (x) (coroutine-yield x))) (helper 10) (helper 20)))))
(let
((r1 (coroutine-resume co nil)))
(let
((r2 (coroutine-resume co nil)))
(let
((r3 (coroutine-resume co nil)))
(assert= false (get r1 "done"))
(assert= 10 (get r1 "value"))
(assert= false (get r2 "done"))
(assert= 20 (get r2 "value"))
(assert= true (get r3 "done")))))))
(deftest
"initial resume argument is ignored by ready coroutine"
(let
((co (make-coroutine (fn () (coroutine-yield 42)))))
(let
((r (coroutine-resume co "ignored")))
(assert= false (get r "done"))
(assert= 42 (get r "value")))))
(deftest
"coroutine with mutable closure state"
(let
((counter {:value 0}))
(let
((co (make-coroutine (fn () (dict-set! counter "value" 1) (coroutine-yield "a") (dict-set! counter "value" 2) (coroutine-yield "b")))))
(assert= 0 (get counter "value"))
(coroutine-resume co nil)
(assert= 1 (get counter "value"))
(coroutine-resume co nil)
(assert= 2 (get counter "value")))))
(deftest
"coroutine can yield complex values"
(let
((co (make-coroutine (fn () (coroutine-yield (list 1 2 3)) (coroutine-yield {:key "val"})))))
(let
((r1 (coroutine-resume co nil)))
(let
((r2 (coroutine-resume co nil)))
(assert= false (get r1 "done"))
(assert= 3 (len (get r1 "value")))
(assert= false (get r2 "done"))
(assert= "val" (get (get r2 "value") "key"))))))
(deftest
"round-robin scheduling of multiple coroutines"
(let
((results (list))
(co1
(make-coroutine
(fn () (coroutine-yield "a") (coroutine-yield "b"))))
(co2
(make-coroutine
(fn () (coroutine-yield "c") (coroutine-yield "d")))))
(append! results (get (coroutine-resume co1 nil) "value"))
(append! results (get (coroutine-resume co2 nil) "value"))
(append! results (get (coroutine-resume co1 nil) "value"))
(append! results (get (coroutine-resume co2 nil) "value"))
(assert= 4 (len results))
(assert= "a" (nth results 0))
(assert= "c" (nth results 1))
(assert= "b" (nth results 2))
(assert= "d" (nth results 3))))
(deftest
"coroutines created from same factory share no state"
(let
((make-counter (fn (start) (make-coroutine (fn () (define loop (fn (n) (coroutine-yield n) (loop (+ n 1)))) (loop start))))))
(let
((c1 (make-counter 0)) (c2 (make-counter 100)))
(let
((a (get (coroutine-resume c1 nil) "value")))
(let
((b (get (coroutine-resume c2 nil) "value")))
(let
((c (get (coroutine-resume c1 nil) "value")))
(let
((d (get (coroutine-resume c2 nil) "value")))
(assert= 0 a)
(assert= 100 b)
(assert= 1 c)
(assert= 101 d))))))))
(deftest
"resuming non-coroutine raises error"
(assert-throws (fn () (coroutine-resume "not-a-coroutine" nil)))))

View File

@@ -1,113 +0,0 @@
;; Tests for dynamic-wind: after-thunk fires on normal return,
;; non-local exit via raise/guard, and call/cc escape.
(defsuite
"dynamic-wind-basic"
(deftest
"after fires on normal return"
(let
((log (list)))
(dynamic-wind
(fn () (append! log "before"))
(fn () (append! log "body"))
(fn () (append! log "after")))
(assert= 3 (len log))
(assert= "before" (nth log 0))
(assert= "body" (nth log 1))
(assert= "after" (nth log 2))))
(deftest
"after fires on raise escape"
(let
((log (list)))
(guard
(e (true nil))
(dynamic-wind
(fn () (append! log "before"))
(fn () (append! log "body") (error "boom"))
(fn () (append! log "after"))))
(assert= 3 (len log))
(assert= "before" (nth log 0))
(assert= "body" (nth log 1))
(assert= "after" (nth log 2))))
(deftest
"after fires on call/cc escape"
(let
((log (list)))
(call/cc
(fn
(k)
(dynamic-wind
(fn () (append! log "before"))
(fn () (append! log "body") (k nil))
(fn () (append! log "after")))))
(assert= 3 (len log))
(assert= "before" (nth log 0))
(assert= "body" (nth log 1))
(assert= "after" (nth log 2))))
(deftest
"nested dynamic-wind after-thunks fire LIFO on normal return"
(let
((log (list)))
(dynamic-wind
(fn () (append! log "outer-before"))
(fn
()
(dynamic-wind
(fn () (append! log "inner-before"))
(fn () (append! log "inner-body"))
(fn () (append! log "inner-after"))))
(fn () (append! log "outer-after")))
(assert= 5 (len log))
(assert= "outer-before" (nth log 0))
(assert= "inner-before" (nth log 1))
(assert= "inner-body" (nth log 2))
(assert= "inner-after" (nth log 3))
(assert= "outer-after" (nth log 4))))
(deftest
"nested dynamic-wind after-thunks fire LIFO on raise"
(let
((log (list)))
(guard
(e (true nil))
(dynamic-wind
(fn () (append! log "outer-before"))
(fn
()
(dynamic-wind
(fn () (append! log "inner-before"))
(fn () (append! log "inner-body") (error "boom"))
(fn () (append! log "inner-after"))))
(fn () (append! log "outer-after"))))
(assert= 5 (len log))
(assert= "outer-before" (nth log 0))
(assert= "inner-before" (nth log 1))
(assert= "inner-body" (nth log 2))
(assert= "inner-after" (nth log 3))
(assert= "outer-after" (nth log 4))))
(deftest
"before and after are called"
(let
((count 0))
(dynamic-wind
(fn () (set! count (+ count 1)))
(fn () nil)
(fn () (set! count (+ count 10))))
(assert= 11 count)))
(deftest
"dynamic-wind return value is body result"
(let
((result (dynamic-wind (fn () nil) (fn () 42) (fn () nil))))
(assert= 42 result)))
(deftest
"after fires before guard handler"
(let
((log (list)))
(guard
(e (true (append! log "guard-handler")))
(dynamic-wind
(fn () nil)
(fn () (error "boom"))
(fn () (append! log "after"))))
(assert= 2 (len log))
(assert= "after" (nth log 0))
(assert= "guard-handler" (nth log 1)))))

View File

@@ -10,56 +10,57 @@
;; Literals and types
;; --------------------------------------------------------------------------
(defsuite
"literals"
(deftest
"numbers are numbers"
(defsuite "literals"
(deftest "numbers are numbers"
(assert-type "number" 42)
(assert-type "number" 3.14)
(assert-type "number" -1))
(deftest
"strings are strings"
(deftest "strings are strings"
(assert-type "string" "hello")
(assert-type "string" ""))
(deftest
"booleans are booleans"
(deftest "booleans are booleans"
(assert-type "boolean" true)
(assert-type "boolean" false))
(deftest "nil is nil" (assert-type "nil" nil) (assert-nil nil))
(deftest
"lists are lists"
(deftest "nil is nil"
(assert-type "nil" nil)
(assert-nil nil))
(deftest "lists are lists"
(assert-type "list" (list 1 2 3))
(assert-type "list" (list)))
(deftest "dicts are dicts" (assert-type "dict" {:b 2 :a 1})))
(deftest "dicts are dicts"
(assert-type "dict" {:a 1 :b 2})))
;; --------------------------------------------------------------------------
;; Arithmetic
;; --------------------------------------------------------------------------
(defsuite
"arithmetic"
(deftest
"addition"
(defsuite "arithmetic"
(deftest "addition"
(assert-equal 3 (+ 1 2))
(assert-equal 0 (+ 0 0))
(assert-equal -1 (+ 1 -2))
(assert-equal 10 (+ 1 2 3 4)))
(deftest
"subtraction"
(deftest "subtraction"
(assert-equal 1 (- 3 2))
(assert-equal -1 (- 2 3)))
(deftest
"multiplication"
(deftest "multiplication"
(assert-equal 6 (* 2 3))
(assert-equal 0 (* 0 100))
(assert-equal 24 (* 1 2 3 4)))
(deftest
"division"
(deftest "division"
(assert-equal 2 (/ 6 3))
(assert-equal 2.5 (/ 5 2)))
(deftest
"modulo"
(deftest "modulo"
(assert-equal 1 (mod 7 3))
(assert-equal 0 (mod 6 3))))
@@ -68,26 +69,20 @@
;; Comparison
;; --------------------------------------------------------------------------
(defsuite
"comparison"
(deftest
"equality"
(defsuite "comparison"
(deftest "equality"
(assert-true (= 1 1))
(assert-false (= 1 2))
(assert-true (= "a" "a"))
(assert-false (= "a" "b")))
(deftest
"deep equality"
(assert-true
(equal?
(list 1 2 3)
(list 1 2 3)))
(assert-false
(equal? (list 1 2) (list 1 3)))
(deftest "deep equality"
(assert-true (equal? (list 1 2 3) (list 1 2 3)))
(assert-false (equal? (list 1 2) (list 1 3)))
(assert-true (equal? {:a 1} {:a 1}))
(assert-false (equal? {:a 1} {:a 2})))
(deftest
"ordering"
(deftest "ordering"
(assert-true (< 1 2))
(assert-false (< 2 1))
(assert-true (> 2 1))
@@ -101,36 +96,34 @@
;; String operations
;; --------------------------------------------------------------------------
(defsuite
"strings"
(deftest
"str concatenation"
(defsuite "strings"
(deftest "str concatenation"
(assert-equal "abc" (str "a" "b" "c"))
(assert-equal "hello world" (str "hello" " " "world"))
(assert-equal "42" (str 42))
(assert-equal "" (str)))
(deftest
"string-length"
(deftest "string-length"
(assert-equal 5 (string-length "hello"))
(assert-equal 0 (string-length "")))
(deftest
"substring"
(deftest "substring"
(assert-equal "ell" (substring "hello" 1 4))
(assert-equal "hello" (substring "hello" 0 5)))
(deftest
"string-contains?"
(deftest "string-contains?"
(assert-true (string-contains? "hello world" "world"))
(assert-false (string-contains? "hello" "xyz")))
(deftest
"upcase and downcase"
(deftest "upcase and downcase"
(assert-equal "HELLO" (upcase "hello"))
(assert-equal "hello" (downcase "HELLO")))
(deftest
"trim"
(deftest "trim"
(assert-equal "hello" (trim " hello "))
(assert-equal "hello" (trim "hello")))
(deftest
"split and join"
(deftest "split and join"
(assert-equal (list "a" "b" "c") (split "a,b,c" ","))
(assert-equal "a-b-c" (join "-" (list "a" "b" "c")))))
@@ -139,145 +132,121 @@
;; List operations
;; --------------------------------------------------------------------------
(defsuite
"lists"
(deftest
"constructors"
(assert-equal
(list 1 2 3)
(list 1 2 3))
(defsuite "lists"
(deftest "constructors"
(assert-equal (list 1 2 3) (list 1 2 3))
(assert-equal (list) (list))
(assert-length 3 (list 1 2 3)))
(deftest
"first and rest"
(deftest "first and rest"
(assert-equal 1 (first (list 1 2 3)))
(assert-equal
(list 2 3)
(rest (list 1 2 3)))
(assert-equal (list 2 3) (rest (list 1 2 3)))
(assert-nil (first (list)))
(assert-equal (list) (rest (list))))
(deftest
"nth"
(assert-equal
1
(nth (list 1 2 3) 0))
(assert-equal
2
(nth (list 1 2 3) 1))
(assert-equal
3
(nth (list 1 2 3) 2)))
(deftest
"last"
(deftest "nth"
(assert-equal 1 (nth (list 1 2 3) 0))
(assert-equal 2 (nth (list 1 2 3) 1))
(assert-equal 3 (nth (list 1 2 3) 2)))
(deftest "last"
(assert-equal 3 (last (list 1 2 3)))
(assert-nil (last (list))))
(deftest
"cons and append"
(assert-equal
(list 0 1 2)
(cons 0 (list 1 2)))
(assert-equal
(list 1 2 3 4)
(append (list 1 2) (list 3 4))))
(deftest
"reverse"
(assert-equal
(list 3 2 1)
(reverse (list 1 2 3)))
(deftest "cons and append"
(assert-equal (list 0 1 2) (cons 0 (list 1 2)))
(assert-equal (list 1 2 3 4) (append (list 1 2) (list 3 4))))
(deftest "reverse"
(assert-equal (list 3 2 1) (reverse (list 1 2 3)))
(assert-equal (list) (reverse (list))))
(deftest
"empty?"
(deftest "empty?"
(assert-true (empty? (list)))
(assert-false (empty? (list 1))))
(deftest
"len"
(deftest "len"
(assert-equal 0 (len (list)))
(assert-equal 3 (len (list 1 2 3))))
(deftest
"contains?"
(assert-true
(contains? (list 1 2 3) 2))
(assert-false
(contains? (list 1 2 3) 4)))
(deftest
"flatten"
(assert-equal
(list 1 2 3 4)
(flatten
(list (list 1 2) (list 3 4))))))
(deftest "contains?"
(assert-true (contains? (list 1 2 3) 2))
(assert-false (contains? (list 1 2 3) 4)))
(deftest "flatten"
(assert-equal (list 1 2 3 4) (flatten (list (list 1 2) (list 3 4))))))
;; --------------------------------------------------------------------------
;; Dict operations
;; --------------------------------------------------------------------------
(defsuite
"dicts"
(deftest
"dict literal"
(assert-type "dict" {:b 2 :a 1})
(defsuite "dicts"
(deftest "dict literal"
(assert-type "dict" {:a 1 :b 2})
(assert-equal 1 (get {:a 1} "a"))
(assert-equal 2 (get {:b 2 :a 1} "b")))
(deftest
"assoc"
(assert-equal {:b 2 :a 1} (assoc {:a 1} "b" 2))
(assert-equal 2 (get {:a 1 :b 2} "b")))
(deftest "assoc"
(assert-equal {:a 1 :b 2} (assoc {:a 1} "b" 2))
(assert-equal {:a 99} (assoc {:a 1} "a" 99)))
(deftest "dissoc" (assert-equal {:b 2} (dissoc {:b 2 :a 1} "a")))
(deftest
"keys and vals"
(let
((d {:b 2 :a 1}))
(deftest "dissoc"
(assert-equal {:b 2} (dissoc {:a 1 :b 2} "a")))
(deftest "keys and vals"
(let ((d {:a 1 :b 2}))
(assert-length 2 (keys d))
(assert-length 2 (vals d))
(assert-contains "a" (keys d))
(assert-contains "b" (keys d))))
(deftest
"has-key?"
(deftest "has-key?"
(assert-true (has-key? {:a 1} "a"))
(assert-false (has-key? {:a 1} "b")))
(deftest
"merge"
(assert-equal {:c 3 :b 2 :a 1} (merge {:b 2 :a 1} {:c 3}))
(assert-equal {:b 2 :a 99} (merge {:b 2 :a 1} {:a 99}))))
(deftest "merge"
(assert-equal {:a 1 :b 2 :c 3}
(merge {:a 1 :b 2} {:c 3}))
(assert-equal {:a 99 :b 2}
(merge {:a 1 :b 2} {:a 99}))))
;; --------------------------------------------------------------------------
;; Predicates
;; --------------------------------------------------------------------------
(defsuite
"predicates"
(deftest
"nil?"
(defsuite "predicates"
(deftest "nil?"
(assert-true (nil? nil))
(assert-false (nil? 0))
(assert-false (nil? false))
(assert-false (nil? "")))
(deftest
"number?"
(deftest "number?"
(assert-true (number? 42))
(assert-true (number? 3.14))
(assert-false (number? "42")))
(deftest
"string?"
(deftest "string?"
(assert-true (string? "hello"))
(assert-false (string? 42)))
(deftest
"list?"
(deftest "list?"
(assert-true (list? (list 1 2)))
(assert-false (list? "not a list")))
(deftest
"dict?"
(deftest "dict?"
(assert-true (dict? {:a 1}))
(assert-false (dict? (list 1))))
(deftest
"boolean?"
(deftest "boolean?"
(assert-true (boolean? true))
(assert-true (boolean? false))
(assert-false (boolean? nil))
(assert-false (boolean? 0)))
(deftest
"not"
(deftest "not"
(assert-true (not false))
(assert-true (not nil))
(assert-false (not true))
@@ -289,67 +258,77 @@
;; Special forms
;; --------------------------------------------------------------------------
(defsuite
"special-forms"
(deftest
"if"
(defsuite "special-forms"
(deftest "if"
(assert-equal "yes" (if true "yes" "no"))
(assert-equal "no" (if false "yes" "no"))
(assert-equal "no" (if nil "yes" "no"))
(assert-nil (if false "yes")))
(deftest
"when"
(deftest "when"
(assert-equal "yes" (when true "yes"))
(assert-nil (when false "yes")))
(deftest
"cond"
(deftest "cond"
(assert-equal "a" (cond true "a" :else "b"))
(assert-equal "b" (cond false "a" :else "b"))
(assert-equal "c" (cond false "a" false "b" :else "c")))
(deftest
"cond with 2-element predicate as first test"
(assert-equal "c" (cond
false "a"
false "b"
:else "c")))
(deftest "cond with 2-element predicate as first test"
;; Regression: cond misclassifies Clojure-style as scheme-style when
;; the first test is a 2-element list like (nil? x) or (empty? x).
;; The evaluator checks: is first arg a 2-element list? If yes, treats
;; as scheme-style ((test body) ...) — returning the arg instead of
;; evaluating the predicate call.
(assert-equal 0 (cond (nil? nil) 0 :else 1))
(assert-equal 1 (cond (nil? "x") 0 :else 1))
(assert-equal "empty" (cond (empty? (list)) "empty" :else "not-empty"))
(assert-equal
"not-empty"
(cond (empty? (list 1)) "empty" :else "not-empty"))
(assert-equal "not-empty" (cond (empty? (list 1)) "empty" :else "not-empty"))
(assert-equal "yes" (cond (not false) "yes" :else "no"))
(assert-equal "no" (cond (not true) "yes" :else "no")))
(deftest
"cond with 2-element predicate and no :else"
(assert-equal "found" (cond (nil? nil) "found" (nil? "x") "other"))
(assert-equal "b" (cond (nil? "x") "a" (not false) "b")))
(deftest
"and"
(deftest "cond with 2-element predicate and no :else"
;; Same bug, but without :else — this is the worst case because the
;; bootstrapper heuristic also breaks (all clauses are 2-element lists).
(assert-equal "found"
(cond (nil? nil) "found"
(nil? "x") "other"))
(assert-equal "b"
(cond (nil? "x") "a"
(not false) "b")))
(deftest "and"
(assert-true (and true true))
(assert-false (and true false))
(assert-false (and false true))
(assert-equal 3 (and 1 2 3)))
(deftest
"or"
(deftest "or"
(assert-equal 1 (or 1 2))
(assert-equal 2 (or false 2))
(assert-equal "fallback" (or nil false "fallback"))
(assert-false (or false false)))
(deftest
"let"
(assert-equal
3
(let ((x 1) (y 2)) (+ x y)))
(assert-equal
"hello world"
(deftest "let"
(assert-equal 3 (let ((x 1) (y 2)) (+ x y)))
(assert-equal "hello world"
(let ((a "hello") (b " world")) (str a b))))
(deftest
"let clojure-style"
(deftest "let clojure-style"
(assert-equal 3 (let (x 1 y 2) (+ x y))))
(deftest
"do / begin"
(deftest "do / begin"
(assert-equal 3 (do 1 2 3))
(assert-equal "last" (begin "first" "middle" "last")))
(deftest "define" (define x 42) (assert-equal 42 x))
(deftest
"set!"
(deftest "define"
(define x 42)
(assert-equal 42 x))
(deftest "set!"
(define x 1)
(set! x 2)
(assert-equal 2 x)))
@@ -359,126 +338,86 @@
;; Lambda and closures
;; --------------------------------------------------------------------------
(defsuite
"lambdas"
(deftest
"basic lambda"
(let
((add (fn (a b) (+ a b))))
(defsuite "lambdas"
(deftest "basic lambda"
(let ((add (fn (a b) (+ a b))))
(assert-equal 3 (add 1 2))))
(deftest
"closure captures env"
(let
((x 10))
(let
((add-x (fn (y) (+ x y))))
(deftest "closure captures env"
(let ((x 10))
(let ((add-x (fn (y) (+ x y))))
(assert-equal 15 (add-x 5)))))
(deftest
"lambda as argument"
(assert-equal
(list 2 4 6)
(map
(fn (x) (* x 2))
(list 1 2 3))))
(deftest
"recursive lambda via define"
(define
factorial
(fn
(n)
(if
(<= n 1)
1
(* n (factorial (- n 1))))))
(deftest "lambda as argument"
(assert-equal (list 2 4 6)
(map (fn (x) (* x 2)) (list 1 2 3))))
(deftest "recursive lambda via define"
(define factorial
(fn (n) (if (<= n 1) 1 (* n (factorial (- n 1))))))
(assert-equal 120 (factorial 5)))
(deftest
"higher-order returns lambda"
(let
((make-adder (fn (n) (fn (x) (+ n x)))))
(let
((add5 (make-adder 5)))
(deftest "higher-order returns lambda"
(let ((make-adder (fn (n) (fn (x) (+ n x)))))
(let ((add5 (make-adder 5)))
(assert-equal 8 (add5 3)))))
(deftest
"multi-body lambda returns last value"
(let
((f (fn (x) (+ x 1) (+ x 2) (+ x 3))))
(deftest "multi-body lambda returns last value"
;; All body expressions must execute. Return value is the last.
;; Catches: sf-lambda using nth(args,1) instead of rest(args).
(let ((f (fn (x) (+ x 1) (+ x 2) (+ x 3))))
(assert-equal 13 (f 10))))
(deftest
"multi-body lambda side effects via dict mutation"
(let
((state (dict "a" 0 "b" 0)))
(let
((f (fn () (dict-set! state "a" 1) (dict-set! state "b" 2) "done")))
(deftest "multi-body lambda side effects via dict mutation"
;; Verify all body expressions run by mutating a shared dict.
(let ((state (dict "a" 0 "b" 0)))
(let ((f (fn ()
(dict-set! state "a" 1)
(dict-set! state "b" 2)
"done")))
(assert-equal "done" (f))
(assert-equal 1 (get state "a"))
(assert-equal 2 (get state "b")))))
(deftest
"multi-body lambda two expressions"
(assert-equal
20
(deftest "multi-body lambda two expressions"
;; Simplest case: two body expressions, return value is second.
(assert-equal 20
((fn (x) (+ x 1) (* x 2)) 10))
(assert-equal 42 ((fn () (+ 1 2) 42)))))
;; And with zero-arg lambda
(assert-equal 42
((fn () (+ 1 2) 42)))))
;; --------------------------------------------------------------------------
;; Higher-order forms
;; --------------------------------------------------------------------------
(defsuite
"higher-order"
(deftest
"map"
(assert-equal
(list 2 4 6)
(map
(fn (x) (* x 2))
(list 1 2 3)))
(defsuite "higher-order"
(deftest "map"
(assert-equal (list 2 4 6)
(map (fn (x) (* x 2)) (list 1 2 3)))
(assert-equal (list) (map (fn (x) x) (list))))
(deftest
"filter"
(assert-equal
(list 2 4)
(filter
(fn (x) (= (mod x 2) 0))
(list 1 2 3 4)))
(assert-equal
(list)
(deftest "filter"
(assert-equal (list 2 4)
(filter (fn (x) (= (mod x 2) 0)) (list 1 2 3 4)))
(assert-equal (list)
(filter (fn (x) false) (list 1 2 3))))
(deftest
"reduce"
(assert-equal
10
(reduce
(fn (acc x) (+ acc x))
0
(list 1 2 3 4)))
(assert-equal
0
(reduce (fn (acc x) (+ acc x)) 0 (list))))
(deftest
"some"
(assert-true
(some
(fn (x) (> x 3))
(list 1 2 3 4 5)))
(assert-false
(some
(fn (x) (> x 10))
(list 1 2 3))))
(deftest
"every?"
(assert-true
(every?
(fn (x) (> x 0))
(list 1 2 3)))
(assert-false
(every?
(fn (x) (> x 2))
(list 1 2 3))))
(deftest
"map-indexed"
(assert-equal
(list "0:a" "1:b" "2:c")
(deftest "reduce"
(assert-equal 10 (reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4)))
(assert-equal 0 (reduce (fn (acc x) (+ acc x)) 0 (list))))
(deftest "some"
(assert-true (some (fn (x) (> x 3)) (list 1 2 3 4 5)))
(assert-false (some (fn (x) (> x 10)) (list 1 2 3))))
(deftest "every?"
(assert-true (every? (fn (x) (> x 0)) (list 1 2 3)))
(assert-false (every? (fn (x) (> x 2)) (list 1 2 3))))
(deftest "map-indexed"
(assert-equal (list "0:a" "1:b" "2:c")
(map-indexed (fn (i x) (str i ":" x)) (list "a" "b" "c")))))
@@ -486,39 +425,49 @@
;; Components
;; --------------------------------------------------------------------------
(defsuite
"components"
(deftest
"defcomp creates component"
(defcomp ~test-comp (&key title) (div title))
(defsuite "components"
(deftest "defcomp creates component"
(defcomp ~test-comp (&key title)
(div title))
(assert-true (not (nil? ~test-comp))))
(deftest
"component renders with keyword args"
(defcomp ~greeting (&key name) (span (str "Hello, " name "!")))
(deftest "component renders with keyword args"
(defcomp ~greeting (&key name)
(span (str "Hello, " name "!")))
(assert-true (not (nil? ~greeting))))
(deftest
"component with children"
(defcomp ~box (&key &rest children) (div :class "box" children))
(deftest "component with children"
(defcomp ~box (&key &rest children)
(div :class "box" children))
(assert-true (not (nil? ~box))))
(deftest
"component with default via or"
(defcomp ~label (&key text) (span (or text "default")))
(deftest "component with default via or"
(defcomp ~label (&key text)
(span (or text "default")))
(assert-true (not (nil? ~label))))
(deftest
"defcomp default affinity is auto"
(defcomp ~aff-default (&key x) (div x))
(deftest "defcomp default affinity is auto"
(defcomp ~aff-default (&key x)
(div x))
(assert-equal "auto" (component-affinity ~aff-default)))
(deftest
"defcomp affinity client"
(defcomp ~aff-client (&key x) :affinity :client (div x))
(deftest "defcomp affinity client"
(defcomp ~aff-client (&key x)
:affinity :client
(div x))
(assert-equal "client" (component-affinity ~aff-client)))
(deftest
"defcomp affinity server"
(defcomp ~aff-server (&key x) :affinity :server (div x))
(deftest "defcomp affinity server"
(defcomp ~aff-server (&key x)
:affinity :server
(div x))
(assert-equal "server" (component-affinity ~aff-server)))
(deftest
"defcomp affinity preserves body"
(defcomp ~aff-body (&key val) :affinity :client (span val))
(deftest "defcomp affinity preserves body"
(defcomp ~aff-body (&key val)
:affinity :client
(span val))
;; Component should still render correctly
(assert-equal "client" (component-affinity ~aff-body))
(assert-true (not (nil? ~aff-body)))))
@@ -527,98 +476,93 @@
;; Macros
;; --------------------------------------------------------------------------
(defsuite
"macros"
(deftest
"defmacro creates macro"
(defmacro
unless
(cond &rest body)
(quasiquote (if (not (unquote cond)) (do (splice-unquote body)))))
(defsuite "macros"
(deftest "defmacro creates macro"
(defmacro unless (cond &rest body)
`(if (not ,cond) (do ,@body)))
(assert-equal "yes" (unless false "yes"))
(assert-nil (unless true "no")))
(deftest
"quasiquote and unquote"
(let
((x 42))
(assert-equal
(list 1 42 3)
(quasiquote (1 (unquote x) 3)))))
(deftest
"splice-unquote"
(let
((xs (list 2 3 4)))
(assert-equal
(list 1 2 3 4 5)
(quasiquote (1 (splice-unquote xs) 5))))))
(deftest "quasiquote and unquote"
(let ((x 42))
(assert-equal (list 1 42 3) `(1 ,x 3))))
(deftest "splice-unquote"
(let ((xs (list 2 3 4)))
(assert-equal (list 1 2 3 4 5) `(1 ,@xs 5)))))
;; --------------------------------------------------------------------------
;; Threading macro
;; --------------------------------------------------------------------------
(defsuite
"threading"
(deftest
"thread-first"
(defsuite "threading"
(deftest "thread-first"
(assert-equal 8 (-> 5 (+ 1) (+ 2)))
(assert-equal "HELLO" (-> "hello" upcase))
(assert-equal "HELLO WORLD" (-> "hello" (str " world") upcase))))
(assert-equal "HELLO WORLD"
(-> "hello"
(str " world")
upcase))))
;; --------------------------------------------------------------------------
;; Truthiness
;; --------------------------------------------------------------------------
(defsuite
"truthiness"
(deftest
"truthy values"
(defsuite "truthiness"
(deftest "truthy values"
(assert-true (if 1 true false))
(assert-true (if "x" true false))
(assert-true (if (list 1) true false))
(assert-true (if true true false)))
(deftest
"falsy values"
(deftest "falsy values"
(assert-false (if false true false))
(assert-false (if nil true false))))
(assert-false (if nil true false)))
;; NOTE: empty list, zero, and empty string truthiness is
;; platform-dependent. Python treats all three as falsy.
;; JavaScript treats [] as truthy but 0 and "" as falsy.
;; These tests are omitted — each bootstrapper should emit
;; platform-specific truthiness tests instead.
)
;; --------------------------------------------------------------------------
;; Edge cases and regression tests
;; --------------------------------------------------------------------------
(defsuite
"edge-cases"
(deftest
"nested let scoping"
(let
((x 1))
(let ((x 2)) (assert-equal 2 x))))
(deftest
"recursive map"
(assert-equal
(list (list 2 4) (list 6 8))
(map
(fn (sub) (map (fn (x) (* x 2)) sub))
(list (list 1 2) (list 3 4)))))
(deftest
"keyword as value"
(defsuite "edge-cases"
(deftest "nested let scoping"
(let ((x 1))
(let ((x 2))
(assert-equal 2 x))
;; outer x should be unchanged by inner let
;; (this tests that let creates a new scope)
))
(deftest "recursive map"
(assert-equal (list (list 2 4) (list 6 8))
(map (fn (sub) (map (fn (x) (* x 2)) sub))
(list (list 1 2) (list 3 4)))))
(deftest "keyword as value"
(assert-equal "class" :class)
(assert-equal "id" :id))
(deftest
"dict with evaluated values"
(let ((x 42)) (assert-equal 42 (get {:val x} "val"))))
(deftest
"nil propagation"
(deftest "dict with evaluated values"
(let ((x 42))
(assert-equal 42 (get {:val x} "val"))))
(deftest "nil propagation"
(assert-nil (get {:a 1} "missing"))
(assert-equal "default" (or (get {:a 1} "missing") "default")))
(deftest
"empty operations"
(deftest "empty operations"
(assert-equal (list) (map (fn (x) x) (list)))
(assert-equal (list) (filter (fn (x) true) (list)))
(assert-equal
0
(reduce (fn (acc x) (+ acc x)) 0 (list)))
(assert-equal 0 (reduce (fn (acc x) (+ acc x)) 0 (list)))
(assert-equal 0 (len (list)))
(assert-equal "" (str))))

View File

@@ -1,90 +0,0 @@
;; ==========================================================================
;; test-format.sx — Tests for CL-style format function
;; ==========================================================================
;; --------------------------------------------------------------------------
;; basic directives
;; --------------------------------------------------------------------------
(defsuite
"format:basic"
(deftest "format returns string" (assert (string? (format "hello"))))
(deftest
"format no directives"
(assert= (format "hello world") "hello world"))
(deftest "format empty template" (assert= (format "") ""))
(deftest "~a display string" (assert= (format "~a" "hello") "hello"))
(deftest "~a display number" (assert= (format "~a" 42) "42"))
(deftest "~a display nil" (assert= (format "~a" nil) "()"))
(deftest
"~s write string (with quotes)"
(assert= (format "~s" "hi") "\"hi\""))
(deftest "~s write number" (assert= (format "~s" 42) "42"))
(deftest
"multiple args"
(assert= (format "~a and ~a" "foo" "bar") "foo and bar")))
;; --------------------------------------------------------------------------
;; numeric directives
;; --------------------------------------------------------------------------
(defsuite
"format:numeric"
(deftest "~d decimal" (assert= (format "~d" 255) "255"))
(deftest "~x hex" (assert= (format "~x" 255) "ff"))
(deftest "~o octal" (assert= (format "~o" 8) "10"))
(deftest "~b binary" (assert= (format "~b" 10) "1010"))
(deftest "~d zero" (assert= (format "~d" 0) "0"))
(deftest
"~x uppercase digits"
(assert= (format "value: ~x" 16) "value: 10")))
;; --------------------------------------------------------------------------
;; float directives
;; --------------------------------------------------------------------------
(defsuite
"format:float"
(deftest "~f fixed point" (assert= (format "~f" 3.14) "3.140000"))
(deftest "~f zero" (assert= (format "~f" 0) "0.000000")))
;; --------------------------------------------------------------------------
;; control directives
;; --------------------------------------------------------------------------
(defsuite
"format:control"
(deftest "~% newline" (assert= (format "a~%b") "a\nb"))
(deftest "~~ literal tilde" (assert= (format "100~~") "100~"))
(deftest "~t tab" (assert= (format "a~tb") "a\tb"))
(deftest "~& fresh line at start" (assert= (format "~&hello") "\nhello"))
(deftest
"~& no newline if already at newline"
(assert= (format "line~%~&next") "line\nnext")))
;; --------------------------------------------------------------------------
;; mixed / compound
;; --------------------------------------------------------------------------
(defsuite
"format:compound"
(deftest
"name and age"
(assert=
(format "Hello ~a, age ~d" "Alice" 30)
"Hello Alice, age 30"))
(deftest
"hex dump style"
(assert=
(format "~d = 0x~x = 0b~b" 10 10 10)
"10 = 0xa = 0b1010"))
(deftest "multiple newlines" (assert= (format "~%~%") "\n\n"))
(deftest "text with no args" (assert= (format "status: ok") "status: ok"))
(deftest
"tilde at end (unknown directive)"
(assert (string? (format "test~"))))
(deftest
"nested strings in ~a"
(assert=
(format "got: ~a" (list 1 2 3))
"got: (1 2 3)")))

View File

@@ -1,78 +0,0 @@
(defsuite
"gensym"
(deftest "gensym returns a symbol" (assert= true (symbol? (gensym))))
(deftest
"gensym default prefix is g"
(let
((s (symbol-name (gensym))))
(assert= true (string-contains? s "g"))))
(deftest
"gensym with prefix uses that prefix"
(let
((s (symbol-name (gensym "var"))))
(assert= "var" (substring s 0 3))))
(deftest
"gensym produces unique symbols"
(let
((a (gensym)) (b (gensym)))
(assert= false (= (symbol-name a) (symbol-name b)))))
(deftest
"gensym same prefix produces unique symbols"
(let
((a (gensym "x")) (b (gensym "x")) (c (gensym "x")))
(assert= false (= (symbol-name a) (symbol-name b)))
(assert= false (= (symbol-name b) (symbol-name c)))))
(deftest
"gensym counter increases: names differ"
(let
((a (gensym "k")) (b (gensym "k")))
(assert= false (= (symbol-name a) (symbol-name b)))))
(deftest
"gensym no-arg and prefix-arg both unique"
(let
((a (gensym)) (b (gensym "g")))
(assert= false (= (symbol-name a) (symbol-name b)))))
(deftest
"string->symbol returns a symbol"
(assert= true (symbol? (string->symbol "hello"))))
(deftest
"string->symbol symbol has correct name"
(assert= "hello" (symbol-name (string->symbol "hello"))))
(deftest
"string->symbol empty string"
(assert= true (symbol? (string->symbol ""))))
(deftest
"symbol->string returns a string"
(assert= true (string? (symbol->string (quote foo)))))
(deftest
"symbol->string round-trips with string->symbol"
(assert= "hello" (symbol->string (string->symbol "hello"))))
(deftest
"string->symbol/symbol->string round-trip"
(let
((sym (string->symbol "my-var")))
(assert= "my-var" (symbol->string sym))))
(deftest
"intern returns a symbol"
(assert= true (symbol? (intern "foo"))))
(deftest
"intern same as string->symbol"
(assert= "bar" (symbol-name (intern "bar"))))
(deftest
"symbol-interned? true for literal symbols"
(assert= true (symbol-interned? (quote hello))))
(deftest
"symbol-interned? true for gensym'd symbol"
(assert= true (symbol-interned? (gensym "g"))))
(deftest
"symbol-interned? true for string->symbol"
(assert= true (symbol-interned? (string->symbol "test"))))
(deftest
"multiple gensym calls all unique"
(let
((syms (map (fn (i) (gensym "t")) (in-range 5))))
(let
((names (map symbol-name syms)))
(let
((unique-names (reduce (fn (acc n) (if (some (fn (x) (= x n)) acc) acc (cons n acc))) (list) names)))
(assert-equal 5 (len unique-names)))))))

View File

@@ -1,166 +0,0 @@
;; Tests for mutable hash tables (Phase 10)
(defsuite
"hash-table"
(deftest
"make-hash-table returns a hash table"
(assert (hash-table? (make-hash-table))))
(deftest
"hash-table? false for dict"
(assert= false (hash-table? {:a 1})))
(deftest "hash-table? false for nil" (assert= false (hash-table? nil)))
(deftest
"hash-table? false for list"
(assert= false (hash-table? (list 1 2))))
(deftest
"empty table has size 0"
(assert= 0 (hash-table-size (make-hash-table))))
(deftest
"size after one set"
(let
((ht (make-hash-table)))
(hash-table-set! ht "a" 1)
(assert= 1 (hash-table-size ht))))
(deftest
"size after multiple sets"
(let
((ht (make-hash-table)))
(hash-table-set! ht "a" 1)
(hash-table-set! ht "b" 2)
(hash-table-set! ht "c" 3)
(assert= 3 (hash-table-size ht))))
(deftest
"set same key does not grow size"
(let
((ht (make-hash-table)))
(hash-table-set! ht "a" 1)
(hash-table-set! ht "a" 2)
(assert= 1 (hash-table-size ht))))
(deftest
"ref returns set value"
(let
((ht (make-hash-table)))
(hash-table-set! ht "k" 42)
(assert= 42 (hash-table-ref ht "k"))))
(deftest
"ref returns updated value after overwrite"
(let
((ht (make-hash-table)))
(hash-table-set! ht "k" 1)
(hash-table-set! ht "k" 99)
(assert= 99 (hash-table-ref ht "k"))))
(deftest
"ref with default returns default for missing key"
(assert=
"fallback"
(hash-table-ref (make-hash-table) "missing" "fallback")))
(deftest
"ref with default returns value when key exists"
(let
((ht (make-hash-table)))
(hash-table-set! ht "x" 7)
(assert= 7 (hash-table-ref ht "x" 0))))
(deftest
"keyword keys work"
(let
((ht (make-hash-table)))
(hash-table-set! ht :foo "bar")
(assert= "bar" (hash-table-ref ht :foo))))
(deftest
"number keys work"
(let
((ht (make-hash-table)))
(hash-table-set! ht 0 "zero")
(assert= "zero" (hash-table-ref ht 0))))
(deftest
"delete removes key"
(let
((ht (make-hash-table)))
(hash-table-set! ht "x" 1)
(hash-table-delete! ht "x")
(assert= "gone" (hash-table-ref ht "x" "gone"))))
(deftest
"delete reduces size"
(let
((ht (make-hash-table)))
(hash-table-set! ht "a" 1)
(hash-table-set! ht "b" 2)
(hash-table-delete! ht "a")
(assert= 1 (hash-table-size ht))))
(deftest
"delete missing key is no-op"
(let
((ht (make-hash-table)))
(hash-table-delete! ht "absent")
(assert= 0 (hash-table-size ht))))
(deftest
"keys of empty table is empty"
(assert (empty? (hash-table-keys (make-hash-table)))))
(deftest
"keys has correct count"
(let
((ht (make-hash-table)))
(hash-table-set! ht "a" 1)
(hash-table-set! ht "b" 2)
(assert= 2 (len (hash-table-keys ht)))))
(deftest
"values has correct count"
(let
((ht (make-hash-table)))
(hash-table-set! ht "a" 10)
(hash-table-set! ht "b" 20)
(assert= 2 (len (hash-table-values ht)))))
(deftest
"alist of empty table is empty"
(assert (empty? (hash-table->alist (make-hash-table)))))
(deftest
"alist has correct length"
(let
((ht (make-hash-table)))
(hash-table-set! ht "x" 1)
(hash-table-set! ht "y" 2)
(assert= 2 (len (hash-table->alist ht)))))
(deftest
"for-each visits all entries"
(let
((ht (make-hash-table)) (count 0))
(hash-table-set! ht "a" 1)
(hash-table-set! ht "b" 2)
(hash-table-set! ht "c" 3)
(hash-table-for-each ht (fn (k v) (set! count (+ count 1))))
(assert= 3 count)))
(deftest
"for-each sums values"
(let
((ht (make-hash-table)) (total 0))
(hash-table-set! ht "a" 10)
(hash-table-set! ht "b" 20)
(hash-table-set! ht "c" 30)
(hash-table-for-each ht (fn (k v) (set! total (+ total v))))
(assert= 60 total)))
(deftest
"merge copies entries from src to dst"
(let
((dst (make-hash-table)) (src (make-hash-table)))
(hash-table-set! src "x" 1)
(hash-table-set! src "y" 2)
(hash-table-merge! dst src)
(assert= 2 (hash-table-size dst))))
(deftest
"merge overwrites existing keys in dst"
(let
((dst (make-hash-table)) (src (make-hash-table)))
(hash-table-set! dst "k" "old")
(hash-table-set! src "k" "new")
(hash-table-merge! dst src)
(assert= "new" (hash-table-ref dst "k"))))
(deftest
"merge does not modify src"
(let
((dst (make-hash-table)) (src (make-hash-table)))
(hash-table-set! src "a" 1)
(hash-table-merge! dst src)
(assert= 1 (hash-table-size src))))
(deftest
"type-of returns hash-table"
(assert= "hash-table" (type-of (make-hash-table)))))

View File

@@ -1,131 +0,0 @@
(deftest
"math completeness"
(deftest
"trigonometry"
(deftest
"sin"
(assert= 0 (round (sin 0)) "sin 0 = 0")
(assert=
1
(round (sin (/ 3.14159 2)))
"sin pi/2 = 1")
(assert= 0 (round (sin 3.14159)) "sin pi = 0"))
(deftest
"cos"
(assert= 1 (round (cos 0)) "cos 0 = 1")
(assert=
0
(round (cos (/ 3.14159 2)))
"cos pi/2 = 0")
(assert= -1 (round (cos 3.14159)) "cos pi = -1"))
(deftest
"tan"
(assert= 0 (round (tan 0)) "tan 0 = 0")
(assert= 1 (round (tan 0.785398)) "tan pi/4 = 1"))
(deftest
"asin"
(assert= 0 (round (asin 0)) "asin 0 = 0")
(let
(r (asin 1))
(assert= true (and (> r 1.5) (< r 1.6)) "asin 1 ≈ pi/2")))
(deftest
"acos"
(assert= 0 (round (acos 1)) "acos 1 = 0")
(let
(r (acos 0))
(assert= true (and (> r 1.5) (< r 1.6)) "acos 0 ≈ pi/2")))
(deftest
"atan"
(assert= 0 (round (atan 0)) "atan 0 = 0")
(let
(r (atan 1))
(assert= true (and (> r 0.78) (< r 0.8)) "atan 1 ≈ pi/4"))
(let
(r (atan 1 1))
(assert=
true
(and (> r 0.78) (< r 0.8))
"atan 1 1 = atan2(1,1) ≈ pi/4"))
(let
(r (atan 1 0))
(assert= true (and (> r 1.5) (< r 1.6)) "atan 1 0 ≈ pi/2")))
(deftest
"exp"
(assert= 1 (round (exp 0)) "exp 0 = 1")
(let
(r (exp 1))
(assert= true (and (> r 2.71) (< r 2.72)) "exp 1 ≈ e")))
(deftest
"log"
(assert= 0 (round (log 1)) "log 1 = 0")
(let
(r (log 2.71828))
(assert= true (and (> r 0.99) (< r 1.01)) "log e ≈ 1"))))
(deftest
"expt"
(assert= 8 (expt 2 3) "2^3 = 8")
(assert= 1 (expt 5 0) "5^0 = 1")
(assert= 1000 (expt 10 3) "10^3 = 1000")
(let
(r (expt 2 0.5))
(assert= true (and (> r 1.41) (< r 1.43)) "2^0.5 ≈ sqrt(2)")))
(deftest
"quotient"
(assert= 3 (quotient 13 4) "13/4 = 3")
(assert=
-3
(quotient -13 4)
"-13/4 = -3 (truncate toward zero)")
(assert=
-3
(quotient 13 -4)
"13/-4 = -3 (truncate toward zero)")
(assert= 3 (quotient -13 -4) "-13/-4 = 3")
(assert= 0 (quotient 0 5) "0/5 = 0"))
(deftest
"gcd"
(assert= 6 (gcd 12 18) "gcd 12 18 = 6")
(assert= 1 (gcd 7 13) "gcd 7 13 = 1 (coprime)")
(assert= 4 (gcd 8 12) "gcd 8 12 = 4")
(assert= 5 (gcd 0 5) "gcd 0 5 = 5")
(assert= 6 (gcd -12 18) "gcd handles negatives"))
(deftest
"lcm"
(assert= 12 (lcm 4 6) "lcm 4 6 = 12")
(assert= 36 (lcm 12 18) "lcm 12 18 = 36")
(assert= 0 (lcm 0 5) "lcm 0 5 = 0")
(assert= 15 (lcm 3 5) "lcm 3 5 = 15"))
(deftest
"number->string"
(assert= "42" (number->string 42) "integer to string")
(assert= "0" (number->string 0) "zero to string")
(assert= "-7" (number->string -7) "negative to string")
(assert= "ff" (number->string 255 16) "255 in hex")
(assert= "1111" (number->string 15 2) "15 in binary")
(assert= "377" (number->string 255 8) "255 in octal")
(assert= "z" (number->string 35 36) "35 in base 36"))
(deftest
"string->number"
(assert= 42 (string->number "42") "string to integer")
(assert= -7 (string->number "-7") "negative string to integer")
(assert= 255 (string->number "ff" 16) "hex string")
(assert= 15 (string->number "1111" 2) "binary string")
(assert= 255 (string->number "377" 8) "octal string")
(assert= nil (string->number "not-a-number") "invalid returns nil")
(assert= nil (string->number "fg" 16) "invalid hex returns nil"))
(deftest
"numeric tower integration"
(assert=
true
(< (abs (- (sin (asin 0.5)) 0.5)) 0.0001)
"sin(asin(x)) = x")
(assert=
true
(< (abs (- (cos (acos 0.5)) 0.5)) 0.0001)
"cos(acos(x)) = x")
(assert= true (< (abs (- (exp (log 2)) 2)) 0.0001) "exp(log(x)) = x")
(assert=
(* 12 18)
(* (gcd 12 18) (lcm 12 18))
"gcd * lcm = a * b")))

View File

@@ -1,230 +0,0 @@
;; ==========================================================================
;; test-numeric-tower.sx — Numeric tower: Integer vs Float distinction
;;
;; Tests for float contagion, integer arithmetic, predicates,
;; coercions, parsing, and rendering.
;;
;; Note: Use fractional floats (1.5, 3.14) or exact->inexact for round floats,
;; since the SX serializer renders Number 1.0 as "1" (int form).
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Integer arithmetic — result stays Integer when all args are Integer
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:int-arithmetic"
(deftest "int + int = int" (assert (integer? (+ 1 2))))
(deftest "int + int value" (assert= (+ 1 2) 3))
(deftest "int - int = int" (assert (integer? (- 10 3))))
(deftest "int - int value" (assert= (- 10 3) 7))
(deftest "int * int = int" (assert (integer? (* 4 5))))
(deftest "int * int value" (assert= (* 4 5) 20))
(deftest "zero identity" (assert= (+ 0 0) 0))
(deftest "negative int" (assert= (- 0 5) -5))
(deftest
"int negation is int"
(assert (integer? (- 0 7))))
(deftest
"large int product"
(assert= (* 100 100) 10000)))
;; --------------------------------------------------------------------------
;; Float contagion — any float arg promotes result to float
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:float-contagion"
(deftest "int + float = float" (assert (float? (+ 1 1.5))))
(deftest "int + float value" (assert= (+ 1 1.5) 2.5))
(deftest "float + int = float" (assert (float? (+ 1.5 2))))
(deftest "float + float = float" (assert (float? (+ 1.5 2.5))))
(deftest "int * float = float" (assert (float? (* 2 1.5))))
(deftest "int * float value" (assert= (* 2 1.5) 3))
(deftest "int - float = float" (assert (float? (- 5 2.5))))
(deftest "float - int = float" (assert (float? (- 5.5 2))))
(deftest
"three args with float"
(assert (float? (+ 1 2 3.5))))
(deftest
"exact->inexact promotes to float"
(assert (float? (exact->inexact 5)))))
;; --------------------------------------------------------------------------
;; Division
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:division"
(deftest
"exact division value"
(assert= (/ 6 2) 3))
(deftest "inexact division value" (assert= (/ 1 4) 0.25))
(deftest "float / float = float" (assert (float? (/ 3.5 2.5))))
(deftest
"rational / int = rational"
(assert (rational? (/ 1/2 2))))
(deftest "rational division value" (assert= (/ 1/2 2) 1/4)))
;; --------------------------------------------------------------------------
;; Type predicates
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:predicates"
(deftest "integer? on int" (assert (integer? 42)))
(deftest "integer? on negative" (assert (integer? -7)))
(deftest "integer? on zero" (assert (integer? 0)))
(deftest
"integer? on float-int"
(assert (integer? (exact->inexact 2))))
(deftest "integer? on fractional float" (assert (not (integer? 1.5))))
(deftest "float? on 1.5" (assert (float? 1.5)))
(deftest
"float? on exact->inexact"
(assert (float? (exact->inexact 2))))
(deftest "float? on int" (assert (not (float? 42))))
(deftest "number? on int" (assert (number? 42)))
(deftest "number? on float" (assert (number? 3.14)))
(deftest "number? on rational" (assert (number? 1/3)))
(deftest "number? on string" (assert (not (number? "42"))))
(deftest "exact? on int" (assert (exact? 1)))
(deftest "exact? on rational" (assert (exact? 1/3)))
(deftest
"exact? on exact->inexact"
(assert (not (exact? (exact->inexact 1)))))
(deftest "inexact? on 1.5" (assert (inexact? 1.5)))
(deftest "inexact? on int" (assert (not (inexact? 3)))))
;; --------------------------------------------------------------------------
;; Coercions
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:coercions"
(deftest
"exact->inexact int"
(assert= (exact->inexact 3) 3))
(deftest
"exact->inexact produces float"
(assert (float? (exact->inexact 5))))
(deftest
"exact->inexact float passthrough"
(assert= (exact->inexact 1.5) 1.5))
(deftest "exact->inexact rational" (assert= (exact->inexact 1/4) 0.25))
(deftest "inexact->exact 1.5" (assert= (inexact->exact 1.5) 2))
(deftest
"inexact->exact produces int"
(assert (integer? (inexact->exact (exact->inexact 4)))))
(deftest "inexact->exact 2.7" (assert= (inexact->exact 2.7) 3))
(deftest
"inexact->exact int passthrough"
(assert= (inexact->exact 5) 5)))
;; --------------------------------------------------------------------------
;; floor / ceiling / truncate / round — return Integer for floats
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:rounding"
(deftest "floor 3.7" (assert= (floor 3.7) 3))
(deftest "floor produces int" (assert (integer? (floor 3.7))))
(deftest "floor negative" (assert= (floor -2.3) -3))
(deftest "truncate 3.9" (assert= (truncate 3.9) 3))
(deftest "truncate negative" (assert= (truncate -3.9) -3))
(deftest "truncate produces int" (assert (integer? (truncate 3.9))))
(deftest "round 2.3 down" (assert= (round 2.3) 2))
(deftest "round produces int" (assert (integer? (round 2.3))))
(deftest
"floor of int passthrough"
(assert= (floor 5) 5))
(deftest "floor of int stays int" (assert (integer? (floor 5)))))
;; --------------------------------------------------------------------------
;; parse-number distinguishes int vs float strings
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:parse-number"
(deftest
"parse-number int string"
(assert= (parse-number "42") 42))
(deftest
"parse-number int is integer?"
(assert (integer? (parse-number "42"))))
(deftest "parse-number 3.14" (assert= (parse-number "3.14") 3.14))
(deftest
"parse-number float is float?"
(assert (float? (parse-number "3.14"))))
(deftest
"parse-number 1.5 is float?"
(assert (float? (parse-number "1.5"))))
(deftest
"parse-number negative int"
(assert= (parse-number "-5") -5))
(deftest
"parse-number negative int is integer?"
(assert (integer? (parse-number "-5"))))
(deftest "parse-int returns integer" (assert (integer? (parse-int "7"))))
(deftest "parse-int value" (assert= (parse-int "7") 7)))
;; --------------------------------------------------------------------------
;; Equality across numeric types
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:equality"
(deftest "int = same int" (assert= 5 5))
(deftest
"int = float eq"
(assert (= 1 (exact->inexact 1))))
(deftest
"float = int eq"
(assert (= (exact->inexact 1) 1)))
(deftest "int != different int" (assert (!= 1 2)))
(deftest "int < float" (assert (< 1 1.5)))
(deftest "float > int" (assert (> 2.5 2)))
(deftest "int <= float" (assert (<= 2 2.5)))
(deftest "int >= int" (assert (>= 3 3))))
;; --------------------------------------------------------------------------
;; mod / remainder / modulo with integers
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:modulo"
(deftest
"mod int int = int"
(assert (integer? (mod 10 3))))
(deftest "mod value" (assert= (mod 10 3) 1))
(deftest
"remainder int int = int"
(assert (integer? (remainder 10 3))))
(deftest
"remainder value"
(assert= (remainder 10 3) 1)))
;; --------------------------------------------------------------------------
;; min / max with mixed types
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:min-max"
(deftest "min two ints" (assert= (min 3 7) 3))
(deftest
"min int result type"
(assert (integer? (min 3 7))))
(deftest "max two ints" (assert= (max 3 7) 7))
(deftest "min with float" (assert= (min 3 2.5) 2.5))
(deftest "max with float" (assert= (max 3 3.5) 3.5)))
;; --------------------------------------------------------------------------
;; str rendering of int vs float
;; --------------------------------------------------------------------------
(defsuite
"numeric-tower:stringify"
(deftest "str of int" (assert= (str 42) "42"))
(deftest "str of negative int" (assert= (str -5) "-5"))
(deftest "str of 3.14" (assert= (str 3.14) "3.14"))
(deftest "str of 1.5" (assert= (str 1.5) "1.5")))

View File

@@ -1,232 +0,0 @@
;; Phase 14 — String ports + eof-object
(deftest
"eof-object"
(deftest
"eof-object is eof"
(assert=
true
(eof-object? (eof-object))
"eof-object? returns true for eof-object"))
(deftest
"non-eof values are not eof"
(assert= false (eof-object? nil) "nil is not eof")
(assert= false (eof-object? "") "string is not eof")
(assert= false (eof-object? 0) "zero is not eof")
(assert= false (eof-object? false) "false is not eof"))
(deftest
"type-of eof-object"
(assert=
"eof-object"
(type-of (eof-object))
"type-of eof-object is eof-object")))
(deftest
"open-input-string"
(deftest
"creates input port"
(let
(p (open-input-string "hello"))
(assert= true (port? p) "is a port")
(assert= true (input-port? p) "is an input port")
(assert= false (output-port? p) "is not an output port")))
(deftest
"type-of input port"
(let
(p (open-input-string "x"))
(assert= "input-port" (type-of p) "type-of is input-port"))))
(deftest
"open-output-string"
(deftest
"creates output port"
(let
(p (open-output-string))
(assert= true (port? p) "is a port")
(assert= true (output-port? p) "is an output port")
(assert= false (input-port? p) "is not an input port")))
(deftest
"type-of output port"
(let
(p (open-output-string))
(assert= "output-port" (type-of p) "type-of is output-port"))))
(deftest
"read-char"
(deftest
"reads chars sequentially"
(let
(p (open-input-string "ab"))
(let
(c1 (read-char p))
(assert= true (char? c1) "first result is char")
(assert= 97 (char->integer c1) "first char is a"))))
(deftest
"reads second char"
(let
(p (open-input-string "ab"))
(read-char p)
(let
(c2 (read-char p))
(assert= true (char? c2) "second result is char")
(assert= 98 (char->integer c2) "second char is b"))))
(deftest
"returns eof at end"
(let
(p (open-input-string "x"))
(read-char p)
(assert= true (eof-object? (read-char p)) "eof after last char")))
(deftest
"empty string yields eof immediately"
(let
(p (open-input-string ""))
(assert= true (eof-object? (read-char p)) "eof from empty string"))))
(deftest
"peek-char"
(deftest
"peeks without consuming"
(let
(p (open-input-string "x"))
(let
(c1 (peek-char p))
(let
(c2 (peek-char p))
(assert=
(char->integer c1)
(char->integer c2)
"peek twice gives same char")))))
(deftest
"peek then read"
(let
(p (open-input-string "z"))
(let
(peeked (peek-char p))
(let
(read (read-char p))
(assert=
(char->integer peeked)
(char->integer read)
"peek and read agree")))))
(deftest
"peek at end returns eof"
(let
(p (open-input-string ""))
(assert= true (eof-object? (peek-char p)) "eof on empty peek"))))
(deftest
"read-line"
(deftest
"reads a single line"
(let
(p (open-input-string "hello"))
(assert= "hello" (read-line p) "reads whole string as line")))
(deftest
"reads line up to newline"
(let
(p (open-input-string "foo\nbar"))
(assert= "foo" (read-line p) "first line is foo")))
(deftest
"reads second line"
(let
(p (open-input-string "foo\nbar"))
(read-line p)
(assert= "bar" (read-line p) "second line is bar")))
(deftest
"returns eof on empty port"
(let
(p (open-input-string ""))
(assert= true (eof-object? (read-line p)) "eof on empty")))
(deftest
"returns eof after last line"
(let
(p (open-input-string "hi"))
(read-line p)
(assert= true (eof-object? (read-line p)) "eof after reading"))))
(deftest
"write-char and get-output-string"
(deftest
"write single char"
(let
(p (open-output-string))
(write-char (make-char 65) p)
(assert= "A" (get-output-string p) "write char A")))
(deftest
"write multiple chars"
(let
(p (open-output-string))
(write-char (make-char 72) p)
(write-char (make-char 105) p)
(assert= "Hi" (get-output-string p) "write Hi"))))
(deftest
"write-string"
(deftest
"write a string to port"
(let
(p (open-output-string))
(write-string "hello" p)
(assert= "hello" (get-output-string p) "write-string result")))
(deftest
"multiple writes concatenate"
(let
(p (open-output-string))
(write-string "foo" p)
(write-string "bar" p)
(assert= "foobar" (get-output-string p) "concatenated writes"))))
(deftest
"get-output-string idempotent"
(let
(p (open-output-string))
(write-string "test" p)
(assert= "test" (get-output-string p) "first call")
(assert= "test" (get-output-string p) "second call same result")))
(deftest
"char-ready?"
(deftest
"ready when chars available"
(let
(p (open-input-string "x"))
(assert= true (char-ready? p) "ready with content")))
(deftest
"not ready when empty"
(let
(p (open-input-string ""))
(assert= false (char-ready? p) "not ready when empty"))))
(deftest
"close-port"
(deftest
"close input port"
(let
(p (open-input-string "hello"))
(close-port p)
(assert= true (eof-object? (read-char p)) "read after close gives eof")))
(deftest
"close output port"
(let
(p (open-output-string))
(write-string "ok" p)
(close-port p)
(assert= "ok" (get-output-string p) "output preserved after close"))))
(deftest
"roundtrip string via ports"
(let
(in (open-input-string "abc"))
(let
(out (open-output-string))
(do
(let
(c1 (read-char in))
(when (not (eof-object? c1)) (write-char c1 out)))
(let
(c2 (read-char in))
(when (not (eof-object? c2)) (write-char c2 out)))
(let
(c3 (read-char in))
(when (not (eof-object? c3)) (write-char c3 out)))
(assert= "abc" (get-output-string out) "roundtrip via ports")))))

View File

@@ -6,36 +6,20 @@
;; Arithmetic
;; --------------------------------------------------------------------------
(defsuite
"arithmetic"
(defsuite "arithmetic"
(deftest "add" (assert-equal 3 (+ 1 2)))
(deftest
"add multiple"
(assert-equal 10 (+ 1 2 3 4)))
(deftest "add multiple" (assert-equal 10 (+ 1 2 3 4)))
(deftest "add zero" (assert-equal 5 (+ 5 0)))
(deftest
"add negative"
(assert-equal -1 (+ 1 -2)))
(deftest "add negative" (assert-equal -1 (+ 1 -2)))
(deftest "subtract" (assert-equal 3 (- 5 2)))
(deftest
"subtract negative"
(assert-equal 7 (- 5 -2)))
(deftest "subtract negative" (assert-equal 7 (- 5 -2)))
(deftest "multiply" (assert-equal 12 (* 3 4)))
(deftest
"multiply zero"
(assert-equal 0 (* 5 0)))
(deftest
"multiply negative"
(assert-equal -6 (* 2 -3)))
(deftest "multiply zero" (assert-equal 0 (* 5 0)))
(deftest "multiply negative" (assert-equal -6 (* 2 -3)))
(deftest "divide" (assert-equal 3 (/ 9 3)))
(deftest "divide float" (assert-equal 2.5 (/ 5 2)))
(deftest "mod" (assert-equal 1 (mod 7 3)))
(deftest
"mod negative"
(assert-true
(or
(= (mod -1 3) 2)
(= (mod -1 3) -1))))
(deftest "mod negative" (assert-true (or (= (mod -1 3) 2) (= (mod -1 3) -1))))
(deftest "inc" (assert-equal 6 (inc 5)))
(deftest "dec" (assert-equal 4 (dec 5)))
(deftest "abs positive" (assert-equal 5 (abs 5)))
@@ -48,8 +32,7 @@
;; Comparison
;; --------------------------------------------------------------------------
(defsuite
"comparison"
(defsuite "comparison"
(deftest "equal numbers" (assert-true (= 1 1)))
(deftest "not equal numbers" (assert-false (= 1 2)))
(deftest "equal strings" (assert-true (= "a" "a")))
@@ -69,8 +52,7 @@
;; Predicates
;; --------------------------------------------------------------------------
(defsuite
"predicates"
(defsuite "predicates"
(deftest "nil? nil" (assert-true (nil? nil)))
(deftest "nil? number" (assert-false (nil? 0)))
(deftest "nil? string" (assert-false (nil? "")))
@@ -94,22 +76,15 @@
;; String operations
;; --------------------------------------------------------------------------
(defsuite
"strings"
(deftest
"str concat"
(assert-equal "hello world" (str "hello" " " "world")))
(defsuite "strings"
(deftest "str concat" (assert-equal "hello world" (str "hello" " " "world")))
(deftest "str number" (assert-equal "42" (str 42)))
(deftest "str empty" (assert-equal "" (str)))
(deftest "len string" (assert-equal 5 (len "hello")))
(deftest "len empty" (assert-equal 0 (len "")))
(deftest
"slice"
(assert-equal "ell" (slice "hello" 1 4)))
(deftest "slice" (assert-equal "ell" (slice "hello" 1 4)))
(deftest "slice from" (assert-equal "llo" (slice "hello" 2)))
(deftest
"slice empty"
(assert-equal "" (slice "hello" 2 2)))
(deftest "slice empty" (assert-equal "" (slice "hello" 2 2)))
(deftest "join" (assert-equal "a,b,c" (join "," (list "a" "b" "c"))))
(deftest "join empty" (assert-equal "" (join "," (list))))
(deftest "join single" (assert-equal "a" (join "," (list "a"))))
@@ -126,238 +101,88 @@
(deftest "replace" (assert-equal "hXllo" (replace "hello" "e" "X")))
(deftest "string-length" (assert-equal 5 (string-length "hello")))
(deftest "index-of found" (assert-equal 2 (index-of "hello" "l")))
(deftest
"index-of not found"
(assert-equal -1 (index-of "hello" "z"))))
(deftest "index-of not found" (assert-equal -1 (index-of "hello" "z"))))
;; --------------------------------------------------------------------------
;; List operations
;; --------------------------------------------------------------------------
(defsuite
"lists"
(deftest
"list create"
(assert-equal
(list 1 2 3)
(list 1 2 3)))
(deftest
"first"
(assert-equal 1 (first (list 1 2 3))))
(defsuite "lists"
(deftest "list create" (assert-equal (list 1 2 3) (list 1 2 3)))
(deftest "first" (assert-equal 1 (first (list 1 2 3))))
(deftest "first empty" (assert-nil (first (list))))
(deftest
"rest"
(assert-equal
(list 2 3)
(rest (list 1 2 3))))
(deftest "rest" (assert-equal (list 2 3) (rest (list 1 2 3))))
(deftest "rest single" (assert-equal (list) (rest (list 1))))
(deftest "rest empty" (assert-equal (list) (rest (list))))
(deftest
"nth"
(assert-equal
2
(nth (list 1 2 3) 1)))
(deftest
"nth out of bounds"
(assert-nil (nth (list 1 2) 5)))
(deftest
"last"
(assert-equal 3 (last (list 1 2 3))))
(deftest "nth" (assert-equal 2 (nth (list 1 2 3) 1)))
(deftest "nth out of bounds" (assert-nil (nth (list 1 2) 5)))
(deftest "last" (assert-equal 3 (last (list 1 2 3))))
(deftest "last single" (assert-equal 1 (last (list 1))))
(deftest
"len list"
(assert-equal 3 (len (list 1 2 3))))
(deftest "len list" (assert-equal 3 (len (list 1 2 3))))
(deftest "len empty" (assert-equal 0 (len (list))))
(deftest
"cons"
(assert-equal
(list 0 1 2)
(cons 0 (list 1 2))))
(deftest
"append"
(assert-equal
(list 1 2 3 4)
(append (list 1 2) (list 3 4))))
(deftest
"append element"
(assert-equal
(list 1 2 3)
(append (list 1 2) (list 3))))
(deftest
"slice list"
(assert-equal
(list 2 3)
(slice
(list 1 2 3 4)
1
3)))
(deftest
"concat"
(assert-equal
(list 1 2 3 4)
(concat (list 1 2) (list 3 4))))
(deftest
"reverse"
(assert-equal
(list 3 2 1)
(reverse (list 1 2 3))))
(deftest "cons" (assert-equal (list 0 1 2) (cons 0 (list 1 2))))
(deftest "append" (assert-equal (list 1 2 3 4) (append (list 1 2) (list 3 4))))
(deftest "append element" (assert-equal (list 1 2 3) (append (list 1 2) (list 3))))
(deftest "slice list" (assert-equal (list 2 3) (slice (list 1 2 3 4) 1 3)))
(deftest "concat" (assert-equal (list 1 2 3 4) (concat (list 1 2) (list 3 4))))
(deftest "reverse" (assert-equal (list 3 2 1) (reverse (list 1 2 3))))
(deftest "reverse empty" (assert-equal (list) (reverse (list))))
(deftest
"contains? list"
(assert-true
(contains? (list 1 2 3) 2)))
(deftest
"contains? list false"
(assert-false
(contains? (list 1 2 3) 5)))
(deftest
"range"
(assert-equal
(list 0 1 2)
(range 0 3)))
(deftest
"range step"
(assert-equal
(list 0 2 4)
(range 0 6 2)))
(deftest
"flatten"
(assert-equal
(list 1 2 3 4)
(flatten
(list (list 1 2) (list 3 4))))))
(deftest "contains? list" (assert-true (contains? (list 1 2 3) 2)))
(deftest "contains? list false" (assert-false (contains? (list 1 2 3) 5)))
(deftest "range" (assert-equal (list 0 1 2) (range 0 3)))
(deftest "range step" (assert-equal (list 0 2 4) (range 0 6 2)))
(deftest "flatten" (assert-equal (list 1 2 3 4) (flatten (list (list 1 2) (list 3 4))))))
;; --------------------------------------------------------------------------
;; Dict operations
;; --------------------------------------------------------------------------
(defsuite
"dicts"
(deftest
"dict create"
(assert-equal 1 (get (dict "a" 1 "b" 2) "a")))
(defsuite "dicts"
(deftest "dict create" (assert-equal 1 (get (dict "a" 1 "b" 2) "a")))
(deftest "get missing" (assert-nil (get (dict "a" 1) "z")))
(deftest
"get default"
(assert-equal 99 (get (dict "a" 1) "z" 99)))
(deftest
"keys"
(assert-true
(contains? (keys (dict "a" 1 "b" 2)) "a")))
(deftest "get default" (assert-equal 99 (get (dict "a" 1) "z" 99)))
(deftest "keys" (assert-true (contains? (keys (dict "a" 1 "b" 2)) "a")))
(deftest "has-key?" (assert-true (has-key? (dict "a" 1) "a")))
(deftest
"has-key? false"
(assert-false (has-key? (dict "a" 1) "z")))
(deftest
"assoc"
(assert-equal
2
(get (assoc (dict "a" 1) "b" 2) "b")))
(deftest
"dissoc"
(assert-false
(has-key? (dissoc (dict "a" 1 "b" 2) "a") "a")))
(deftest
"len dict"
(assert-equal 2 (len (dict "a" 1 "b" 2))))
(deftest "has-key? false" (assert-false (has-key? (dict "a" 1) "z")))
(deftest "assoc" (assert-equal 2 (get (assoc (dict "a" 1) "b" 2) "b")))
(deftest "dissoc" (assert-false (has-key? (dissoc (dict "a" 1 "b" 2) "a") "a")))
(deftest "len dict" (assert-equal 2 (len (dict "a" 1 "b" 2))))
(deftest "len empty dict" (assert-equal 0 (len (dict))))
(deftest "empty? dict" (assert-true (empty? (dict))))
(deftest
"empty? nonempty dict"
(assert-false (empty? (dict "a" 1)))))
(deftest "empty? nonempty dict" (assert-false (empty? (dict "a" 1)))))
;; --------------------------------------------------------------------------
;; Higher-order functions
;; --------------------------------------------------------------------------
(defsuite
"higher-order"
(deftest
"map"
(assert-equal
(list 2 4 6)
(map
(fn (x) (* x 2))
(list 1 2 3))))
(defsuite "higher-order"
(deftest "map" (assert-equal (list 2 4 6) (map (fn (x) (* x 2)) (list 1 2 3))))
(deftest "map empty" (assert-equal (list) (map (fn (x) x) (list))))
(deftest
"filter"
(assert-equal
(list 2 4)
(filter
(fn (x) (= (mod x 2) 0))
(list 1 2 3 4 5))))
(deftest
"filter none"
(assert-equal
(list)
(filter (fn (x) false) (list 1 2 3))))
(deftest
"reduce"
(assert-equal
10
(reduce
(fn (acc x) (+ acc x))
0
(list 1 2 3 4))))
(deftest
"reduce empty"
(assert-equal
0
(reduce (fn (acc x) (+ acc x)) 0 (list))))
(deftest
"some true"
(assert-true
(some
(fn (x) (> x 3))
(list 1 2 3 4 5))))
(deftest
"some false"
(assert-false
(some
(fn (x) (> x 10))
(list 1 2 3))))
(deftest "filter" (assert-equal (list 2 4) (filter (fn (x) (= (mod x 2) 0)) (list 1 2 3 4 5))))
(deftest "filter none" (assert-equal (list) (filter (fn (x) false) (list 1 2 3))))
(deftest "reduce" (assert-equal 10 (reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4))))
(deftest "reduce empty" (assert-equal 0 (reduce (fn (acc x) (+ acc x)) 0 (list))))
(deftest "some true" (assert-true (some (fn (x) (> x 3)) (list 1 2 3 4 5))))
(deftest "some false" (assert-false (some (fn (x) (> x 10)) (list 1 2 3))))
(deftest "some empty" (assert-false (some (fn (x) true) (list))))
(deftest
"every? true"
(assert-true
(every?
(fn (x) (> x 0))
(list 1 2 3))))
(deftest
"every? false"
(assert-false
(every?
(fn (x) (> x 2))
(list 1 2 3))))
(deftest "every? true" (assert-true (every? (fn (x) (> x 0)) (list 1 2 3))))
(deftest "every? false" (assert-false (every? (fn (x) (> x 2)) (list 1 2 3))))
(deftest "every? empty" (assert-true (every? (fn (x) false) (list))))
(deftest
"for-each returns nil"
(let
((log (list)))
(for-each
(fn (x) (append! log x))
(list 1 2 3))
(deftest "for-each returns nil"
(let ((log (list)))
(for-each (fn (x) (append! log x)) (list 1 2 3))
(assert-equal (list 1 2 3) log)))
(deftest
"map-indexed"
(assert-equal
(list (list 0 "a") (list 1 "b"))
(deftest "map-indexed"
(assert-equal (list (list 0 "a") (list 1 "b"))
(map-indexed (fn (i x) (list i x)) (list "a" "b")))))
;; --------------------------------------------------------------------------
;; Type coercion
;; --------------------------------------------------------------------------
(defsuite
"type-coercion"
(deftest
"str bool"
(assert-true (or (= (str true) "true") (= (str true) "True"))))
(defsuite "type-coercion"
(deftest "str bool" (assert-true (or (= (str true) "true") (= (str true) "True"))))
(deftest "str nil" (assert-equal "" (str nil)))
(deftest
"str list"
(assert-true
(not (empty? (str (list 1 2 3))))))
(deftest "str list" (assert-true (not (empty? (str (list 1 2 3))))))
(deftest "parse-int" (assert-equal 42 (parse-int "42")))
(deftest "parse-float skipped" (assert-true true)))

View File

@@ -1,150 +0,0 @@
(defsuite
"promises"
(deftest
"delay creates a promise"
(do (assert (promise? (delay 42)))))
(deftest
"delay does not evaluate immediately"
(do
(let
((count 0))
(let
((p (delay (do (set! count (+ count 1)) count))))
(assert= 0 count)))))
(deftest
"force evaluates the expression"
(do (assert= 42 (force (delay 42)))))
(deftest
"force with arithmetic"
(do (assert= 10 (force (delay (+ 3 7))))))
(deftest
"force memoises result"
(do
(let
((count 0))
(let
((p (delay (do (set! count (+ count 1)) count))))
(force p)
(force p)
(assert= 1 count)))))
(deftest
"force returns same value on repeated calls"
(do
(let
((p (delay (+ 1 2))))
(assert= 3 (force p))
(assert= 3 (force p)))))
(deftest
"make-promise creates an already-forced promise"
(do
(let
((p (make-promise 99)))
(assert (promise? p))
(assert= 99 (force p)))))
(deftest
"make-promise memoises without evaluating"
(do
(let
((count 0))
(let
((p (make-promise 42)))
(force p)
(force p)
(assert= 0 count)))))
(deftest
"promise? returns true for delay"
(do (assert (promise? (delay 1)))))
(deftest
"promise? returns true for make-promise"
(do (assert (promise? (make-promise 1)))))
(deftest
"promise? returns false for non-promise"
(do
(assert= false (promise? 42))
(assert= false (promise? "hello"))
(assert= false (promise? nil))
(assert= false (promise? (list 1 2)))))
(deftest
"force non-promise returns value unchanged"
(do
(assert= 42 (force 42))
(assert= "hi" (force "hi"))
(assert= nil (force nil))))
(deftest
"delay captures environment"
(do
(let
((x 10))
(let
((p (delay (+ x 5))))
(assert= 15 (force p))))))
(deftest
"delay-force basic"
(do (assert= 42 (force (delay-force (delay 42))))))
(deftest
"delay-force chains"
(do
(assert=
5
(force (delay-force (delay-force (delay 5)))))))
(deftest
"delay with string"
(do (assert= "hello" (force (delay "hello")))))
(deftest
"delay with list"
(do
(assert-equal
(list 1 2 3)
(force (delay (list 1 2 3))))))
(deftest
"delay with function call"
(do (assert= 6 (force (delay (* 2 3))))))
(deftest
"nested delay"
(do
(let
((p (delay (delay 99))))
(assert (promise? (force p))))))
(deftest
"force already forced promise"
(do
(let
((p (make-promise 7)))
(assert= 7 (force p))
(assert= 7 (force p)))))
(deftest
"lazy stream first element"
(do
(define (stream-cons x s) (delay (list x s)))
(define (stream-car s) (first (force s)))
(define (stream-cdr s) (nth (force s) 1))
(let
((s (stream-cons 1 (stream-cons 2 (stream-cons 3 nil)))))
(assert= 1 (stream-car s))
(assert= 2 (stream-car (stream-cdr s))))))
(deftest
"delay-force is a promise"
(do (assert (promise? (delay-force (delay 1))))))
(deftest
"force with side effects runs once"
(do
(let
((log (list)))
(let
((p (delay (do (set! log (cons 42 log)) 42))))
(force p)
(force p)
(assert= 1 (len log))))))
(deftest
"make-promise with nil"
(do
(let
((p (make-promise nil)))
(assert (promise? p))
(assert= nil (force p)))))
(deftest
"delay in let binding"
(do
(let
((p (delay (+ 10 20))))
(assert= 30 (force p))))))

View File

@@ -1,135 +0,0 @@
;; ==========================================================================
;; test-rationals.sx — Rational number type: literals, arithmetic, tower
;;
;; Note: in the JS host, (/ int int) returns float (backward-compatible).
;; Use rational literals (1/3, 3/4) or make-rational for exact rationals.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Literals and type
;; --------------------------------------------------------------------------
(defsuite
"rationals:literals"
(deftest "1/3 is rational" (assert (rational? 1/3)))
(deftest "1/2 is rational" (assert (rational? 1/2)))
(deftest "2/3 is rational" (assert (rational? 2/3)))
(deftest "literal numerator 1/3" (assert= (numerator 1/3) 1))
(deftest "literal denominator 1/3" (assert= (denominator 1/3) 3))
(deftest "literal numerator 2/3" (assert= (numerator 2/3) 2))
(deftest "auto-reduce 2/4 = 1/2" (assert= 2/4 1/2))
(deftest "auto-reduce 6/9 = 2/3" (assert= 6/9 2/3))
(deftest "negative literal" (assert= (numerator -1/3) -1)))
;; --------------------------------------------------------------------------
;; Constructor and predicates
;; --------------------------------------------------------------------------
(defsuite
"rationals:constructor"
(deftest
"make-rational basic"
(assert (rational? (make-rational 1 3))))
(deftest
"make-rational reduces"
(assert= (make-rational 2 4) 1/2))
(deftest
"make-rational exact int"
(assert (integer? (make-rational 6 3))))
(deftest
"make-rational 6/3 = 2"
(assert= (make-rational 6 3) 2))
(deftest
"make-rational negative"
(assert= (numerator (make-rational -1 3)) -1))
(deftest
"make-rational neg denom"
(assert= (numerator (make-rational 1 -3)) -1))
(deftest "rational? on int" (assert (not (rational? 5))))
(deftest "rational? on float" (assert (not (rational? 1.5))))
(deftest "rational? on string" (assert (not (rational? "1/2"))))
(deftest "number? on rational" (assert (number? 1/3)))
(deftest "exact? on rational" (assert (exact? 1/3)))
(deftest "inexact? on rational" (assert (not (inexact? 1/3))))
(deftest "integer? on rational" (assert (not (integer? 1/3))))
(deftest "dict? on rational" (assert (not (dict? 1/3)))))
;; --------------------------------------------------------------------------
;; Accessors
;; --------------------------------------------------------------------------
(defsuite
"rationals:accessors"
(deftest "numerator 1/3" (assert= (numerator 1/3) 1))
(deftest "denominator 1/3" (assert= (denominator 1/3) 3))
(deftest "numerator 3/4" (assert= (numerator 3/4) 3))
(deftest "denominator 3/4" (assert= (denominator 3/4) 4))
(deftest "numerator of int" (assert= (numerator 5) 5))
(deftest
"denominator of int"
(assert= (denominator 5) 1)))
;; --------------------------------------------------------------------------
;; Arithmetic
;; --------------------------------------------------------------------------
(defsuite
"rationals:arithmetic"
(deftest "add two rationals" (assert= (+ 1/3 1/3) 2/3))
(deftest "add to integer" (assert= (+ 1 1/2) 3/2))
(deftest "add integer to rational" (assert= (+ 1/2 1) 3/2))
(deftest "add reduces" (assert= (+ 1/6 1/6) 1/3))
(deftest "add to whole number" (assert (integer? (+ 1/2 1/2))))
(deftest "add whole = 1" (assert= (+ 1/2 1/2) 1))
(deftest "subtract rationals" (assert= (- 3/4 1/4) 1/2))
(deftest "subtract int from rational" (assert= (- 3/2 1) 1/2))
(deftest "negate rational" (assert= (- 1/3) -1/3))
(deftest "multiply rationals" (assert= (* 2/3 3/4) 1/2))
(deftest "multiply int and rational" (assert= (* 2 1/3) 2/3))
(deftest "multiply reduces to int" (assert (integer? (* 3 1/3))))
(deftest "divide rational by int" (assert= (/ 2/3 2) 1/3))
(deftest "divide rational by rational" (assert= (/ 1/2 1/4) 2))
(deftest
"divide rational gives int when exact"
(assert (integer? (/ 1/2 1/2)))))
;; --------------------------------------------------------------------------
;; Float contagion
;; --------------------------------------------------------------------------
(defsuite
"rationals:float-contagion"
(deftest "rational + float = float" (assert (float? (+ 1/3 0.5))))
(deftest "float + rational = float" (assert (float? (+ 0.5 1/3))))
(deftest "rational * float = float" (assert (float? (* 1/2 2))))
(deftest "rational - float = float" (assert (float? (- 1/2 0.1)))))
;; --------------------------------------------------------------------------
;; Comparison
;; --------------------------------------------------------------------------
(defsuite
"rationals:comparison"
(deftest "equal rationals" (assert (= 1/2 1/2)))
(deftest "equal reduced" (assert (= 2/4 1/2)))
(deftest "not equal" (assert (not (= 1/3 1/2))))
(deftest "less than" (assert (< 1/3 1/2)))
(deftest "less than int" (assert (< 1/3 1)))
(deftest "greater than" (assert (> 2/3 1/2)))
(deftest "less equal" (assert (<= 1/3 1/3)))
(deftest "greater equal" (assert (>= 2/3 2/3)))
(deftest "rational less than float" (assert (< 1/3 0.5))))
;; --------------------------------------------------------------------------
;; Coercion
;; --------------------------------------------------------------------------
(defsuite
"rationals:coercion"
(deftest "exact->inexact 1/2" (assert= (exact->inexact 1/2) 0.5))
(deftest "exact->inexact 1/4" (assert= (exact->inexact 1/4) 0.25))
(deftest
"exact->inexact 1/3 is float"
(assert (float? (exact->inexact 1/3))))
(deftest "number->string 1/2" (assert= (number->string 1/2) "1/2"))
(deftest "number->string 3/4" (assert= (number->string 3/4) "3/4")))

View File

@@ -1,212 +0,0 @@
;; ==========================================================================
;; test-read-write.sx — Tests for read / write / display / newline
;; ==========================================================================
;; --------------------------------------------------------------------------
;; read — parse one datum from an input port
;; --------------------------------------------------------------------------
(defsuite
"read:basics"
(deftest
"read integer"
(let ((p (open-input-string "42"))) (assert= (read p) 42)))
(deftest
"read float"
(let ((p (open-input-string "3.14"))) (assert= (read p) 3.14)))
(deftest
"read string"
(let ((p (open-input-string "\"hello\""))) (assert= (read p) "hello")))
(deftest
"read boolean true"
(let ((p (open-input-string "#t"))) (assert (read p))))
(deftest
"read boolean false"
(let ((p (open-input-string "#f"))) (assert (not (read p)))))
(deftest
"read nil"
(let ((p (open-input-string "()"))) (assert-nil (read p))))
(deftest
"read list"
(let
((p (open-input-string "(1 2 3)")))
(assert= (read p) (list 1 2 3))))
(deftest
"read nested list"
(let
((p (open-input-string "(+ 1 (* 2 3))")))
(assert=
(read p)
(list (quote +) 1 (list (quote *) 2 3))))))
;; --------------------------------------------------------------------------
;; read — eof and multi-read
;; --------------------------------------------------------------------------
(defsuite
"read:eof"
(deftest
"read eof returns eof-object"
(let ((p (open-input-string ""))) (assert (eof-object? (read p)))))
(deftest
"read whitespace-only returns eof"
(let ((p (open-input-string " "))) (assert (eof-object? (read p)))))
(deftest
"read two forms"
(let
((p (open-input-string "1 2")))
(let
((a (read p)) (b (read p)))
(assert (and (= a 1) (= b 2))))))
(deftest
"read returns eof after last form"
(let
((p (open-input-string "42")))
(read p)
(assert (eof-object? (read p))))))
;; --------------------------------------------------------------------------
;; write — serialize with quoting
;; --------------------------------------------------------------------------
(defsuite
"write:basics"
(deftest "write integer" (assert= (write-to-string 42) "42"))
(deftest
"write negative integer"
(assert= (write-to-string -5) "-5"))
(deftest "write float" (assert= (write-to-string 3.14) "3.14"))
(deftest "write true" (assert= (write-to-string true) "#t"))
(deftest "write false" (assert= (write-to-string false) "#f"))
(deftest "write nil" (assert= (write-to-string nil) "()"))
(deftest
"write string quotes"
(assert= (write-to-string "hello") "\"hello\""))
(deftest
"write string with escapes"
(assert= (write-to-string "a\"b") "\"a\\\"b\""))
(deftest
"write list"
(assert=
(write-to-string (list 1 2 3))
"(1 2 3)"))
(deftest
"write nested list"
(assert=
(write-to-string (list 1 (list 2 3)))
"(1 (2 3))"))
(deftest "write symbol" (assert= (write-to-string (quote foo)) "foo"))
(deftest "write rational" (assert= (write-to-string 1/3) "1/3")))
;; --------------------------------------------------------------------------
;; display — serialize without quoting
;; --------------------------------------------------------------------------
(defsuite
"display:basics"
(deftest "display integer" (assert= (display-to-string 42) "42"))
(deftest
"display string no quotes"
(assert= (display-to-string "hello") "hello"))
(deftest "display true" (assert= (display-to-string true) "#t"))
(deftest "display nil" (assert= (display-to-string nil) "()"))
(deftest
"display list"
(assert=
(display-to-string (list 1 2 3))
"(1 2 3)")))
;; --------------------------------------------------------------------------
;; write vs display distinction
;; --------------------------------------------------------------------------
(defsuite
"write-vs-display"
(deftest
"write quotes string, display does not"
(let
((s "hello"))
(assert
(and
(= (write-to-string s) "\"hello\"")
(= (display-to-string s) "hello")))))
(deftest
"write and display same for numbers"
(assert= (write-to-string 42) (display-to-string 42)))
(deftest
"write and display same for lists"
(assert=
(write-to-string (list 1 2))
(display-to-string (list 1 2)))))
;; --------------------------------------------------------------------------
;; write/display/newline to port
;; --------------------------------------------------------------------------
(defsuite
"write-to-port"
(deftest
"write to output port"
(let
((p (open-output-string)))
(write 42 p)
(assert= (get-output-string p) "42")))
(deftest
"display to output port"
(let
((p (open-output-string)))
(display "hi" p)
(assert= (get-output-string p) "hi")))
(deftest
"newline to output port"
(let
((p (open-output-string)))
(newline p)
(assert= (get-output-string p) "\n")))
(deftest
"write then newline"
(let
((p (open-output-string)))
(write "hello" p)
(newline p)
(assert= (get-output-string p) "\"hello\"\n")))
(deftest
"display multiple values"
(let
((p (open-output-string)))
(display 1 p)
(display " " p)
(display 2 p)
(assert= (get-output-string p) "1 2"))))
;; --------------------------------------------------------------------------
;; write round-trip
;; --------------------------------------------------------------------------
(defsuite
"write:round-trip"
(deftest
"integer round-trips"
(let
((p (open-input-string (write-to-string 42))))
(assert= (read p) 42)))
(deftest
"string round-trips"
(let
((p (open-input-string (write-to-string "hello world"))))
(assert= (read p) "hello world")))
(deftest
"list round-trips"
(let
((p (open-input-string (write-to-string (list 1 2 3)))))
(assert= (read p) (list 1 2 3))))
(deftest
"boolean true round-trips"
(let
((p (open-input-string (write-to-string true))))
(assert (read p))))
(deftest
"boolean false round-trips"
(let
((p (open-input-string (write-to-string false))))
(assert (not (read p))))))

View File

@@ -1,191 +0,0 @@
;; ==========================================================================
;; test-regexp.sx — Tests for regexp primitives
;; ==========================================================================
;; --------------------------------------------------------------------------
;; make-regexp / regexp?
;; --------------------------------------------------------------------------
(defsuite
"regexp:create"
(deftest "make-regexp returns regexp" (assert (regexp? (make-regexp "abc"))))
(deftest
"make-regexp with flags"
(assert (regexp? (make-regexp "[a-z]+" "i"))))
(deftest "regexp? true for regexp" (assert (regexp? (make-regexp "x"))))
(deftest "regexp? false for string" (assert (not (regexp? "abc"))))
(deftest "regexp? false for nil" (assert (not (regexp? nil))))
(deftest
"regexp-source"
(assert= (regexp-source (make-regexp "hello")) "hello"))
(deftest
"regexp-flags"
(assert= (regexp-flags (make-regexp "x" "im")) "im"))
(deftest
"regexp-flags empty string"
(assert= (regexp-flags (make-regexp "x")) "")))
;; --------------------------------------------------------------------------
;; regexp-match — basic
;; --------------------------------------------------------------------------
(defsuite
"regexp:match"
(deftest
"match returns dict"
(let
((m (regexp-match (make-regexp "hel+o") "hello world")))
(assert (dict? m))))
(deftest
"match :match key"
(let
((m (regexp-match (make-regexp "hel+o") "say hello")))
(assert= (get m "match") "hello")))
(deftest
"match :start key"
(let
((m (regexp-match (make-regexp "lo") "hello")))
(assert= (get m "start") 3)))
(deftest
"match :end key"
(let
((m (regexp-match (make-regexp "lo") "hello")))
(assert= (get m "end") 5)))
(deftest
"no match returns nil"
(assert-nil (regexp-match (make-regexp "xyz") "hello")))
(deftest
"match at start"
(let
((m (regexp-match (make-regexp "^hel") "hello")))
(assert= (get m "start") 0)))
(deftest
"match digit pattern"
(let
((m (regexp-match (make-regexp "[0-9]+") "abc 123 def")))
(assert= (get m "match") "123"))))
;; --------------------------------------------------------------------------
;; regexp-match — groups
;; --------------------------------------------------------------------------
(defsuite
"regexp:groups"
(deftest
"no capture groups → empty list"
(let
((m (regexp-match (make-regexp "hello") "hello world")))
(assert= (length (get m "groups")) 0)))
(deftest
"one capture group"
(let
((m (regexp-match (make-regexp "([0-9]+)") "price: 42")))
(assert= (first (get m "groups")) "42")))
(deftest
"two capture groups"
(let
((m (regexp-match (make-regexp "([a-z]+)=([0-9]+)") "x=10")))
(let
((gs (get m "groups")))
(assert
(and (= (first gs) "x") (= (first (rest gs)) "10")))))))
;; --------------------------------------------------------------------------
;; regexp-match-all
;; --------------------------------------------------------------------------
(defsuite
"regexp:match-all"
(deftest
"match-all returns list"
(let
((ms (regexp-match-all (make-regexp "[0-9]+") "1 and 2 and 3")))
(assert (list? ms))))
(deftest
"match-all count"
(assert=
(length (regexp-match-all (make-regexp "[0-9]+") "1 and 2 and 3"))
3))
(deftest
"match-all first match"
(let
((ms (regexp-match-all (make-regexp "[0-9]+") "10 20 30")))
(assert= (get (first ms) "match") "10")))
(deftest
"match-all empty when no match"
(assert=
(length (regexp-match-all (make-regexp "xyz") "hello"))
0)))
;; --------------------------------------------------------------------------
;; regexp-replace / regexp-replace-all
;; --------------------------------------------------------------------------
(defsuite
"regexp:replace"
(deftest
"replace first match"
(assert= (regexp-replace (make-regexp "o+") "foobar boo" "0") "f0bar boo"))
(deftest
"replace no match returns original"
(assert= (regexp-replace (make-regexp "xyz") "hello" "X") "hello"))
(deftest
"replace-all all matches"
(assert= (regexp-replace-all (make-regexp "o") "foo boo" "0") "f00 b00"))
(deftest
"replace with $& (whole match)"
(assert=
(regexp-replace (make-regexp "[0-9]+") "price 42" "[$&]")
"price [42]"))
(deftest
"replace-all removes digits"
(assert=
(regexp-replace-all (make-regexp "[0-9]") "a1b2c3" "")
"abc")))
;; --------------------------------------------------------------------------
;; regexp-split
;; --------------------------------------------------------------------------
(defsuite
"regexp:split"
(deftest
"split on whitespace"
(let
((parts (regexp-split (make-regexp " +") "hello world foo")))
(assert= (length parts) 3)))
(deftest
"split first part"
(let
((parts (regexp-split (make-regexp ",") "a,b,c")))
(assert= (first parts) "a")))
(deftest
"split last part"
(let
((parts (regexp-split (make-regexp ",") "a,b,c")))
(assert= (first (rest (rest parts))) "c")))
(deftest
"split no match → single element"
(let
((parts (regexp-split (make-regexp ",") "hello")))
(assert= (length parts) 1))))
;; --------------------------------------------------------------------------
;; flags
;; --------------------------------------------------------------------------
(defsuite
"regexp:flags"
(deftest
"case-insensitive flag"
(let
((m (regexp-match (make-regexp "HELLO" "i") "hello world")))
(assert (not (nil? m)))))
(deftest
"case-sensitive without flag"
(assert-nil (regexp-match (make-regexp "HELLO") "hello world")))
(deftest
"multiline ^ matches line starts"
(let
((ms (regexp-match-all (make-regexp "^[a-z]" "m") "a\nb\nc")))
(assert= (length ms) 3))))

View File

@@ -1,202 +0,0 @@
;; test-sequences.sx — Phase 11: sequence protocol tests
(defsuite
"sequences"
(deftest
"seq-to-list nil is empty list"
(assert-equal (list) (seq-to-list nil)))
(deftest
"seq-to-list list is identity"
(assert-equal
(list 1 2 3)
(seq-to-list (list 1 2 3))))
(deftest
"seq-to-list vector to list"
(assert-equal
(list 10 20 30)
(seq-to-list (vector 10 20 30))))
(deftest
"seq-to-list string to char list"
(assert-equal (list "a" "b" "c") (seq-to-list "abc")))
(deftest
"seq-to-list empty string to empty list"
(assert-equal (list) (seq-to-list "")))
(deftest
"sequence-to-list nil is empty list"
(assert-equal (list) (sequence-to-list nil)))
(deftest
"sequence-to-list list is identity"
(assert-equal
(list 1 2 3)
(sequence-to-list (list 1 2 3))))
(deftest
"sequence-to-list vector to list"
(assert-equal (list "x" "y") (sequence-to-list (vector "x" "y"))))
(deftest
"sequence-to-list string to char list"
(assert-equal (list "h" "i") (sequence-to-list "hi")))
(deftest
"sequence-to-vector nil is empty vector"
(let
((v (sequence-to-vector nil)))
(do (assert (vector? v)) (assert= 0 (vector-length v)))))
(deftest
"sequence-to-vector list to vector"
(let
((v (sequence-to-vector (list 1 2 3))))
(do
(assert (vector? v))
(assert= 3 (vector-length v))
(assert= 1 (vector-ref v 0))
(assert= 3 (vector-ref v 2)))))
(deftest
"sequence-to-vector string to vector of chars"
(let
((v (sequence-to-vector "abc")))
(do
(assert (vector? v))
(assert= 3 (vector-length v))
(assert= "a" (vector-ref v 0))
(assert= "c" (vector-ref v 2)))))
(deftest
"sequence-length nil is 0"
(assert= 0 (sequence-length nil)))
(deftest
"sequence-length empty list is 0"
(assert= 0 (sequence-length (list))))
(deftest
"sequence-length list of 3"
(assert=
3
(sequence-length (list 1 2 3))))
(deftest
"sequence-length empty vector is 0"
(assert= 0 (sequence-length (vector))))
(deftest
"sequence-length vector of 4"
(assert=
4
(sequence-length (vector 10 20 30 40))))
(deftest
"sequence-length empty string is 0"
(assert= 0 (sequence-length "")))
(deftest
"sequence-length string hello"
(assert= 5 (sequence-length "hello")))
(deftest
"sequence-ref list first"
(assert=
10
(sequence-ref (list 10 20 30) 0)))
(deftest
"sequence-ref list last"
(assert=
30
(sequence-ref (list 10 20 30) 2)))
(deftest
"sequence-ref vector middle"
(assert=
20
(sequence-ref (vector 10 20 30) 1)))
(deftest
"sequence-ref string first char"
(assert= "h" (sequence-ref "hello" 0)))
(deftest
"sequence-ref string last char"
(assert= "o" (sequence-ref "hello" 4)))
(deftest
"sequence-append two lists"
(assert-equal
(list 1 2 3 4)
(sequence-append
(list 1 2)
(list 3 4))))
(deftest
"sequence-append list with empty"
(assert-equal
(list 1 2)
(sequence-append (list 1 2) (list))))
(deftest
"sequence-append two strings"
(assert= "hello world" (sequence-append "hello " "world")))
(deftest
"sequence-append empty strings"
(assert= "abc" (sequence-append "" "abc")))
(deftest
"in-range 1-arg gives 0..n-1"
(assert-equal
(list 0 1 2 3 4)
(in-range 5)))
(deftest
"in-range 1-arg zero is empty"
(assert-equal (list) (in-range 0)))
(deftest
"in-range 2-arg start and end"
(assert-equal
(list 1 2 3)
(in-range 1 4)))
(deftest
"in-range 2-arg same start end is empty"
(assert-equal (list) (in-range 3 3)))
(deftest
"in-range 3-arg with step 2"
(assert-equal
(list 0 2 4)
(in-range 0 6 2)))
(deftest
"in-range result is a list"
(assert (list? (in-range 5))))
(deftest
"in-range length is correct"
(assert= 10 (len (in-range 10))))
(deftest
"map over vector"
(assert-equal
(list 2 4 6)
(map
(fn (x) (* x 2))
(vector 1 2 3))))
(deftest
"filter over vector keeps odds"
(assert-equal
(list 1 3 5)
(filter
odd?
(vector 1 2 3 4 5))))
(deftest
"reduce over vector sums"
(assert=
10
(reduce
+
0
(vector 1 2 3 4))))
(deftest
"some over vector finds odd"
(assert (some odd? (vector 2 4 3 6))))
(deftest
"every? over vector all even"
(assert
(every? even? (vector 2 4 6 8))))
(deftest
"every? over vector fails with odd"
(assert= false (every? even? (vector 2 3 6))))
(deftest
"map over in-range squares"
(assert-equal
(list 0 1 4 9 16)
(map (fn (x) (* x x)) (in-range 5))))
(deftest
"filter over in-range keeps evens"
(assert-equal
(list 0 2 4 6)
(filter even? (in-range 7))))
(deftest
"reduce over in-range sums"
(assert= 15 (reduce + 0 (in-range 6))))
(deftest
"map over string returns char list"
(assert-equal (list "a" "b" "c") (map (fn (c) c) "abc")))
(deftest
"filter over string keeps matching chars"
(assert-equal (list "p" "p") (filter (fn (c) (= c "p")) "apple"))))

View File

@@ -1,200 +0,0 @@
;; ==========================================================================
;; test-sets.sx — Tests for set primitives
;; ==========================================================================
;; --------------------------------------------------------------------------
;; make-set / set?
;; --------------------------------------------------------------------------
(defsuite
"sets:create"
(deftest "make-set returns a set" (assert (set? (make-set))))
(deftest "empty set has size 0" (assert= (set-size (make-set)) 0))
(deftest
"make-set from list"
(let ((s (make-set (list 1 2 3)))) (assert= (set-size s) 3)))
(deftest
"make-set deduplicates"
(let ((s (make-set (list 1 2 2 3 3)))) (assert= (set-size s) 3)))
(deftest "set? true for sets" (assert (set? (make-set))))
(deftest "set? false for list" (assert (not (set? (list 1 2 3)))))
(deftest "set? false for nil" (assert (not (set? nil))))
(deftest "set? false for number" (assert (not (set? 42)))))
;; --------------------------------------------------------------------------
;; set-add! / set-member? / set-remove!
;; --------------------------------------------------------------------------
(defsuite
"sets:mutation"
(deftest
"set-add! increases size"
(let
((s (make-set)))
(set-add! s 1)
(assert= (set-size s) 1)))
(deftest
"set-add! idempotent"
(let
((s (make-set)))
(set-add! s 1)
(set-add! s 1)
(assert= (set-size s) 1)))
(deftest
"set-member? true after add"
(let
((s (make-set)))
(set-add! s "hello")
(assert (set-member? s "hello"))))
(deftest
"set-member? false for absent"
(let
((s (make-set (list 1 2 3))))
(assert (not (set-member? s 99)))))
(deftest
"set-remove! reduces size"
(let
((s (make-set (list 1 2 3))))
(set-remove! s 2)
(assert= (set-size s) 2)))
(deftest
"set-remove! removes element"
(let
((s (make-set (list 1 2 3))))
(set-remove! s 2)
(assert (not (set-member? s 2)))))
(deftest
"set-remove! no-op for absent"
(let
((s (make-set (list 1 2 3))))
(set-remove! s 99)
(assert= (set-size s) 3)))
(deftest
"set handles strings"
(let
((s (make-set)))
(set-add! s "a")
(set-add! s "b")
(assert (and (set-member? s "a") (set-member? s "b")))))
(deftest
"set handles symbols"
(let
((s (make-set)))
(set-add! s (quote foo))
(assert (set-member? s (quote foo))))))
;; --------------------------------------------------------------------------
;; set->list / list->set
;; --------------------------------------------------------------------------
(defsuite
"sets:conversion"
(deftest
"list->set creates set"
(let ((s (list->set (list 1 2 3)))) (assert (set? s))))
(deftest
"list->set size"
(let ((s (list->set (list 1 2 3)))) (assert= (set-size s) 3)))
(deftest
"list->set deduplicates"
(let ((s (list->set (list 1 1 2)))) (assert= (set-size s) 2)))
(deftest
"set->list has all elements"
(let
((s (make-set (list 1 2 3)))
(lst (set->list s)))
(assert= (length lst) 3)))
(deftest
"set->list round-trip membership"
(let
((s (make-set (list 10 20 30)))
(lst (set->list s)))
(assert
(and
(set-member? (list->set lst) 10)
(set-member? (list->set lst) 20)
(set-member? (list->set lst) 30))))))
;; --------------------------------------------------------------------------
;; set-union / set-intersection / set-difference
;; --------------------------------------------------------------------------
(defsuite
"sets:operations"
(deftest
"union size"
(let
((a (make-set (list 1 2 3)))
(b (make-set (list 3 4 5))))
(assert= (set-size (set-union a b)) 5)))
(deftest
"union contains all"
(let
((u (set-union (make-set (list 1 2)) (make-set (list 3 4)))))
(assert
(and
(set-member? u 1)
(set-member? u 3)
(set-member? u 4)))))
(deftest
"intersection size"
(let
((a (make-set (list 1 2 3)))
(b (make-set (list 2 3 4))))
(assert= (set-size (set-intersection a b)) 2)))
(deftest
"intersection contains overlap"
(let
((i (set-intersection (make-set (list 1 2 3)) (make-set (list 2 3 4)))))
(assert (and (set-member? i 2) (set-member? i 3) (not (set-member? i 1))))))
(deftest
"intersection empty when disjoint"
(let
((a (make-set (list 1 2)))
(b (make-set (list 3 4))))
(assert= (set-size (set-intersection a b)) 0)))
(deftest
"difference size"
(let
((a (make-set (list 1 2 3)))
(b (make-set (list 2 3))))
(assert= (set-size (set-difference a b)) 1)))
(deftest
"difference keeps only a-exclusive"
(let
((d (set-difference (make-set (list 1 2 3)) (make-set (list 2 3 4)))))
(assert (and (set-member? d 1) (not (set-member? d 2)) (not (set-member? d 4))))))
(deftest
"union does not mutate inputs"
(let
((a (make-set (list 1 2)))
(b (make-set (list 3 4))))
(set-union a b)
(assert= (set-size a) 2))))
;; --------------------------------------------------------------------------
;; set-for-each / set-map
;; --------------------------------------------------------------------------
(defsuite
"sets:higher-order"
(deftest
"set-for-each visits all"
(let
((s (make-set (list 1 2 3)))
(acc (list)))
(set-for-each s (fn (v) (set! acc (cons v acc))))
(assert= (length acc) 3)))
(deftest
"set-map doubles values"
(let
((s (make-set (list 1 2 3)))
(s2 (set-map s (fn (v) (* v 2)))))
(assert
(and
(set-member? s2 2)
(set-member? s2 4)
(set-member? s2 6)))))
(deftest
"set-map result is a set"
(assert (set? (set-map (make-set (list 1 2)) (fn (v) v))))))

View File

@@ -1,131 +0,0 @@
(defsuite
"string-buffer"
(deftest
"make-string-buffer creates a string-buffer"
(let ((buf (make-string-buffer))) (assert (string-buffer? buf))))
(deftest
"string-buffer? is false for non-buffers"
(assert= false (string-buffer? "hello"))
(assert= false (string-buffer? 42))
(assert= false (string-buffer? nil))
(assert= false (string-buffer? (list)))
(assert= false (string-buffer? {:key "val"})))
(deftest
"type-of returns string-buffer"
(assert= "string-buffer" (type-of (make-string-buffer))))
(deftest
"empty buffer converts to empty string"
(let
((buf (make-string-buffer)))
(assert= "" (string-buffer->string buf))))
(deftest
"empty buffer has length zero"
(let
((buf (make-string-buffer)))
(assert= 0 (string-buffer-length buf))))
(deftest
"single append accumulates string"
(let
((buf (make-string-buffer)))
(string-buffer-append! buf "hello")
(assert= "hello" (string-buffer->string buf))))
(deftest
"multiple appends join in order"
(let
((buf (make-string-buffer)))
(string-buffer-append! buf "foo")
(string-buffer-append! buf "bar")
(string-buffer-append! buf "baz")
(assert= "foobarbaz" (string-buffer->string buf))))
(deftest
"length tracks total bytes appended"
(let
((buf (make-string-buffer)))
(string-buffer-append! buf "abc")
(string-buffer-append! buf "de")
(assert= 5 (string-buffer-length buf))))
(deftest
"append returns nil"
(let
((buf (make-string-buffer)))
(assert= nil (string-buffer-append! buf "x"))))
(deftest
"appending empty string is harmless"
(let
((buf (make-string-buffer)))
(string-buffer-append! buf "start")
(string-buffer-append! buf "")
(string-buffer-append! buf "end")
(assert= "startend" (string-buffer->string buf))
(assert= 8 (string-buffer-length buf))))
(deftest
"buffer is still usable after string-buffer->string"
(let
((buf (make-string-buffer)))
(string-buffer-append! buf "hello")
(string-buffer->string buf)
(string-buffer-append! buf " world")
(assert= "hello world" (string-buffer->string buf))))
(deftest
"two buffers are independent"
(let
((b1 (make-string-buffer)) (b2 (make-string-buffer)))
(string-buffer-append! b1 "one")
(string-buffer-append! b2 "two")
(string-buffer-append! b1 "ONE")
(assert= "oneONE" (string-buffer->string b1))
(assert= "two" (string-buffer->string b2))))
(deftest
"loop building — linear string concat"
(let
((buf (make-string-buffer)))
(let
loop
((i 0))
(when
(< i 5)
(string-buffer-append! buf (str i))
(loop (+ i 1))))
(assert= "01234" (string-buffer->string buf))
(assert= 5 (string-buffer-length buf))))
(deftest
"building CSV row with separator"
(let
((buf (make-string-buffer)) (items (list "a" "b" "c" "d")))
(let
loop
((remaining items) (is-first true))
(when
(not (empty? remaining))
(when (not is-first) (string-buffer-append! buf ","))
(string-buffer-append! buf (first remaining))
(loop (rest remaining) false)))
(assert= "a,b,c,d" (string-buffer->string buf))))
(deftest
"unicode characters accumulate correctly"
(let
((buf (make-string-buffer)))
(string-buffer-append! buf "こんにちは")
(string-buffer-append! buf " ")
(string-buffer-append! buf "世界")
(assert= "こんにちは 世界" (string-buffer->string buf))))
(deftest
"repeated to-string calls are consistent"
(let
((buf (make-string-buffer)))
(string-buffer-append! buf "test")
(assert= (string-buffer->string buf) (string-buffer->string buf))))
(deftest
"building with join pattern produces correct output"
(let
((buf (make-string-buffer))
(words (list "the" "quick" "brown" "fox")))
(let
loop
((remaining words) (sep ""))
(when
(not (empty? remaining))
(string-buffer-append! buf sep)
(string-buffer-append! buf (first remaining))
(loop (rest remaining) " ")))
(assert= "the quick brown fox" (string-buffer->string buf)))))

View File

@@ -1,172 +0,0 @@
(defsuite
"multiple-values"
(deftest
"values single returns value directly"
(do
(assert= 42 (values 42))
(assert= "hi" (values "hi"))
(assert= nil (values nil))))
(deftest
"values multiple returns marker dict"
(do
(let
((v (values 1 2 3)))
(assert (dict? v))
(assert= true (get v :_values false))
(assert-equal (list 1 2 3) (get v :_list)))))
(deftest
"call-with-values basic two values"
(do
(assert=
3
(call-with-values
(fn () (values 1 2))
(fn (a b) (+ a b))))))
(deftest
"call-with-values three values"
(do
(assert=
6
(call-with-values
(fn () (values 1 2 3))
(fn (a b c) (+ a b c))))))
(deftest
"call-with-values single value passthrough"
(do
(assert= 10 (call-with-values (fn () 10) (fn (x) x)))))
(deftest
"call-with-values passes non-values result as single arg"
(do (assert= "hello" (call-with-values (fn () "hello") (fn (x) x)))))
(deftest
"call-with-values with string concat"
(do
(assert=
"ab"
(call-with-values (fn () (values "a" "b")) (fn (a b) (str a b))))))
(deftest
"let-values basic two bindings"
(do
(let-values
(((a b) (values 10 20)))
(assert= 10 a)
(assert= 20 b))))
(deftest
"let-values computes with bindings"
(do
(let-values
(((x y) (values 3 4)))
(assert= 7 (+ x y)))))
(deftest
"let-values three values"
(do
(let-values
(((a b c) (values 1 2 3)))
(assert= 6 (+ a b c)))))
(deftest
"let-values single value binding"
(do (let-values (((x) (values 42))) (assert= 42 x))))
(deftest
"let-values multiple binding clauses"
(do
(let-values
(((a b) (values 1 2))
((c d) (values 3 4)))
(assert= 10 (+ a b c d)))))
(deftest
"let-values body is multiple expressions"
(do
(let-values
(((a b) (values 5 6)))
(define sum (+ a b))
(assert= 11 sum))))
(deftest
"let-values with no bindings evals body"
(do (let-values () (assert= 99 99))))
(deftest
"define-values binds multiple names"
(do
(define-values (x y) (values 7 8))
(assert= 7 x)
(assert= 8 y)))
(deftest
"define-values three names"
(do
(define-values (a b c) (values 10 20 30))
(assert= 10 a)
(assert= 20 b)
(assert= 30 c)))
(deftest
"define-values single name"
(do (define-values (n) (values 42)) (assert= 42 n)))
(deftest
"define-values used in computation"
(do
(define-values (w h) (values 6 7))
(assert= 42 (* w h))))
(deftest
"values in let binding"
(do
(let
((v (values 100 200)))
(assert= true (get v :_values false))
(assert= 100 (first (get v :_list))))))
(deftest
"call-with-values with swap"
(do
(define (swap a b) (values b a))
(assert=
5
(call-with-values
(fn () (swap 3 5))
(fn (first-val second-val) first-val)))))
(deftest
"let-values from function returning values"
(do
(define (min-max a b) (values (min a b) (max a b)))
(let-values
(((lo hi) (min-max 7 3)))
(assert= 3 lo)
(assert= 7 hi))))
(deftest
"nested let-values"
(do
(let-values
(((a b) (values 1 2)))
(let-values
(((c d) (values 3 4)))
(assert= 10 (+ a b c d))))))
(deftest
"call-with-values chained"
(do
(define
result
(call-with-values
(fn
()
(call-with-values
(fn () (values 4 6))
(fn (a b) (* a b))))
(fn (x) x)))
(assert= 24 result)))
(deftest
"values zero args produces dict"
(do
(let
((v (values)))
(assert (dict? v))
(assert (get v :_values false))
(assert-equal (list) (get v :_list)))))
(deftest
"let-values strings"
(do
(let-values
(((first-name last-name) (values "Alice" "Smith")))
(assert= "Alice Smith" (str first-name " " last-name)))))
(deftest
"define-values with list values"
(do
(define-values
(head tail)
(values 1 (list 2 3 4)))
(assert= 1 head)
(assert-equal (list 2 3 4) tail))))

View File

@@ -1,207 +0,0 @@
;; test-vectors.sx — Tests for vector primitives
(defsuite
"vectors"
(deftest
"make-vector default fill is nil"
(let
((v (make-vector 3)))
(assert (vector? v))
(assert-equal 3 (vector-length v))
(assert-equal nil (vector-ref v 0))
(assert-equal nil (vector-ref v 1))
(assert-equal nil (vector-ref v 2))))
(deftest
"make-vector with fill value"
(let
((v (make-vector 4 99)))
(assert-equal 4 (vector-length v))
(assert-equal 99 (vector-ref v 0))
(assert-equal 99 (vector-ref v 1))
(assert-equal 99 (vector-ref v 2))
(assert-equal 99 (vector-ref v 3))))
(deftest
"make-vector size zero"
(let ((v (make-vector 0))) (assert-equal 0 (vector-length v))))
(deftest
"make-vector size one"
(let
((v (make-vector 1 "x")))
(assert-equal 1 (vector-length v))
(assert-equal "x" (vector-ref v 0))))
(deftest
"vector constructor no args"
(let ((v (vector))) (assert-equal 0 (vector-length v))))
(deftest
"vector constructor with args"
(let
((v (vector 10 20 30)))
(assert-equal 3 (vector-length v))
(assert-equal 10 (vector-ref v 0))
(assert-equal 20 (vector-ref v 1))
(assert-equal 30 (vector-ref v 2))))
(deftest
"vector constructor strings"
(let
((v (vector "a" "b" "c")))
(assert-equal "a" (vector-ref v 0))
(assert-equal "b" (vector-ref v 1))
(assert-equal "c" (vector-ref v 2))))
(deftest "vector? true for vector" (assert (vector? (make-vector 3))))
(deftest "vector? false for list" (assert (not (vector? (list 1 2 3)))))
(deftest "vector? false for number" (assert (not (vector? 42))))
(deftest "vector? false for nil" (assert (not (vector? nil))))
(deftest "vector? false for string" (assert (not (vector? "hello"))))
(deftest "vector-length zero" (assert-equal 0 (vector-length (vector))))
(deftest
"vector-length three"
(assert-equal 3 (vector-length (vector 1 2 3))))
(deftest
"vector-length after make-vector"
(assert-equal 7 (vector-length (make-vector 7 0))))
(deftest
"vector-ref first element"
(assert-equal 1 (vector-ref (vector 1 2 3) 0)))
(deftest
"vector-ref last element"
(assert-equal 3 (vector-ref (vector 1 2 3) 2)))
(deftest
"vector-ref middle element"
(assert-equal 2 (vector-ref (vector 1 2 3) 1)))
(deftest
"vector-set! mutates in place"
(let
((v (vector 1 2 3)))
(vector-set! v 1 99)
(assert-equal 99 (vector-ref v 1))
(assert-equal 1 (vector-ref v 0))
(assert-equal 3 (vector-ref v 2))))
(deftest
"vector-set! first slot"
(let
((v (make-vector 3 0)))
(vector-set! v 0 42)
(assert-equal 42 (vector-ref v 0))))
(deftest
"vector-set! last slot"
(let
((v (make-vector 3 0)))
(vector-set! v 2 77)
(assert-equal 77 (vector-ref v 2))))
(deftest
"vector-set! returns nil"
(let ((v (make-vector 3 0))) (assert-equal nil (vector-set! v 0 1))))
(deftest
"vector->list empty"
(assert-equal (list) (vector->list (vector))))
(deftest
"vector->list numbers"
(assert-equal (list 1 2 3) (vector->list (vector 1 2 3))))
(deftest
"vector->list strings"
(assert-equal (list "a" "b") (vector->list (vector "a" "b"))))
(deftest
"list->vector empty"
(let ((v (list->vector (list)))) (assert-equal 0 (vector-length v))))
(deftest
"list->vector numbers"
(let
((v (list->vector (list 10 20 30))))
(assert-equal 3 (vector-length v))
(assert-equal 10 (vector-ref v 0))
(assert-equal 20 (vector-ref v 1))
(assert-equal 30 (vector-ref v 2))))
(deftest
"vector-fill! sets all elements"
(let
((v (vector 1 2 3)))
(vector-fill! v 0)
(assert-equal 0 (vector-ref v 0))
(assert-equal 0 (vector-ref v 1))
(assert-equal 0 (vector-ref v 2))))
(deftest
"vector-fill! returns nil"
(assert-equal nil (vector-fill! (make-vector 2 0) 7)))
(deftest
"vector-fill! string fill"
(let
((v (make-vector 3 "")))
(vector-fill! v "x")
(assert-equal "x" (vector-ref v 0))
(assert-equal "x" (vector-ref v 2))))
(deftest
"vector-copy full copy"
(let
((v1 (vector 1 2 3)) (v2 (vector-copy (vector 1 2 3))))
(assert-equal 3 (vector-length v2))
(assert-equal 1 (vector-ref v2 0))
(assert-equal 2 (vector-ref v2 1))
(assert-equal 3 (vector-ref v2 2))))
(deftest
"vector-copy is independent"
(let
((v1 (vector 1 2 3)))
(let
((v2 (vector-copy v1)))
(vector-set! v1 0 99)
(assert-equal 1 (vector-ref v2 0)))))
(deftest
"vector-copy with start"
(let
((v (vector-copy (vector 10 20 30 40) 1)))
(assert-equal 3 (vector-length v))
(assert-equal 20 (vector-ref v 0))
(assert-equal 30 (vector-ref v 1))
(assert-equal 40 (vector-ref v 2))))
(deftest
"vector-copy with start and end"
(let
((v (vector-copy (vector 10 20 30 40) 1 3)))
(assert-equal 2 (vector-length v))
(assert-equal 20 (vector-ref v 0))
(assert-equal 30 (vector-ref v 1))))
(deftest
"vector-copy empty slice"
(let
((v (vector-copy (vector 1 2 3) 1 1)))
(assert-equal 0 (vector-length v))))
(deftest
"vector-ref out of bounds raises"
(let
((ok false))
(guard (exn (else (set! ok true))) (vector-ref (vector 1 2 3) 5))
(assert ok)))
(deftest
"vector-ref negative index raises"
(let
((ok false))
(guard (exn (else (set! ok true))) (vector-ref (vector 1 2 3) -1))
(assert ok)))
(deftest
"vector-set! out of bounds raises"
(let
((ok false))
(guard
(exn (else (set! ok true)))
(vector-set! (vector 1 2 3) 10 99))
(assert ok)))
(deftest
"vector list round-trip"
(let
((lst (list 5 10 15 20)))
(assert-equal lst (vector->list (list->vector lst)))))
(deftest
"vector mutation does not affect copy"
(let
((v1 (vector 1 2 3)))
(let
((v2 (vector-copy v1)))
(vector-set! v2 0 100)
(assert-equal 1 (vector-ref v1 0))
(assert-equal 100 (vector-ref v2 0)))))
(deftest
"vector-length after fill"
(let
((v (make-vector 5 0)))
(vector-fill! v 1)
(assert-equal 5 (vector-length v)))))

View File

@@ -1,156 +1,195 @@
;; ==========================================================================
;; test.sx — Self-hosting SX test suite (backward-compatible entry point)
;;
;; This file includes the test framework and core eval tests inline.
;; It exists for backward compatibility — runners that load "test.sx"
;; get the same 81 tests as before.
;;
;; For modular testing, runners should instead load:
;; 1. test-framework.sx (macros + assertions)
;; 2. One or more test specs: test-eval.sx, test-parser.sx,
;; test-router.sx, test-render.sx, etc.
;;
;; Platform functions required:
;; try-call (thunk) -> {:ok true} | {:ok false :error "msg"}
;; report-pass (name) -> platform-specific pass output
;; report-fail (name error) -> platform-specific fail output
;; push-suite (name) -> push suite name onto context stack
;; pop-suite () -> pop suite name from context stack
;;
;; Usage:
;; ;; Host injects platform functions into env, then:
;; (eval-file "test.sx" env)
;;
;; The same test.sx runs on every host — Python, JavaScript, etc.
;; ==========================================================================
(defmacro
deftest
(name &rest body)
(quasiquote
(let
((result (try-call (fn () (splice-unquote body)))))
(if
(get result "ok")
(report-pass (unquote name))
(report-fail (unquote name) (get result "error"))))))
(defmacro
defsuite
(name &rest items)
(quasiquote
(do (push-suite (unquote name)) (splice-unquote items) (pop-suite))))
;; --------------------------------------------------------------------------
;; 1. Test framework macros
;; --------------------------------------------------------------------------
;;
;; deftest and defsuite are macros that make test.sx directly executable.
;; The host provides try-call (error catching), reporting, and suite
;; context — everything else is pure SX.
(define
assert-equal
(fn
(expected actual)
(assert
(equal? expected actual)
(defmacro deftest (name &rest body)
`(let ((result (try-call (fn () ,@body))))
(if (get result "ok")
(report-pass ,name)
(report-fail ,name (get result "error")))))
(defmacro defsuite (name &rest items)
`(do (push-suite ,name)
,@items
(pop-suite)))
;; --------------------------------------------------------------------------
;; 2. Assertion helpers — defined in SX, available in test bodies
;; --------------------------------------------------------------------------
;;
;; These are regular functions (not special forms). They use the `assert`
;; primitive underneath but provide better error messages.
(define assert-equal
(fn (expected actual)
(assert (equal? expected actual)
(str "Expected " (str expected) " but got " (str actual)))))
(define
assert-not-equal
(fn
(a b)
(assert
(not (equal? a b))
(define assert-not-equal
(fn (a b)
(assert (not (equal? a b))
(str "Expected values to differ but both are " (str a)))))
(define
assert-true
(fn (val) (assert val (str "Expected truthy but got " (str val)))))
(define assert-true
(fn (val)
(assert val (str "Expected truthy but got " (str val)))))
(define
assert-false
(fn (val) (assert (not val) (str "Expected falsy but got " (str val)))))
(define assert-false
(fn (val)
(assert (not val) (str "Expected falsy but got " (str val)))))
(define
assert-nil
(fn (val) (assert (nil? val) (str "Expected nil but got " (str val)))))
(define assert-nil
(fn (val)
(assert (nil? val) (str "Expected nil but got " (str val)))))
(define
assert-type
(fn
(expected-type val)
(let
((actual-type (if (nil? val) "nil" (if (boolean? val) "boolean" (if (number? val) "number" (if (string? val) "string" (if (list? val) "list" (if (dict? val) "dict" "unknown"))))))))
(assert
(= expected-type actual-type)
(define assert-type
(fn (expected-type val)
;; Implemented via predicate dispatch since type-of is a platform
;; function not available in all hosts. Uses nested if to avoid
;; Scheme-style cond detection for 2-element predicate calls.
;; Boolean checked before number (subtypes on some platforms).
(let ((actual-type
(if (nil? val) "nil"
(if (boolean? val) "boolean"
(if (number? val) "number"
(if (string? val) "string"
(if (list? val) "list"
(if (dict? val) "dict"
"unknown"))))))))
(assert (= expected-type actual-type)
(str "Expected type " expected-type " but got " actual-type)))))
(define
assert-length
(fn
(expected-len col)
(assert
(= (len col) expected-len)
(define assert-length
(fn (expected-len col)
(assert (= (len col) expected-len)
(str "Expected length " expected-len " but got " (len col)))))
(define
assert-contains
(fn
(item col)
(assert
(some (fn (x) (equal? x item)) col)
(define assert-contains
(fn (item col)
(assert (some (fn (x) (equal? x item)) col)
(str "Expected collection to contain " (str item)))))
(define
assert-throws
(fn
(thunk)
(let
((result (try-call thunk)))
(assert
(not (get result "ok"))
(define assert-throws
(fn (thunk)
(let ((result (try-call thunk)))
(assert (not (get result "ok"))
"Expected an error to be thrown but none was"))))
(defsuite
"literals"
(deftest
"numbers are numbers"
;; ==========================================================================
;; 3. Test suites — SX testing SX
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 3a. Literals and types
;; --------------------------------------------------------------------------
(defsuite "literals"
(deftest "numbers are numbers"
(assert-type "number" 42)
(assert-type "number" 3.14)
(assert-type "number" -1))
(deftest
"strings are strings"
(deftest "strings are strings"
(assert-type "string" "hello")
(assert-type "string" ""))
(deftest
"booleans are booleans"
(deftest "booleans are booleans"
(assert-type "boolean" true)
(assert-type "boolean" false))
(deftest "nil is nil" (assert-type "nil" nil) (assert-nil nil))
(deftest
"lists are lists"
(deftest "nil is nil"
(assert-type "nil" nil)
(assert-nil nil))
(deftest "lists are lists"
(assert-type "list" (list 1 2 3))
(assert-type "list" (list)))
(deftest "dicts are dicts" (assert-type "dict" {:b 2 :a 1})))
(defsuite
"arithmetic"
(deftest
"addition"
(deftest "dicts are dicts"
(assert-type "dict" {:a 1 :b 2})))
;; --------------------------------------------------------------------------
;; 3b. Arithmetic
;; --------------------------------------------------------------------------
(defsuite "arithmetic"
(deftest "addition"
(assert-equal 3 (+ 1 2))
(assert-equal 0 (+ 0 0))
(assert-equal -1 (+ 1 -2))
(assert-equal 10 (+ 1 2 3 4)))
(deftest
"subtraction"
(deftest "subtraction"
(assert-equal 1 (- 3 2))
(assert-equal -1 (- 2 3)))
(deftest
"multiplication"
(deftest "multiplication"
(assert-equal 6 (* 2 3))
(assert-equal 0 (* 0 100))
(assert-equal 24 (* 1 2 3 4)))
(deftest
"division"
(deftest "division"
(assert-equal 2 (/ 6 3))
(assert-equal 2.5 (/ 5 2)))
(deftest
"modulo"
(deftest "modulo"
(assert-equal 1 (mod 7 3))
(assert-equal 0 (mod 6 3))))
(defsuite
"comparison"
(deftest
"equality"
;; --------------------------------------------------------------------------
;; 3c. Comparison
;; --------------------------------------------------------------------------
(defsuite "comparison"
(deftest "equality"
(assert-true (= 1 1))
(assert-false (= 1 2))
(assert-true (= "a" "a"))
(assert-false (= "a" "b")))
(deftest
"deep equality"
(assert-true
(equal?
(list 1 2 3)
(list 1 2 3)))
(assert-false
(equal? (list 1 2) (list 1 3)))
(deftest "deep equality"
(assert-true (equal? (list 1 2 3) (list 1 2 3)))
(assert-false (equal? (list 1 2) (list 1 3)))
(assert-true (equal? {:a 1} {:a 1}))
(assert-false (equal? {:a 1} {:a 2})))
(deftest
"ordering"
(deftest "ordering"
(assert-true (< 1 2))
(assert-false (< 2 1))
(assert-true (> 2 1))
@@ -159,418 +198,405 @@
(assert-true (>= 2 2))
(assert-true (>= 3 2))))
(defsuite
"strings"
(deftest
"str concatenation"
;; --------------------------------------------------------------------------
;; 3d. String operations
;; --------------------------------------------------------------------------
(defsuite "strings"
(deftest "str concatenation"
(assert-equal "abc" (str "a" "b" "c"))
(assert-equal "hello world" (str "hello" " " "world"))
(assert-equal "42" (str 42))
(assert-equal "" (str)))
(deftest
"string-length"
(deftest "string-length"
(assert-equal 5 (string-length "hello"))
(assert-equal 0 (string-length "")))
(deftest
"substring"
(deftest "substring"
(assert-equal "ell" (substring "hello" 1 4))
(assert-equal "hello" (substring "hello" 0 5)))
(deftest
"string-contains?"
(deftest "string-contains?"
(assert-true (string-contains? "hello world" "world"))
(assert-false (string-contains? "hello" "xyz")))
(deftest
"upcase and downcase"
(deftest "upcase and downcase"
(assert-equal "HELLO" (upcase "hello"))
(assert-equal "hello" (downcase "HELLO")))
(deftest
"trim"
(deftest "trim"
(assert-equal "hello" (trim " hello "))
(assert-equal "hello" (trim "hello")))
(deftest
"split and join"
(deftest "split and join"
(assert-equal (list "a" "b" "c") (split "a,b,c" ","))
(assert-equal "a-b-c" (join "-" (list "a" "b" "c")))))
(defsuite
"lists"
(deftest
"constructors"
(assert-equal
(list 1 2 3)
(list 1 2 3))
;; --------------------------------------------------------------------------
;; 3e. List operations
;; --------------------------------------------------------------------------
(defsuite "lists"
(deftest "constructors"
(assert-equal (list 1 2 3) (list 1 2 3))
(assert-equal (list) (list))
(assert-length 3 (list 1 2 3)))
(deftest
"first and rest"
(deftest "first and rest"
(assert-equal 1 (first (list 1 2 3)))
(assert-equal
(list 2 3)
(rest (list 1 2 3)))
(assert-equal (list 2 3) (rest (list 1 2 3)))
(assert-nil (first (list)))
(assert-equal (list) (rest (list))))
(deftest
"nth"
(assert-equal
1
(nth (list 1 2 3) 0))
(assert-equal
2
(nth (list 1 2 3) 1))
(assert-equal
3
(nth (list 1 2 3) 2)))
(deftest
"last"
(deftest "nth"
(assert-equal 1 (nth (list 1 2 3) 0))
(assert-equal 2 (nth (list 1 2 3) 1))
(assert-equal 3 (nth (list 1 2 3) 2)))
(deftest "last"
(assert-equal 3 (last (list 1 2 3)))
(assert-nil (last (list))))
(deftest
"cons and append"
(assert-equal
(list 0 1 2)
(cons 0 (list 1 2)))
(assert-equal
(list 1 2 3 4)
(append (list 1 2) (list 3 4))))
(deftest
"reverse"
(assert-equal
(list 3 2 1)
(reverse (list 1 2 3)))
(deftest "cons and append"
(assert-equal (list 0 1 2) (cons 0 (list 1 2)))
(assert-equal (list 1 2 3 4) (append (list 1 2) (list 3 4))))
(deftest "reverse"
(assert-equal (list 3 2 1) (reverse (list 1 2 3)))
(assert-equal (list) (reverse (list))))
(deftest
"empty?"
(deftest "empty?"
(assert-true (empty? (list)))
(assert-false (empty? (list 1))))
(deftest
"len"
(deftest "len"
(assert-equal 0 (len (list)))
(assert-equal 3 (len (list 1 2 3))))
(deftest
"contains?"
(assert-true
(contains? (list 1 2 3) 2))
(assert-false
(contains? (list 1 2 3) 4)))
(deftest
"flatten"
(assert-equal
(list 1 2 3 4)
(flatten
(list (list 1 2) (list 3 4))))))
(defsuite
"dicts"
(deftest
"dict literal"
(assert-type "dict" {:b 2 :a 1})
(deftest "contains?"
(assert-true (contains? (list 1 2 3) 2))
(assert-false (contains? (list 1 2 3) 4)))
(deftest "flatten"
(assert-equal (list 1 2 3 4) (flatten (list (list 1 2) (list 3 4))))))
;; --------------------------------------------------------------------------
;; 3f. Dict operations
;; --------------------------------------------------------------------------
(defsuite "dicts"
(deftest "dict literal"
(assert-type "dict" {:a 1 :b 2})
(assert-equal 1 (get {:a 1} "a"))
(assert-equal 2 (get {:b 2 :a 1} "b")))
(deftest
"assoc"
(assert-equal {:b 2 :a 1} (assoc {:a 1} "b" 2))
(assert-equal 2 (get {:a 1 :b 2} "b")))
(deftest "assoc"
(assert-equal {:a 1 :b 2} (assoc {:a 1} "b" 2))
(assert-equal {:a 99} (assoc {:a 1} "a" 99)))
(deftest "dissoc" (assert-equal {:b 2} (dissoc {:b 2 :a 1} "a")))
(deftest
"keys and vals"
(let
((d {:b 2 :a 1}))
(deftest "dissoc"
(assert-equal {:b 2} (dissoc {:a 1 :b 2} "a")))
(deftest "keys and vals"
(let ((d {:a 1 :b 2}))
(assert-length 2 (keys d))
(assert-length 2 (vals d))
(assert-contains "a" (keys d))
(assert-contains "b" (keys d))))
(deftest
"has-key?"
(deftest "has-key?"
(assert-true (has-key? {:a 1} "a"))
(assert-false (has-key? {:a 1} "b")))
(deftest
"merge"
(assert-equal {:c 3 :b 2 :a 1} (merge {:b 2 :a 1} {:c 3}))
(assert-equal {:b 2 :a 99} (merge {:b 2 :a 1} {:a 99}))))
(defsuite
"predicates"
(deftest
"nil?"
(deftest "merge"
(assert-equal {:a 1 :b 2 :c 3}
(merge {:a 1 :b 2} {:c 3}))
(assert-equal {:a 99 :b 2}
(merge {:a 1 :b 2} {:a 99}))))
;; --------------------------------------------------------------------------
;; 3g. Predicates
;; --------------------------------------------------------------------------
(defsuite "predicates"
(deftest "nil?"
(assert-true (nil? nil))
(assert-false (nil? 0))
(assert-false (nil? false))
(assert-false (nil? "")))
(deftest
"number?"
(deftest "number?"
(assert-true (number? 42))
(assert-true (number? 3.14))
(assert-false (number? "42")))
(deftest
"string?"
(deftest "string?"
(assert-true (string? "hello"))
(assert-false (string? 42)))
(deftest
"list?"
(deftest "list?"
(assert-true (list? (list 1 2)))
(assert-false (list? "not a list")))
(deftest
"dict?"
(deftest "dict?"
(assert-true (dict? {:a 1}))
(assert-false (dict? (list 1))))
(deftest
"boolean?"
(deftest "boolean?"
(assert-true (boolean? true))
(assert-true (boolean? false))
(assert-false (boolean? nil))
(assert-false (boolean? 0)))
(deftest
"not"
(deftest "not"
(assert-true (not false))
(assert-true (not nil))
(assert-false (not true))
(assert-false (not 1))
(assert-false (not "x"))))
(defsuite
"special-forms"
(deftest
"if"
;; --------------------------------------------------------------------------
;; 3h. Special forms
;; --------------------------------------------------------------------------
(defsuite "special-forms"
(deftest "if"
(assert-equal "yes" (if true "yes" "no"))
(assert-equal "no" (if false "yes" "no"))
(assert-equal "no" (if nil "yes" "no"))
(assert-nil (if false "yes")))
(deftest
"when"
(deftest "when"
(assert-equal "yes" (when true "yes"))
(assert-nil (when false "yes")))
(deftest
"cond"
(deftest "cond"
(assert-equal "a" (cond true "a" :else "b"))
(assert-equal "b" (cond false "a" :else "b"))
(assert-equal "c" (cond false "a" false "b" :else "c")))
(deftest
"and"
(assert-equal "c" (cond
false "a"
false "b"
:else "c")))
(deftest "and"
(assert-true (and true true))
(assert-false (and true false))
(assert-false (and false true))
(assert-equal 3 (and 1 2 3)))
(deftest
"or"
(deftest "or"
(assert-equal 1 (or 1 2))
(assert-equal 2 (or false 2))
(assert-equal "fallback" (or nil false "fallback"))
(assert-false (or false false)))
(deftest
"let"
(assert-equal
3
(let ((x 1) (y 2)) (+ x y)))
(assert-equal
"hello world"
(deftest "let"
(assert-equal 3 (let ((x 1) (y 2)) (+ x y)))
(assert-equal "hello world"
(let ((a "hello") (b " world")) (str a b))))
(deftest
"let clojure-style"
(deftest "let clojure-style"
(assert-equal 3 (let (x 1 y 2) (+ x y))))
(deftest
"do / begin"
(deftest "do / begin"
(assert-equal 3 (do 1 2 3))
(assert-equal "last" (begin "first" "middle" "last")))
(deftest "define" (define x 42) (assert-equal 42 x))
(deftest
"set!"
(deftest "define"
(define x 42)
(assert-equal 42 x))
(deftest "set!"
(define x 1)
(set! x 2)
(assert-equal 2 x)))
(defsuite
"lambdas"
(deftest
"basic lambda"
(let
((add (fn (a b) (+ a b))))
;; --------------------------------------------------------------------------
;; 3i. Lambda and closures
;; --------------------------------------------------------------------------
(defsuite "lambdas"
(deftest "basic lambda"
(let ((add (fn (a b) (+ a b))))
(assert-equal 3 (add 1 2))))
(deftest
"closure captures env"
(let
((x 10))
(let
((add-x (fn (y) (+ x y))))
(deftest "closure captures env"
(let ((x 10))
(let ((add-x (fn (y) (+ x y))))
(assert-equal 15 (add-x 5)))))
(deftest
"lambda as argument"
(assert-equal
(list 2 4 6)
(map
(fn (x) (* x 2))
(list 1 2 3))))
(deftest
"recursive lambda via define"
(define
factorial
(fn
(n)
(if
(<= n 1)
1
(* n (factorial (- n 1))))))
(deftest "lambda as argument"
(assert-equal (list 2 4 6)
(map (fn (x) (* x 2)) (list 1 2 3))))
(deftest "recursive lambda via define"
(define factorial
(fn (n) (if (<= n 1) 1 (* n (factorial (- n 1))))))
(assert-equal 120 (factorial 5)))
(deftest
"higher-order returns lambda"
(let
((make-adder (fn (n) (fn (x) (+ n x)))))
(let
((add5 (make-adder 5)))
(deftest "higher-order returns lambda"
(let ((make-adder (fn (n) (fn (x) (+ n x)))))
(let ((add5 (make-adder 5)))
(assert-equal 8 (add5 3))))))
(defsuite
"higher-order"
(deftest
"map"
(assert-equal
(list 2 4 6)
(map
(fn (x) (* x 2))
(list 1 2 3)))
;; --------------------------------------------------------------------------
;; 3j. Higher-order forms
;; --------------------------------------------------------------------------
(defsuite "higher-order"
(deftest "map"
(assert-equal (list 2 4 6)
(map (fn (x) (* x 2)) (list 1 2 3)))
(assert-equal (list) (map (fn (x) x) (list))))
(deftest
"filter"
(assert-equal
(list 2 4)
(filter
(fn (x) (= (mod x 2) 0))
(list 1 2 3 4)))
(assert-equal
(list)
(deftest "filter"
(assert-equal (list 2 4)
(filter (fn (x) (= (mod x 2) 0)) (list 1 2 3 4)))
(assert-equal (list)
(filter (fn (x) false) (list 1 2 3))))
(deftest
"reduce"
(assert-equal
10
(reduce
(fn (acc x) (+ acc x))
0
(list 1 2 3 4)))
(assert-equal
0
(reduce (fn (acc x) (+ acc x)) 0 (list))))
(deftest
"some"
(assert-true
(some
(fn (x) (> x 3))
(list 1 2 3 4 5)))
(assert-false
(some
(fn (x) (> x 10))
(list 1 2 3))))
(deftest
"every?"
(assert-true
(every?
(fn (x) (> x 0))
(list 1 2 3)))
(assert-false
(every?
(fn (x) (> x 2))
(list 1 2 3))))
(deftest
"map-indexed"
(assert-equal
(list "0:a" "1:b" "2:c")
(deftest "reduce"
(assert-equal 10 (reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4)))
(assert-equal 0 (reduce (fn (acc x) (+ acc x)) 0 (list))))
(deftest "some"
(assert-true (some (fn (x) (> x 3)) (list 1 2 3 4 5)))
(assert-false (some (fn (x) (> x 10)) (list 1 2 3))))
(deftest "every?"
(assert-true (every? (fn (x) (> x 0)) (list 1 2 3)))
(assert-false (every? (fn (x) (> x 2)) (list 1 2 3))))
(deftest "map-indexed"
(assert-equal (list "0:a" "1:b" "2:c")
(map-indexed (fn (i x) (str i ":" x)) (list "a" "b" "c")))))
(defsuite
"components"
(deftest
"defcomp creates component"
(defcomp ~test-comp (&key title) (div title))
;; --------------------------------------------------------------------------
;; 3k. Components
;; --------------------------------------------------------------------------
(defsuite "components"
(deftest "defcomp creates component"
(defcomp ~test-comp (&key title)
(div title))
;; Component is bound and not nil
(assert-true (not (nil? ~test-comp))))
(deftest
"component renders with keyword args"
(defcomp ~greeting (&key name) (span (str "Hello, " name "!")))
(deftest "component renders with keyword args"
(defcomp ~greeting (&key name)
(span (str "Hello, " name "!")))
(assert-true (not (nil? ~greeting))))
(deftest
"component with children"
(defcomp ~box (&key &rest children) (div :class "box" children))
(deftest "component with children"
(defcomp ~box (&key &rest children)
(div :class "box" children))
(assert-true (not (nil? ~box))))
(deftest
"component with default via or"
(defcomp ~label (&key text) (span (or text "default")))
(deftest "component with default via or"
(defcomp ~label (&key text)
(span (or text "default")))
(assert-true (not (nil? ~label)))))
(defsuite
"macros"
(deftest
"defmacro creates macro"
(defmacro
unless
(cond &rest body)
(quasiquote (if (not (unquote cond)) (do (splice-unquote body)))))
;; --------------------------------------------------------------------------
;; 3l. Macros
;; --------------------------------------------------------------------------
(defsuite "macros"
(deftest "defmacro creates macro"
(defmacro unless (cond &rest body)
`(if (not ,cond) (do ,@body)))
(assert-equal "yes" (unless false "yes"))
(assert-nil (unless true "no")))
(deftest
"quasiquote and unquote"
(let
((x 42))
(assert-equal
(list 1 42 3)
(quasiquote (1 (unquote x) 3)))))
(deftest
"splice-unquote"
(let
((xs (list 2 3 4)))
(assert-equal
(list 1 2 3 4 5)
(quasiquote (1 (splice-unquote xs) 5))))))
(defsuite
"threading"
(deftest
"thread-first"
(deftest "quasiquote and unquote"
(let ((x 42))
(assert-equal (list 1 42 3) `(1 ,x 3))))
(deftest "splice-unquote"
(let ((xs (list 2 3 4)))
(assert-equal (list 1 2 3 4 5) `(1 ,@xs 5)))))
;; --------------------------------------------------------------------------
;; 3m. Threading macro
;; --------------------------------------------------------------------------
(defsuite "threading"
(deftest "thread-first"
(assert-equal 8 (-> 5 (+ 1) (+ 2)))
(assert-equal "HELLO" (-> "hello" upcase))
(assert-equal "HELLO WORLD" (-> "hello" (str " world") upcase))))
(assert-equal "HELLO WORLD"
(-> "hello"
(str " world")
upcase))))
(defsuite
"truthiness"
(deftest
"truthy values"
;; --------------------------------------------------------------------------
;; 3n. Truthiness
;; --------------------------------------------------------------------------
(defsuite "truthiness"
(deftest "truthy values"
(assert-true (if 1 true false))
(assert-true (if "x" true false))
(assert-true (if (list 1) true false))
(assert-true (if true true false)))
(deftest
"falsy values"
(assert-false (if false true false))
(assert-false (if nil true false))))
(defsuite
"edge-cases"
(deftest
"nested let scoping"
(let
((x 1))
(let ((x 2)) (assert-equal 2 x))))
(deftest
"recursive map"
(assert-equal
(list (list 2 4) (list 6 8))
(map
(fn (sub) (map (fn (x) (* x 2)) sub))
(list (list 1 2) (list 3 4)))))
(deftest
"keyword as value"
(deftest "falsy values"
(assert-false (if false true false))
(assert-false (if nil true false)))
;; NOTE: empty list, zero, and empty string truthiness is
;; platform-dependent. Python treats all three as falsy.
;; JavaScript treats [] as truthy but 0 and "" as falsy.
;; These tests are omitted — each bootstrapper should emit
;; platform-specific truthiness tests instead.
)
;; --------------------------------------------------------------------------
;; 3o. Edge cases and regression tests
;; --------------------------------------------------------------------------
(defsuite "edge-cases"
(deftest "nested let scoping"
(let ((x 1))
(let ((x 2))
(assert-equal 2 x))
;; outer x should be unchanged by inner let
;; (this tests that let creates a new scope)
))
(deftest "recursive map"
(assert-equal (list (list 2 4) (list 6 8))
(map (fn (sub) (map (fn (x) (* x 2)) sub))
(list (list 1 2) (list 3 4)))))
(deftest "keyword as value"
(assert-equal "class" :class)
(assert-equal "id" :id))
(deftest
"dict with evaluated values"
(let ((x 42)) (assert-equal 42 (get {:val x} "val"))))
(deftest
"nil propagation"
(deftest "dict with evaluated values"
(let ((x 42))
(assert-equal 42 (get {:val x} "val"))))
(deftest "nil propagation"
(assert-nil (get {:a 1} "missing"))
(assert-equal "default" (or (get {:a 1} "missing") "default")))
(deftest
"empty operations"
(deftest "empty operations"
(assert-equal (list) (map (fn (x) x) (list)))
(assert-equal (list) (filter (fn (x) true) (list)))
(assert-equal
0
(reduce (fn (acc x) (+ acc x)) 0 (list)))
(assert-equal 0 (reduce (fn (acc x) (+ acc x)) 0 (list)))
(assert-equal 0 (len (list)))
(assert-equal "" (str))))