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

Compare commits

base: coop:abde5fbac1b947eda70f9351127eb4a28209d4b4
Branches Tags
coop:main coop:loops/fed-sx-m1 coop:loops/go coop:loops/fed-prims coop:loops/erlang coop:architecture coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/ruby coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations
..
compare: coop:loops/ruby
Branches Tags
coop:loops/fed-sx-m1 coop:loops/go coop:loops/fed-prims coop:loops/erlang coop:architecture coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/ruby coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:main coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations

3 Commits
abde5fbac1 ... loops/ruby

Author SHA1 Message Date
giles
fa3274c394 briefing: push to origin/loops/ruby after each commit
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Details
2026-05-06 06:47:27 +00:00
giles
15eb133311 ruby: Phase 1 parser (+83 tests, 190 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 11s
Details
2026-04-25 18:50:49 +00:00
giles
96019e9fe8 ruby: Phase 1 tokenizer (+107 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details 
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
946 changed files with 16577 additions and 188248 deletions
Expand all files Collapse all files

1
.claude/scheduled_tasks.lock
View File

@@ -1 +0,0 @@
{"sessionId":"31c80255-eb92-43e4-8997-84ad84e27326","pid":90960,"procStart":"564684","acquiredAt":1777049890282}

979
hosts/javascript/platform.py
View File

File diff suppressed because it is too large Load Diff

16
hosts/javascript/run_tests.js
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"]) {

59
hosts/javascript/transpiler.sx
View File

File diff suppressed because one or more lines are too long

73
hosts/ocaml/bin/bench_cek.ml
View File

@@ -1,73 +0,0 @@
(** CEK benchmark — measures throughput of the CEK evaluator on tight loops.
Usage:
dune exec bin/bench_cek.exe
dune exec bin/bench_cek.exe -- 5 (5 runs each)
*)
open Sx_types
open Sx_parser
let parse_one s =
let exprs = parse_all s in
match exprs with
| e :: _ -> e
| [] -> failwith "empty parse"
let parse_many s = parse_all s
let bench_run name setup expr iters =
let env = Sx_types.make_env () in
(* Run setup forms in env *)
List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) setup;
let times = ref [] in
for _ = 1 to iters do
Gc.full_major ();
let t0 = Unix.gettimeofday () in
let _r = Sx_ref.eval_expr expr (Env env) in
let t1 = Unix.gettimeofday () in
times := (t1 -. t0) :: !times
done;
let sorted = List.sort compare !times in
let median = List.nth sorted (iters / 2) in
let min_t = List.nth sorted 0 in
let max_t = List.nth sorted (iters - 1) in
Printf.printf " %-22s min=%8.2fms median=%8.2fms max=%8.2fms\n%!"
name (min_t *. 1000.0) (median *. 1000.0) (max_t *. 1000.0);
median
let () =
let iters =
if Array.length Sys.argv > 1
then int_of_string Sys.argv.(1)
else 5
in
Printf.printf "CEK benchmark (%d runs each, taking median)\n%!" iters;
Printf.printf "==========================================\n%!";
(* fib 18 — recursive function call benchmark, smallish *)
let fib_setup = parse_many "(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))" in
let fib_expr = parse_one "(fib 18)" in
let _ = bench_run "fib(18)" fib_setup fib_expr iters in
(* loop 5000 — tight let loop *)
let loop_setup = parse_many "(define (loop n acc) (if (= n 0) acc (loop (- n 1) (+ acc 1))))" in
let loop_expr = parse_one "(loop 5000 0)" in
let _ = bench_run "loop(5000)" loop_setup loop_expr iters in
(* map+square over 1000 elem list *)
let map_setup = parse_many "(define (range-list n) (let loop ((i 0) (acc (list))) (if (= i n) acc (loop (+ i 1) (cons i acc))))) (define xs (range-list 1000))" in
let map_expr = parse_one "(map (fn (x) (* x x)) xs)" in
let _ = bench_run "map sq xs(1000)" map_setup map_expr iters in
(* reduce + over 2000 elem list *)
let red_setup = parse_many "(define (range-list n) (let loop ((i 0) (acc (list))) (if (= i n) acc (loop (+ i 1) (cons i acc))))) (define ys (range-list 2000))" in
let red_expr = parse_one "(reduce + 0 ys)" in
let _ = bench_run "reduce + ys(2000)" red_setup red_expr iters in
(* let-heavy: many bindings + if *)
let lh_setup = parse_many "(define (lh n) (let ((a 1) (b 2) (c 3) (d 4)) (if (= n 0) (+ a b c d) (lh (- n 1)))))" in
let lh_expr = parse_one "(lh 2000)" in
let _ = bench_run "let-heavy(2000)" lh_setup lh_expr iters in
Printf.printf "\nDone.\n%!"

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

@@ -1,46 +0,0 @@
(* Benchmark inspect on representative SX values.
Takes min of 9 runs of n iterations to dampen GC noise. *)
open Sx_types
let rec make_tree d =
if d = 0 then String "leaf"
else List [String "node"; make_tree (d - 1); make_tree (d - 1); make_tree (d - 1)]
let bench_min label f n runs =
let times = ref [] in
for _ = 1 to runs do
Gc.compact ();
let t0 = Unix.gettimeofday () in
for _ = 1 to n do ignore (f ()) done;
let t1 = Unix.gettimeofday () in
times := (t1 -. t0) :: !times
done;
let sorted = List.sort compare !times in
let min_t = List.nth sorted 0 in
let median = List.nth sorted (runs / 2) in
Printf.printf " %-30s min=%6.2fms median=%6.2fms (n=%d * %d runs)\n%!"
label (min_t *. 1000.0 /. float_of_int n)
(median *. 1000.0 /. float_of_int n) n runs
let () =
let tree8 = make_tree 8 in
let s = inspect tree8 in
Printf.printf "tree-d8 inspect len=%d\n%!" (String.length s);
bench_min "inspect tree-d8" (fun () -> inspect tree8) 50 9;
let tree10 = make_tree 10 in
let s = inspect tree10 in
Printf.printf "tree-d10 inspect len=%d\n%!" (String.length s);
bench_min "inspect tree-d10" (fun () -> inspect tree10) 5 9;
let dict_xs = make_dict () in
for i = 0 to 999 do
Hashtbl.replace dict_xs (string_of_int i) (Integer i)
done;
let d = Dict dict_xs in
bench_min "inspect dict-1000" (fun () -> inspect d) 100 9;
let xs = ref [] in
for i = 0 to 1999 do xs := Integer i :: !xs done;
let lst = List !xs in
bench_min "inspect list-2000" (fun () -> inspect lst) 200 9

155
hosts/ocaml/bin/bench_vm.ml
View File

@@ -1,155 +0,0 @@
(** VM bytecode benchmark — measures throughput of the VM (compiled bytecode).
Loads the SX compiler via CEK, then for each test:
1. Define the function via CEK (as a Lambda).
2. Trigger JIT compilation via Sx_vm.jit_compile_lambda.
3. Call the compiled VmClosure repeatedly via Sx_vm.call_closure.
This measures pure VM execution time on the JIT path. *)
open Sx_types
let load_compiler env globals =
let compiler_path =
if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
else if Sys.file_exists "../../lib/compiler.sx" then "../../lib/compiler.sx"
else if Sys.file_exists "../../../lib/compiler.sx" then "../../../lib/compiler.sx"
else failwith "compiler.sx not found"
in
let ic = open_in compiler_path in
let src = really_input_string ic (in_channel_length ic) in
close_in ic;
let exprs = Sx_parser.parse_all src in
List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) exprs;
let rec sync e =
Hashtbl.iter (fun id v ->
let name = Sx_types.unintern id in
Hashtbl.replace globals name v) e.bindings;
match e.parent with Some p -> sync p | None -> ()
in
sync env
let _make_globals env =
let g = Hashtbl.create 512 in
Hashtbl.iter (fun name fn ->
Hashtbl.replace g name (NativeFn (name, fn))
) Sx_primitives.primitives;
let rec sync e =
Hashtbl.iter (fun id v ->
let name = Sx_types.unintern id in
if not (Hashtbl.mem g name) then Hashtbl.replace g name v) e.bindings;
match e.parent with Some p -> sync p | None -> ()
in
sync env;
g
let define_fn env globals name params body_src =
(* Define via CEK so we get a Lambda value with proper closure. *)
let body_expr = match Sx_parser.parse_all body_src with
| [e] -> e
| _ -> failwith "expected one body expression"
in
let param_syms = List (List.map (fun p -> Symbol p) params) in
let define_expr = List [Symbol "define"; Symbol name; List [Symbol "fn"; param_syms; body_expr]] in
ignore (Sx_ref.eval_expr define_expr (Env env));
(* Sync env to globals so JIT can resolve free vars. *)
let rec sync e =
Hashtbl.iter (fun id v ->
let n = Sx_types.unintern id in
Hashtbl.replace globals n v) e.bindings;
match e.parent with Some p -> sync p | None -> ()
in
sync env;
(* Now find the Lambda and JIT-compile it. *)
let lam_val = Hashtbl.find globals name in
match lam_val with
| Lambda l ->
(match Sx_vm.jit_compile_lambda l globals with
| Some cl ->
l.l_compiled <- Some cl;
Hashtbl.replace globals name (NativeFn (name, fun args ->
Sx_vm.call_closure cl args globals));
cl
| None ->
failwith (Printf.sprintf "JIT failed for %s" name))
| _ -> failwith (Printf.sprintf "%s is not a Lambda after define" name)
let bench_call name cl globals args iters =
let times = ref [] in
for _ = 1 to iters do
Gc.full_major ();
let t0 = Unix.gettimeofday () in
let _r = Sx_vm.call_closure cl args globals in
let t1 = Unix.gettimeofday () in
times := (t1 -. t0) :: !times
done;
let sorted = List.sort compare !times in
let median = List.nth sorted (iters / 2) in
let min_t = List.nth sorted 0 in
let max_t = List.nth sorted (iters - 1) in
Printf.printf " %-22s min=%8.2fms median=%8.2fms max=%8.2fms\n%!"
name (min_t *. 1000.0) (median *. 1000.0) (max_t *. 1000.0);
median
let () =
let iters =
if Array.length Sys.argv > 1
then int_of_string Sys.argv.(1)
else 7
in
Printf.printf "VM (bytecode/JIT) benchmark (%d runs each, taking median)\n%!" iters;
Printf.printf "========================================================\n%!";
let env = Sx_types.make_env () in
let bind n fn = ignore (Sx_types.env_bind env n (NativeFn (n, fn))) in
(* Seed env with primitives as NativeFn so CEK lookups work. *)
Hashtbl.iter (fun name fn ->
Hashtbl.replace env.bindings (Sx_types.intern name) (NativeFn (name, fn))
) Sx_primitives.primitives;
(* Helpers the SX compiler relies on but aren't kernel primitives. *)
bind "symbol-name" (fun args -> match args with
| [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name"));
bind "keyword-name" (fun args -> match args with
| [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name"));
bind "make-symbol" (fun args -> match args with
| [String s] -> Symbol s
| [v] -> Symbol (Sx_types.value_to_string v)
| _ -> raise (Eval_error "make-symbol"));
bind "sx-serialize" (fun args -> match args with
| [v] -> String (Sx_types.inspect v)
| _ -> raise (Eval_error "sx-serialize"));
let globals = Hashtbl.create 1024 in
Hashtbl.iter (fun name fn ->
Hashtbl.replace globals name (NativeFn (name, fn))
) Sx_primitives.primitives;
Printf.printf "Loading compiler.sx ... %!";
let t0 = Unix.gettimeofday () in
load_compiler env globals;
Printf.printf "%.0fms\n%!" ((Unix.gettimeofday () -. t0) *. 1000.0);
(* fib(22) — recursive call benchmark *)
let fib_cl = define_fn env globals "fib" ["n"]
"(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))" in
let _ = bench_call "fib(22)" fib_cl globals [Number 22.0] iters in
(* tight loop *)
let loop_cl = define_fn env globals "loop" ["n"; "acc"]
"(if (= n 0) acc (loop (- n 1) (+ acc 1)))" in
let _ = bench_call "loop(200000)" loop_cl globals [Number 200000.0; Number 0.0] iters in
(* sum-to *)
let sum_cl = define_fn env globals "sum_to" ["n"; "acc"]
"(if (= n 0) acc (sum_to (- n 1) (+ acc n)))" in
let _ = bench_call "sum-to(50000)" sum_cl globals [Number 50000.0; Number 0.0] iters in
(* count-lt: comparison-heavy *)
let cnt_cl = define_fn env globals "count_lt" ["n"; "acc"]
"(if (= n 0) acc (count_lt (- n 1) (if (< n 10000) (+ acc 1) acc)))" in
let _ = bench_call "count-lt(20000)" cnt_cl globals [Number 20000.0; Number 0.0] iters in
(* count-eq: equality-heavy on multiples of 7 *)
let eq_cl = define_fn env globals "count_eq" ["n"; "acc"]
"(if (= n 0) acc (count_eq (- n 1) (if (= 0 (- n (* 7 (/ n 7)))) (+ acc 1) acc)))" in
let _ = bench_call "count-eq(20000)" eq_cl globals [Number 20000.0; Number 0.0] iters in
Printf.printf "\nDone.\n%!"

2
hosts/ocaml/bin/dune
View File

@@ -1,5 +1,5 @@
(executables
(names run_tests debug_set sx_server integration_tests bench_cek bench_inspect bench_vm)
(names run_tests debug_set sx_server integration_tests)
(libraries sx unix threads.posix otfm yojson))
(executable

29
hosts/ocaml/bin/mcp_tree.ml
View File

@@ -1892,34 +1892,8 @@ let handle_sx_harness_eval args =
let file = args |> member "file" |> to_string_option in
let setup_str = args |> member "setup" |> to_string_option in
let files_json = try args |> member "files" with _ -> `Null in
let host_stubs = match args |> member "host_stubs" with `Bool b -> b | _ -> false in
let e = !env in
let warnings = ref [] in
(* Inject stub host primitives so files using host-get/host-new/etc. can load *)
if host_stubs then begin
let stubs = {|
(define host-global (fn (&rest _) nil))
(define host-get (fn (&rest _) nil))
(define host-set! (fn (obj k v) v))
(define host-call (fn (&rest _) nil))
(define host-new (fn (&rest _) (dict)))
(define host-callback (fn (f) f))
(define host-typeof (fn (&rest _) "string"))
(define hs-ref-eq (fn (a b) (identical? a b)))
(define host-call-fn (fn (&rest _) nil))
(define host-iter? (fn (&rest _) false))
(define host-to-list (fn (&rest _) (list)))
(define host-await (fn (&rest _) nil))
(define host-new-function (fn (&rest _) nil))
(define load-library! (fn (&rest _) false))
|} in
let stub_exprs = Sx_parser.parse_all stubs in
List.iter (fun expr ->
try ignore (Sx_ref.eval_expr expr (Env e))
with exn ->
warnings := Printf.sprintf "Stub warning: %s" (Printexc.to_string exn) :: !warnings
) stub_exprs
end;
(* Collect all files to load *)
let all_files = match files_json with
| `List items ->
@@ -3044,8 +3018,7 @@ let tool_definitions = `List [
("mock", `Assoc [("type", `String "string"); ("description", `String "Optional mock platform overrides as SX dict, e.g. {:fetch (fn (url) {:status 200})}")]);
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]);
("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String "Multiple .sx files to load in order")]);
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")]);
("host_stubs", `Assoc [("type", `String "boolean"); ("description", `String "If true, inject nil-returning stubs for host-get/host-set!/host-call/host-new/etc. so files that use host primitives can load in the harness")])]
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")])]
["expr"];
tool "sx_nav" "Manage sx-docs navigation and articles. Modes: list (all nav items with status), check (validate consistency), add (create article + nav entry), delete (remove nav entry + page fn), move (move entry between sections, rewriting hrefs)."
[("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: list, check, add, delete, or move")]);

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

File diff suppressed because it is too large Load Diff

204
hosts/ocaml/bin/sx_server.ml
View File

@@ -18,20 +18,6 @@
open Sx_types
(* Force-link Sx_vm_extensions so its module-init runs: installs the
extension dispatch fallthrough and registers the `extension-opcode-id`
SX primitive. Without a reference here OCaml dead-code-eliminates the
module from sx_server.exe (it's only otherwise reached from run_tests),
leaving guest-language opcode extensions (Erlang Phase 9, etc.)
invisible to the runtime. The applied call is a harmless lookup. *)
let () = ignore (Sx_vm_extensions.id_of_name "")
(* Register the Erlang opcode extension (Phase 9h) so
`extension-opcode-id "erlang.OP_*"` resolves to the host ids the SX
stub dispatcher consults. Guarded: a double-register raises Failure,
which we swallow so a re-entered server process doesn't die. *)
let () = try Erlang_ext.register () with Failure _ -> ()
(* ====================================================================== *)
(* Font measurement via otfm — reads OpenType/TrueType font tables *)
(* ====================================================================== *)
@@ -310,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. *)
@@ -375,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)] ->
@@ -419,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
@@ -717,144 +688,6 @@ let setup_evaluator_bridge env =
| [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
| [expr] -> Sx_ref.eval_expr expr (Env env)
| _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
(* eval-in-env: (env expr) → result. Evaluates expr in the given env. *)
Sx_primitives.register "eval-in-env" (fun args ->
match args with
| [e; expr] -> Sx_ref.eval_expr expr e
| _ -> raise (Eval_error "eval-in-env: (env expr)"));
(* fed-sx Milestone 1 Step 8 transport. NATIVE ONLY — sockets +
threads; deliberately absent from the WASM kernel (registered
here in bin/, never in lib/sx_primitives.ml). Minimal HTTP/1.1,
Connection: close. handler : req-dict -> resp-dict where
req = {:method :path :query :headers :body},
resp = {:status :headers :body}. Never returns. *)
Sx_primitives.register "http-listen" (fun args ->
let strip_cr s =
let n = String.length s in
if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
in
match args with
| [port_v; handler] ->
let port = match port_v with
| Integer n -> n
| Number f -> int_of_float f
| _ -> raise (Eval_error "http-listen: (port handler)") in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.setsockopt sock Unix.SO_REUSEADDR true;
Unix.bind sock
(Unix.ADDR_INET (Unix.inet_addr_loopback, port));
Unix.listen sock 64;
(* SX runtime is shared across threads — serialize handler calls. *)
let mtx = Mutex.create () in
let reason = function
| 200 -> "OK" | 201 -> "Created" | 204 -> "No Content"
| 301 -> "Moved Permanently" | 302 -> "Found"
| 400 -> "Bad Request" | 401 -> "Unauthorized"
| 403 -> "Forbidden" | 404 -> "Not Found"
| 405 -> "Method Not Allowed" | 500 -> "Internal Server Error"
| _ -> "OK" in
let handle fd =
(try
let ic = Unix.in_channel_of_descr fd in
let oc = Unix.out_channel_of_descr fd in
let reqline = strip_cr (input_line ic) in
(match String.split_on_char ' ' reqline with
| meth :: target :: _ ->
let path, query =
match String.index_opt target '?' with
| Some i ->
String.sub target 0 i,
String.sub target (i + 1)
(String.length target - i - 1)
| None -> target, "" in
let headers = Sx_types.make_dict () in
let clen = ref 0 in
let rec rdh () =
let h = strip_cr (input_line ic) in
if h = "" then ()
else begin
(match String.index_opt h ':' with
| Some i ->
let name =
String.lowercase_ascii
(String.trim (String.sub h 0 i)) in
let value =
String.trim
(String.sub h (i + 1)
(String.length h - i - 1)) in
Hashtbl.replace headers name (String value);
if name = "content-length" then
(try clen := int_of_string value with _ -> ())
| None -> ());
rdh ()
end in
rdh ();
let body =
if !clen > 0 then begin
let b = Bytes.create !clen in
really_input ic b 0 !clen;
Bytes.unsafe_to_string b
end else "" in
let req = Sx_types.make_dict () in
Hashtbl.replace req "method" (String meth);
Hashtbl.replace req "path" (String path);
Hashtbl.replace req "query" (String query);
Hashtbl.replace req "headers" (Dict headers);
Hashtbl.replace req "body" (String body);
Mutex.lock mtx;
let resp =
(try Sx_runtime.sx_call handler [Dict req]
with e -> Mutex.unlock mtx; raise e) in
Mutex.unlock mtx;
let getk k = match resp with
| Dict h -> Hashtbl.find_opt h k | _ -> None in
let status = match getk "status" with
| Some (Integer n) -> n
| Some (Number f) -> int_of_float f
| _ -> 200 in
let rbody = match getk "body" with
| Some (String s) -> s
| Some v -> Sx_types.value_to_string v
| None -> "" in
let rhdrs = match getk "headers" with
| Some (Dict h) ->
Hashtbl.fold (fun k v acc ->
(k, (match v with
| String s -> s
| v -> Sx_types.value_to_string v)) :: acc)
h []
| _ -> [] in
let buf = Buffer.create 256 in
Buffer.add_string buf
(Printf.sprintf "HTTP/1.1 %d %s\r\n" status
(reason status));
List.iter (fun (k, v) ->
Buffer.add_string buf
(Printf.sprintf "%s: %s\r\n" k v)) rhdrs;
if not (List.exists
(fun (k, _) ->
String.lowercase_ascii k = "content-type")
rhdrs)
then Buffer.add_string buf
"Content-Type: text/plain\r\n";
Buffer.add_string buf
(Printf.sprintf "Content-Length: %d\r\n"
(String.length rbody));
Buffer.add_string buf "Connection: close\r\n\r\n";
Buffer.add_string buf rbody;
output_string oc (Buffer.contents buf);
flush oc
| _ -> ())
with _ -> ());
(try Unix.close fd with _ -> ())
in
while true do
let fd, _ = Unix.accept sock in
ignore (Thread.create handle fd)
done;
Nil
| _ -> raise (Eval_error "http-listen: (port handler)"));
bind "trampoline" (fun args ->
match args with
| [v] ->
@@ -916,13 +749,7 @@ let setup_evaluator_bridge env =
| _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args ->
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))));
(* current-env: special form — returns current lexical env as a first-class value *)
ignore (Sx_ref.register_special_form (String "current-env")
(NativeFn ("current-env", fun args ->
match args with
| [_arg_list; env_val] -> env_val
| _ -> Nil)))
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))))
(* ---- Type predicates and introspection ---- *)
let setup_introspection env =
@@ -1108,24 +935,7 @@ let setup_env_operations env =
bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string"));
bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value"));
bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value"));
bind "env-extend" (fun args ->
match args with
| e :: pairs ->
let child = Sx_types.env_extend (uw e) in
let rec go = function
| [] -> ()
| k :: v :: rest ->
ignore (Sx_types.env_bind child (Sx_runtime.value_to_str k) v); go rest
| [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
go pairs; Env child
| _ -> raise (Eval_error "env-extend: expected env"));
bind "env-lookup" (fun args ->
match args with
| [e; key] ->
let k = Sx_runtime.value_to_str key in
let raw = uw e in
if Sx_types.env_has raw k then Sx_types.env_get raw k else Nil
| _ -> raise (Eval_error "env-lookup: (env key)"));
bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env"));
bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs"))
(* ---- Strict mode (gradual type system support) ---- *)
@@ -1149,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)
@@ -1552,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
@@ -1566,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)
@@ -4646,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
@@ -4705,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

49
hosts/ocaml/bin/test_http.sh
View File

@@ -1,49 +0,0 @@
#!/usr/bin/env bash
# Phase H test — native-only http-listen primitive.
# Starts sx_server with a tiny SX echo handler, drives it with curl
# (GET / POST / 404 / custom header), asserts, then kills it.
set -u
cd "$(dirname "$0")/.."
SRV=_build/default/bin/sx_server.exe
PORT=${HTTP_TEST_PORT:-8911}
PASS=0
FAIL=0
ok() { echo " PASS: $1"; PASS=$((PASS+1)); }
bad() { echo " FAIL: $1 — $2"; FAIL=$((FAIL+1)); }
if [ ! -x "$SRV" ]; then
echo "build sx_server.exe first (dune build bin/sx_server.exe)"; exit 1
fi
H='(begin (define (h req) (if (= (get req "path") "/echo") {:status 200 :headers {"X-Echo" (get req "method")} :body (str "M=" (get req "method") " P=" (get req "path") " Q=" (get req "query") " B=" (get req "body"))} {:status 404 :body "nope"})) (http-listen '"$PORT"' h))'
ESC=${H//\"/\\\"}
{ printf '(epoch 1)\n(eval "%s")\n' "$ESC"; sleep 30; } | "$SRV" >/tmp/test_http_srv.out 2>&1 &
SVPID=$!
trap 'kill $SVPID 2>/dev/null; wait 2>/dev/null' EXIT
up=0
for _ in $(seq 1 50); do
curl -s -o /dev/null "http://127.0.0.1:$PORT/echo" 2>/dev/null && { up=1; break; }
sleep 0.2
done
[ "$up" = 1 ] || { echo " FAIL: server did not start"; cat /tmp/test_http_srv.out; exit 1; }
# GET with query + custom response header.
g=$(curl -s -i "http://127.0.0.1:$PORT/echo?x=1" | tr -d '\r')
echo "$g" | grep -q '^HTTP/1.1 200 OK' && ok "GET status 200" || bad "GET status" "$g"
echo "$g" | grep -q '^X-Echo: GET' && ok "GET custom header" || bad "GET header" "$g"
echo "$g" | grep -q '^M=GET P=/echo Q=x=1 B=$' && ok "GET echo body" || bad "GET body" "$g"
# POST with body.
p=$(curl -s -X POST --data 'hello' "http://127.0.0.1:$PORT/echo")
[ "$p" = 'M=POST P=/echo Q= B=hello' ] && ok "POST body echoed" || bad "POST body" "$p"
# 404 path.
n=$(curl -s -i "http://127.0.0.1:$PORT/missing" | tr -d '\r')
echo "$n" | grep -q '^HTTP/1.1 404 Not Found' && ok "404 status" || bad "404 status" "$n"
echo "$n" | grep -q '^nope$' && ok "404 body" || bad "404 body" "$n"
echo "Results: $PASS passed, $FAIL failed"
[ "$FAIL" = 0 ]

115
hosts/ocaml/bootstrap.py
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)
@@ -82,10 +80,7 @@ let cek_run_iterative state =
s := cek_step !s
done;
(match cek_suspended_p !s with
| Bool true ->
(match !_cek_io_suspend_hook with
| Some hook -> hook !s
| None -> raise (Eval_error "IO suspension in non-IO context"))
| Bool true -> raise (Eval_error "IO suspension in non-IO context")
| _ -> cek_value !s)
with Eval_error msg ->
_last_error_kont_ref := cek_kont !s;
@@ -131,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)))
"""
@@ -260,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)
@@ -311,23 +219,6 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
output
)
# Patch transpiled cek_run to invoke _cek_io_suspend_hook on suspension
# instead of unconditionally raising Eval_error. This is the fix for the
# tree-walk eval_expr path: sf_letrec init exprs / non-last body exprs,
# macro bodies, qq_expand, dynamic-wind / scope / provide bodies all use
# `trampoline (eval_expr ...)` and were swallowing CEK suspensions as
# "IO suspension in non-IO context" errors. With the hook, the suspension
# propagates as VmSuspended to the outer driver (browser callFn / server
# eval_expr_io). When the hook is unset (pure-CEK harness), the legacy
# error is preserved as the fallback.
output = re.sub(
r'\(raise \(Eval_error \(value_to_str \(String "IO suspension in non-IO context"\)\)\)\)',
'(match !_cek_io_suspend_hook with Some hook -> hook final | None -> '
'(raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))))',
output,
count=1,
)
return output

4
hosts/ocaml/bootstrap_vm.py
View File

@@ -355,9 +355,7 @@ let vm_create_closure vm_val frame_val code_val =
let f = unwrap_frame frame_val in
let uv_count = match code_val with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Integer n) -> n
| Some (Number n) -> int_of_float n
| _ -> 0)
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0
in
let upvalues = Array.init uv_count (fun _ ->

3
hosts/ocaml/browser/bundle.sh
View File

@@ -75,9 +75,6 @@ cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/"
for f in tokenizer parser compiler runtime integration htmx; do
cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx"
done
for f in worker prolog; do
cp "$ROOT/lib/hyperscript/plugins/$f.sx" "$DIST/sx/hs-$f.sx"
done
# Summary
WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1)

9
hosts/ocaml/browser/compile-modules.js
View File

@@ -85,7 +85,6 @@ const FILES = [
'harness-web.sx', 'engine.sx', 'orchestration.sx',
// Hyperscript modules — loaded on demand via transparent lazy loader
'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx',
'hs-worker.sx', 'hs-prolog.sx',
'hs-integration.sx', 'hs-htmx.sx',
'boot.sx',
];
@@ -456,10 +455,8 @@ for (const file of FILES) {
'hs-parser': ['hs-tokenizer'],
'hs-compiler': ['hs-tokenizer', 'hs-parser'],
'hs-runtime': ['hs-tokenizer', 'hs-parser', 'hs-compiler'],
'hs-worker': ['hs-tokenizer', 'hs-parser'],
'hs-prolog': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog'],
'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog', 'hs-integration'],
'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration'],
};
manifest[key] = {
file: sxbcFile,
@@ -480,7 +477,7 @@ if (entryFile) {
const lazyDeps = entryFile.deps.filter(d => LAZY_ENTRY_DEPS.has(d));
// Hyperscript modules aren't define-library, so not auto-detected as deps.
// Load them lazily after boot — eager loading breaks the boot sequence.
const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog', 'hs-integration', 'hs-htmx'];
const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration', 'hs-htmx'];
for (const m of HS_LAZY) {
if (manifest[m] && !lazyDeps.includes(m)) lazyDeps.push(m);
}

25
hosts/ocaml/browser/sx_browser.ml
View File

@@ -344,12 +344,6 @@ let api_eval src_js =
sync_env_to_vm ();
return_via_side_channel (value_to_js result)
with
| Sx_vm.VmSuspended _ ->
(* Top-level eval encountered an IO suspension propagated via the
cek_run hook (perform inside letrec init / non-last body / macro /
qq tree-walked path). K.eval doesn't drive resumption — surface as
a clear error so the caller knows to use callFn instead. *)
Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)")
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
@@ -377,8 +371,6 @@ let api_eval_vm src_js =
) _vm_globals;
return_via_side_channel (value_to_js result)
with
| Sx_vm.VmSuspended _ ->
Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)")
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
| Not_found -> Js.Unsafe.inject (Js.string "Error: compile-module not loaded")
@@ -389,10 +381,7 @@ let api_eval_expr expr_js _env_js =
let result = Sx_ref.eval_expr expr (Env global_env) in
sync_env_to_vm ();
return_via_side_channel (value_to_js result)
with
| Sx_vm.VmSuspended _ ->
Js.Unsafe.inject (Js.string "Error: IO suspension in non-IO context (use callFn for IO-aware paths)")
| Eval_error msg ->
with Eval_error msg ->
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
let api_load src_js =
@@ -676,11 +665,7 @@ let () =
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
| Number a, Number b -> a = b | String a, String b -> a = b
| Symbol a, Symbol b -> a = b | Keyword a, Keyword b -> a = b
| (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
List.length a = List.length b && List.for_all2 deep_equal a b
@@ -719,10 +704,8 @@ let () =
| List (Symbol "code" :: rest) ->
let d = Hashtbl.create 8 in
let rec parse_kv = function
| Keyword "arity" :: (Number _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest
| Keyword "arity" :: (Integer _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest
| Keyword "upvalue-count" :: (Number _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest
| Keyword "upvalue-count" :: (Integer _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest
| Keyword "arity" :: Number n :: rest -> Hashtbl.replace d "arity" (Number n); parse_kv rest
| Keyword "upvalue-count" :: Number n :: rest -> Hashtbl.replace d "upvalue-count" (Number n); parse_kv rest
| Keyword "bytecode" :: List nums :: rest ->
Hashtbl.replace d "bytecode" (List nums); parse_kv rest
| Keyword "constants" :: List consts :: rest ->

172
hosts/ocaml/browser/test_letrec_resume.js
View File

@@ -1,172 +0,0 @@
#!/usr/bin/env node
// Repro: letrec sibling bindings nil after perform/resume in browser kernel
//
// Bug: After a CEK IO suspension (perform / hs-wait) resumes in the
// WASM browser kernel, calling a sibling letrec binding could return
// nil, with the error surfaced as `[sx] resume: Not callable: nil`.
//
// Root cause: cek-run / cek_run_iterative raised
// `"IO suspension in non-IO context"` when a tree-walked eval_expr
// (sf_letrec init exprs / non-last body, macro body, qq unquote, scope
// body, provide body, dynamic-wind) hit a perform. The CEK suspension
// was created correctly but never propagated through the OCaml-side
// _cek_io_suspend_hook, so the outer driver never saw VmSuspended.
//
// Fix: cek_run / cek_run_iterative now invoke _cek_io_suspend_hook on
// suspension (raising VmSuspended for the outer driver). When the hook
// is unset (pure-CEK harness), they fall back to the legacy error.
//
// This test exercises the WASM kernel through K.callFn — the path that
// browser event handlers use. Suspension surfaces as a JS object with
// {suspended, request, resume(result)} that the test drives synchronously.
//
// Companion: spec/tests/test-letrec-resume-treewalk.sx tests the
// CEK-only path through the OCaml test runner.
const path = require('path');
const fs = require('fs');
const KERNEL = path.join(__dirname, '..', '_build', 'default', 'browser', 'sx_browser.bc.js');
if (!fs.existsSync(KERNEL)) {
console.error('FATAL: missing ' + KERNEL + ' — run `dune build` from hosts/ocaml first');
process.exit(2);
}
require(KERNEL);
const K = globalThis.SxKernel;
let passed = 0, failed = 0;
const failures = [];
function test(name, fn) {
try {
const r = fn();
if (r === true) {
passed++;
console.log(' PASS: ' + name);
} else {
failed++;
failures.push({ name, error: 'got ' + JSON.stringify(r) });
console.log(' FAIL: ' + name + ' — got ' + JSON.stringify(r));
}
} catch (e) {
failed++;
failures.push({ name, error: e.message || String(e) });
console.log(' FAIL: ' + name + ' — ' + (e.message || e));
}
}
function driveSync(result) {
while (result && typeof result === 'object' && result.suspended) {
result = result.resume(null);
}
return result;
}
function callExpr(src) {
K.eval('(define _t-fn (fn () ' + src + '))');
const fn = K.eval('_t-fn');
return driveSync(K.callFn(fn, []));
}
console.log('\n=== letrec + perform/resume regression tests ===\n');
test('basic letrec without perform', () =>
callExpr('(letrec ((f (fn () "ok"))) (f))') === 'ok');
test('callFn perform suspends and resumes with nil', () => {
K.eval('(define _t-perform (fn () (perform {:op "io"})))');
let r = K.callFn(K.eval('_t-perform'), []);
if (!r || !r.suspended) return 'no suspension: ' + JSON.stringify(r);
return r.resume(null) === null;
});
test('letrec, single binding, perform/resume', () =>
callExpr('(letrec ((f (fn () (perform {:op "io"})))) (f))') === null);
test('letrec, 2 bindings, body calls sibling after suspended call', () =>
callExpr(`
(letrec
((wait-then (fn () (do (perform {:op "io"}) "wait-done")))
(other-fn (fn () "other-result")))
(do (wait-then) (other-fn)))`) === 'other-result');
test('letrec, suspending fn calls sibling after own perform', () =>
callExpr(`
(letrec
((wait-and-call (fn () (do (perform {:op "io"}) (other-fn))))
(other-fn (fn () "from-sibling")))
(wait-and-call))`) === 'from-sibling');
test('letrec, fn references sibling value after perform/resume', () =>
callExpr(`
(letrec
((shared "shared-state")
(do-fn (fn () (do (perform {:op "io"}) shared))))
(do-fn))`) === 'shared-state');
test('letrec, recursive self-call after perform (wait-boot pattern)', () => {
K.eval('(define _wb-c 0)');
K.eval('(set! _wb-c 0)');
return callExpr(`
(letrec ((wait-boot (fn ()
(do (perform {:op "io"})
(if (>= _wb-c 1)
"done"
(do (set! _wb-c (+ 1 _wb-c))
(wait-boot)))))))
(wait-boot))`) === 'done';
});
test('top-level define + perform + sibling call after resume', () => {
K.eval('(define do-suspend-x (fn () (do (perform {:op "io"}) (do-other-x))))');
K.eval('(define do-other-x (fn () "ok-from-other"))');
return callExpr('(do-suspend-x)') === 'ok-from-other';
});
test('letrec, two performs (sequential) then sibling call', () =>
callExpr(`
(letrec
((wait-twice (fn () (do (perform {:op "io1"}) (perform {:op "io2"}) (other))))
(other (fn () "after-double")))
(wait-twice))`) === 'after-double');
// === Tree-walk paths that previously raised "IO suspension in non-IO context" ===
test('letrec init expr with perform — suspension propagates (no error)', () => {
let r;
try { r = callExpr('(letrec ((x (perform {:op "io"}))) "ok")'); }
catch (e) { return 'threw: ' + e.message; }
return r === null || r === 'ok';
});
test('letrec non-last body with perform — suspension propagates (no error)', () => {
let r;
try { r = callExpr('(letrec ((x 1)) (perform {:op "io"}) "after")'); }
catch (e) { return 'threw: ' + e.message; }
return r === null || r === 'after';
});
test('macro body with perform — suspension propagates', () => {
K.eval('(defmacro _m1 (form) (do (perform {:op "io"}) form))');
let r;
try { r = callExpr('(_m1 "macro-ok")'); }
catch (e) { return 'threw: ' + e.message; }
return r === 'macro-ok' || r === null;
});
test('quasiquote unquote with perform — suspension propagates', () => {
let r;
try { r = callExpr('(let ((y "yyy")) `(a ,(do (perform {:op "io"}) y) c))'); }
catch (e) { return 'threw: ' + e.message; }
return r !== undefined;
});
console.log('\n--- Results ---');
console.log('passed: ' + passed);
console.log('failed: ' + failed);
if (failed > 0) {
console.log('\nFailures:');
failures.forEach(f => console.log(' - ' + f.name + ': ' + f.error));
process.exit(1);
}
process.exit(0);

6
hosts/ocaml/lib/dune
View File

@@ -1,8 +1,4 @@
(library
(name sx)
(wrapped false)
(libraries re re.pcre unix))
; Pull in extension modules from lib/extensions/ (test_ext.ml, etc).
; See plans/sx-vm-opcode-extension.md.
(include_subdirs unqualified)
(libraries re re.pcre))

71
hosts/ocaml/lib/extensions/README.md
View File

@@ -1,71 +0,0 @@
# SX VM extensions
Each `*.ml` file here is a VM extension — a first-class OCaml module that
registers specialized bytecode opcodes with `Sx_vm_extensions`. See
[`plans/sx-vm-opcode-extension.md`](../../../../plans/sx-vm-opcode-extension.md)
for the design.
## Pattern
```ocaml
(* lib/extensions/myport.ml *)
open Sx_types
type Sx_vm_extension.extension_state += MyportState of { ... }
module M : Sx_vm_extension.EXTENSION = struct
let name = "myport"
let init () = MyportState { ... }
let opcodes _st = [
(id, "myport.OP_NAME", handler);
...
]
end
let register () = Sx_vm_extensions.register (module M)
```
Then call `Myport.register ()` once at startup from any binary that
should have the extension loaded.
## Opcode-ID allocation
Range 200-247 (per `Sx_vm_extensions.extension_min` /
`extension_max`). Conventions:
| Range | Use |
|---------|-------------------------------------------------------------------------|
| 200-209 | reserved for `lib/guest/vm/` shared opcodes (chiselled out on 2nd use) |
| 210-219 | inline test extensions defined in `bin/run_tests.ml` |
| 220-229 | this directory's `test_ext` (the canonical template) |
| 230-247 | first-come-first-served by language ports (Erlang first) |
When a port claims a contiguous block, document it in the table above.
The registry rejects collisions at startup with a loud error — there is
no silent shadowing.
## Naming
Always prefix opcode names with the extension name plus a dot:
`myport.OP_<NAME>`. The prefix is a hard convention so that multiple
extensions can share the global opcode-name namespace cleanly.
## State
`extension_state` is an extensible variant. Add your case (e.g.
`MyportState of { ... }`) at the top of your file, return it from
`init`, and pattern-match it inside your handlers. Other extensions
cannot see your state — the variant case is private to your module.
## Testing
`test_ext.ml` is the canonical worked example. `bin/run_tests.ml`
calls `Test_ext.register ()`, then drives bytecode that exercises the
opcodes end-to-end (push, double, dispatch, disassemble, invocation
counter). Mirror this shape when adding a real port's extension.
## Build wiring
`lib/dune` has `(include_subdirs unqualified)`, so any `.ml` you drop
in here is automatically part of the `sx` library. Module name follows
the filename verbatim (`test_ext.ml` → `Test_ext`).

278
hosts/ocaml/lib/extensions/erlang_ext.ml
View File

@@ -1,278 +0,0 @@
(** {1 [erlang_ext] — Erlang-on-SX VM opcode extension (Phase 9h)}
Registers the Erlang opcode namespace in [Sx_vm_extensions] so that
[extension-opcode-id "erlang.OP_*"] resolves to a stable id. The SX
stub dispatcher in [lib/erlang/vm/dispatcher.sx] consults these ids
(Phase 9i) and falls back to its own local ids when the host
extension is absent.
Opcode ids occupy 222-239 in the extension partition (200-247).
222+ is chosen to clear the test extensions' reserved ids
(test_reg 210/211, test_ext 220/221) so all three coexist in
run_tests; production sx_server only registers this one. Names
mirror the SX stub dispatcher exactly:
- 222 erlang.OP_PATTERN_TUPLE - 231 erlang.OP_BIF_HD
- 223 erlang.OP_PATTERN_LIST - 232 erlang.OP_BIF_TL
- 224 erlang.OP_PATTERN_BINARY - 233 erlang.OP_BIF_ELEMENT
- 225 erlang.OP_PERFORM - 234 erlang.OP_BIF_TUPLE_SIZE
- 226 erlang.OP_HANDLE - 235 erlang.OP_BIF_LISTS_REVERSE
- 227 erlang.OP_RECEIVE_SCAN - 236 erlang.OP_BIF_IS_INTEGER
- 228 erlang.OP_SPAWN - 237 erlang.OP_BIF_IS_ATOM
- 229 erlang.OP_SEND - 238 erlang.OP_BIF_IS_LIST
- 230 erlang.OP_BIF_LENGTH - 239 erlang.OP_BIF_IS_TUPLE
{2 Handler status}
The bytecode compiler does not yet emit these opcodes — Erlang
programs run through the general CEK path and the working
specialization path is the SX stub dispatcher. So every handler
here raises a descriptive [Eval_error] rather than silently
corrupting the VM stack. This keeps the extension honest: the
namespace is registered and disassembles by name, [extension-opcode-id]
works, but actually dispatching an opcode (which only happens once a
future phase teaches the compiler to emit them) fails loudly with a
pointer to the phase that will wire it. Real stack-machine handlers
land alongside compiler emission in a later phase. *)
open Sx_types
(** Per-instance state: invocation counter, purely to exercise the
[extension_state] machinery (mirrors [test_ext]). *)
type Sx_vm_extension.extension_state += ErlangExtState of {
mutable dispatched : int;
}
let not_wired name =
raise (Eval_error
(Printf.sprintf
"%s: bytecode emission not yet wired (Phase 9j) — \
Erlang runs via CEK; specialization path is the SX stub \
dispatcher in lib/erlang/vm/dispatcher.sx"
name))
module M : Sx_vm_extension.EXTENSION = struct
let name = "erlang"
let init () = ErlangExtState { dispatched = 0 }
let opcodes st =
let bump () = match st with
| ErlangExtState s -> s.dispatched <- s.dispatched + 1
| _ -> ()
in
let op id nm =
(id, nm, (fun (_vm : Sx_vm.vm) (_frame : Sx_vm.frame) ->
bump (); not_wired nm))
in
(* Phase 10b vertical slice: one REAL register-machine handler.
erlang.OP_BIF_LENGTH (230) — pops an Erlang list off the VM
stack and pushes its length. Proves the full path works:
extension-opcode-id -> bytecode -> Sx_vm dispatch fallthrough
-> this handler -> correct stack result. The remaining 17
opcodes still raise not_wired until their handlers + compiler
emission land. Erlang lists are tagged dicts:
nil = {"tag" -> String "nil"}
cons = {"tag" -> String "cons"; "head" -> v; "tail" -> v} *)
let er_tag d =
match Hashtbl.find_opt d "tag" with
| Some (String s) -> s | _ -> ""
in
let op_bif_length =
(230, "erlang.OP_BIF_LENGTH",
(fun (vm : Sx_vm.vm) (_frame : Sx_vm.frame) ->
bump ();
let v = Sx_vm.pop vm in
let rec walk acc node =
match node with
| Dict d ->
(match er_tag d with
| "nil" -> acc
| "cons" ->
(match Hashtbl.find_opt d "tail" with
| Some t -> walk (acc + 1) t
| None -> raise (Eval_error
"erlang.OP_BIF_LENGTH: cons cell without :tail"))
| _ -> raise (Eval_error
"erlang.OP_BIF_LENGTH: not a proper list"))
| _ -> raise (Eval_error
"erlang.OP_BIF_LENGTH: not a proper list")
in
Sx_vm.push vm (Integer (walk 0 v))))
in
(* Phase 10b — simple hot-BIF handlers. Erlang bool is the atom
{"tag"->"atom"; "name"->"true"|"false"}; mk_atom builds it. *)
let mk_atom nm =
let h = Hashtbl.create 2 in
Hashtbl.replace h "tag" (String "atom");
Hashtbl.replace h "name" (String nm);
Dict h
in
let er_bool b = mk_atom (if b then "true" else "false") in
let is_tag v t = match v with
| Dict d -> er_tag d = t
| _ -> false
in
let op_bif_hd =
(231, "erlang.OP_BIF_HD",
(fun (vm : Sx_vm.vm) _f ->
bump ();
match Sx_vm.pop vm with
| Dict d when er_tag d = "cons" ->
(match Hashtbl.find_opt d "head" with
| Some h -> Sx_vm.push vm h
| None -> raise (Eval_error "erlang.OP_BIF_HD: cons without :head"))
| _ -> raise (Eval_error "erlang.OP_BIF_HD: not a cons")))
in
let op_bif_tl =
(232, "erlang.OP_BIF_TL",
(fun (vm : Sx_vm.vm) _f ->
bump ();
match Sx_vm.pop vm with
| Dict d when er_tag d = "cons" ->
(match Hashtbl.find_opt d "tail" with
| Some t -> Sx_vm.push vm t
| None -> raise (Eval_error "erlang.OP_BIF_TL: cons without :tail"))
| _ -> raise (Eval_error "erlang.OP_BIF_TL: not a cons")))
in
let op_bif_tuple_size =
(234, "erlang.OP_BIF_TUPLE_SIZE",
(fun (vm : Sx_vm.vm) _f ->
bump ();
match Sx_vm.pop vm with
| Dict d when er_tag d = "tuple" ->
let n = match Hashtbl.find_opt d "elements" with
| Some (List es) -> List.length es
| Some (ListRef r) -> List.length !r
| _ -> raise (Eval_error
"erlang.OP_BIF_TUPLE_SIZE: tuple without :elements")
in
Sx_vm.push vm (Integer n)
| _ -> raise (Eval_error "erlang.OP_BIF_TUPLE_SIZE: not a tuple")))
in
let op_bif_is_integer =
(236, "erlang.OP_BIF_IS_INTEGER",
(fun (vm : Sx_vm.vm) _f ->
bump ();
let v = Sx_vm.pop vm in
Sx_vm.push vm (er_bool (match v with Integer _ -> true | _ -> false))))
in
let op_bif_is_atom =
(237, "erlang.OP_BIF_IS_ATOM",
(fun (vm : Sx_vm.vm) _f ->
bump ();
let v = Sx_vm.pop vm in
Sx_vm.push vm (er_bool (is_tag v "atom"))))
in
let op_bif_is_list =
(238, "erlang.OP_BIF_IS_LIST",
(fun (vm : Sx_vm.vm) _f ->
bump ();
let v = Sx_vm.pop vm in
Sx_vm.push vm (er_bool (is_tag v "cons" || is_tag v "nil"))))
in
let op_bif_is_tuple =
(239, "erlang.OP_BIF_IS_TUPLE",
(fun (vm : Sx_vm.vm) _f ->
bump ();
let v = Sx_vm.pop vm in
Sx_vm.push vm (er_bool (is_tag v "tuple"))))
in
(* element/2 and lists:reverse/1 — pure stack transforms (no
bytecode operands). Calling convention: args pushed left→right,
so element/2 stack is [.. Index Tuple] (Tuple on top). Erlang
element/2 is 1-indexed. *)
let op_bif_element =
(233, "erlang.OP_BIF_ELEMENT",
(fun (vm : Sx_vm.vm) _f ->
bump ();
let tup = Sx_vm.pop vm in
let idx = Sx_vm.pop vm in
match tup, idx with
| Dict d, Integer i when er_tag d = "tuple" ->
let es = match Hashtbl.find_opt d "elements" with
| Some (List es) -> es
| Some (ListRef r) -> !r
| _ -> raise (Eval_error
"erlang.OP_BIF_ELEMENT: tuple without :elements")
in
let n = List.length es in
if i < 1 || i > n then
raise (Eval_error
(Printf.sprintf
"erlang.OP_BIF_ELEMENT: index %d out of range 1..%d" i n))
else
Sx_vm.push vm (List.nth es (i - 1))
| _, Integer _ ->
raise (Eval_error "erlang.OP_BIF_ELEMENT: 2nd arg not a tuple")
| _ ->
raise (Eval_error "erlang.OP_BIF_ELEMENT: 1st arg not an integer")))
in
let op_bif_lists_reverse =
(235, "erlang.OP_BIF_LISTS_REVERSE",
(fun (vm : Sx_vm.vm) _f ->
bump ();
let v = Sx_vm.pop vm in
let mk_nil () =
let h = Hashtbl.create 1 in
Hashtbl.replace h "tag" (String "nil"); Dict h in
let mk_cons hd tl =
let h = Hashtbl.create 3 in
Hashtbl.replace h "tag" (String "cons");
Hashtbl.replace h "head" hd;
Hashtbl.replace h "tail" tl;
Dict h in
let rec rev acc node =
match node with
| Dict d ->
(match er_tag d with
| "nil" -> acc
| "cons" ->
let hd = match Hashtbl.find_opt d "head" with
| Some x -> x
| None -> raise (Eval_error
"erlang.OP_BIF_LISTS_REVERSE: cons without :head") in
let tl = match Hashtbl.find_opt d "tail" with
| Some x -> x
| None -> raise (Eval_error
"erlang.OP_BIF_LISTS_REVERSE: cons without :tail") in
rev (mk_cons hd acc) tl
| _ -> raise (Eval_error
"erlang.OP_BIF_LISTS_REVERSE: not a proper list"))
| _ -> raise (Eval_error
"erlang.OP_BIF_LISTS_REVERSE: not a proper list")
in
Sx_vm.push vm (rev (mk_nil ()) v)))
in
[
op 222 "erlang.OP_PATTERN_TUPLE";
op 223 "erlang.OP_PATTERN_LIST";
op 224 "erlang.OP_PATTERN_BINARY";
op 225 "erlang.OP_PERFORM";
op 226 "erlang.OP_HANDLE";
op 227 "erlang.OP_RECEIVE_SCAN";
op 228 "erlang.OP_SPAWN";
op 229 "erlang.OP_SEND";
op_bif_length;
op_bif_hd;
op_bif_tl;
op_bif_element;
op_bif_tuple_size;
op_bif_lists_reverse;
op_bif_is_integer;
op_bif_is_atom;
op_bif_is_list;
op_bif_is_tuple;
]
end
(** Register [erlang] in [Sx_vm_extensions]. Idempotent only by failing
loudly — calling twice raises [Failure]. sx_server calls this once
at startup. *)
let register () = Sx_vm_extensions.register (module M : Sx_vm_extension.EXTENSION)
(** Read the dispatch counter from the live registry state. [None] if
[register] hasn't run. *)
let dispatch_count () =
match Sx_vm_extensions.state_of_extension "erlang" with
| Some (ErlangExtState s) -> Some s.dispatched
| _ -> None

67
hosts/ocaml/lib/extensions/test_ext.ml
View File

@@ -1,67 +0,0 @@
(** {1 [test_ext] — canonical example VM extension}
A minimal extension demonstrating the registration pattern from
[plans/sx-vm-opcode-extension.md]. The opcode IDs (220, 221) sit at
the top of the extension range, well clear of anything a real
language port would claim.
Two operand-less opcodes:
- [test_ext.OP_TEST_PUSH_42] (220) — pushes the integer 42.
- [test_ext.OP_TEST_DOUBLE_TOS] (221) — pops the integer on TOS,
pushes 2× it.
These are the smallest stack manipulations that prove the extension
mechanism wires through end-to-end (registry → dispatch → human-
readable disassembly). Real ports (Erlang Phase 9, future Haskell
perf phases) replace this template with their own opcode set.
Loading: [Test_ext.register ()] adds the extension to
[Sx_vm_extensions]. Run-time binaries that want the test opcodes
available call this once at startup. Unit tests in
[bin/run_tests.ml] do exactly that. *)
open Sx_types
(** Per-instance state for [test_ext]. Counts how many times the
handlers ran — purely so the extension has *some* state, exercising
the [extension_state] machinery. *)
type Sx_vm_extension.extension_state += TestExtState of {
mutable invocations : int;
}
module M : Sx_vm_extension.EXTENSION = struct
let name = "test_ext"
let init () = TestExtState { invocations = 0 }
let opcodes st =
let bump () = match st with
| TestExtState s -> s.invocations <- s.invocations + 1
| _ -> ()
in
[
(220, "test_ext.OP_TEST_PUSH_42",
(fun vm _frame -> bump (); Sx_vm.push vm (Integer 42)));
(221, "test_ext.OP_TEST_DOUBLE_TOS",
(fun vm _frame ->
bump ();
let v = Sx_vm.pop vm in
match v with
| Integer n -> Sx_vm.push vm (Integer (n * 2))
| _ -> raise (Eval_error
"test_ext.OP_TEST_DOUBLE_TOS: TOS is not an integer")));
]
end
(** Register [test_ext] in [Sx_vm_extensions]. Idempotent only by
failing loudly — calling twice raises [Failure]. Binaries call this
once at startup; tests may [_reset_for_tests] then re-register. *)
let register () = Sx_vm_extensions.register (module M : Sx_vm_extension.EXTENSION)
(** Read the invocation counter from the live registry state. Returns
[None] if [register] hasn't been called yet. *)
let invocation_count () =
match Sx_vm_extensions.state_of_extension "test_ext" with
| Some (TestExtState s) -> Some s.invocations
| _ -> None

142
hosts/ocaml/lib/sx_cbor.ml
View File

@@ -1,142 +0,0 @@
(** dag-cbor encode / decode — pure OCaml, WASM-safe.
RFC 8949 deterministic subset as constrained by IPLD dag-cbor
(RFC 8742): unsigned/negative ints, text strings, arrays, maps
with keys sorted by **length-then-bytewise**, bool, null, and
tag 42 (CID link, decode-side passthrough). Floats are not
supported (no fed-sx shape needs them yet) — encoding a [Number]
or decoding a float head raises. Reference: RFC 8949 §3, §4.2. *)
open Sx_types
exception Cbor_error of string
(* ---- Encoder ---- *)
let write_head buf major v =
let m = major lsl 5 in
if v < 24 then
Buffer.add_char buf (Char.chr (m lor v))
else if v < 0x100 then begin
Buffer.add_char buf (Char.chr (m lor 24));
Buffer.add_char buf (Char.chr v)
end else if v < 0x10000 then begin
Buffer.add_char buf (Char.chr (m lor 25));
Buffer.add_char buf (Char.chr ((v lsr 8) land 0xFF));
Buffer.add_char buf (Char.chr (v land 0xFF))
end else if v < 0x100000000 then begin
Buffer.add_char buf (Char.chr (m lor 26));
for i = 3 downto 0 do
Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
done
end else begin
Buffer.add_char buf (Char.chr (m lor 27));
for i = 7 downto 0 do
Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
done
end
(* dag-cbor map key order: shorter key first, then bytewise. *)
let key_order a b =
let la = String.length a and lb = String.length b in
if la <> lb then compare la lb else compare a b
let rec encode_into buf (v : value) : unit =
match v with
| Integer n ->
if n >= 0 then write_head buf 0 n
else write_head buf 1 (-1 - n)
| String s ->
write_head buf 3 (String.length s);
Buffer.add_string buf s
| Symbol s | Keyword s ->
write_head buf 3 (String.length s);
Buffer.add_string buf s
| Bool false -> Buffer.add_char buf '\xf4'
| Bool true -> Buffer.add_char buf '\xf5'
| Nil -> Buffer.add_char buf '\xf6'
| List items ->
write_head buf 4 (List.length items);
List.iter (encode_into buf) items
| Dict d ->
let keys = Hashtbl.fold (fun k _ acc -> k :: acc) d [] in
let keys = List.sort_uniq key_order keys in
write_head buf 5 (List.length keys);
List.iter (fun k ->
write_head buf 3 (String.length k);
Buffer.add_string buf k;
encode_into buf (Hashtbl.find d k)) keys
| Number _ ->
raise (Cbor_error "cbor-encode: floats unsupported (dag-cbor subset)")
| _ ->
raise (Cbor_error
("cbor-encode: unencodable value " ^ type_of v))
let encode (v : value) : string =
let buf = Buffer.create 64 in
encode_into buf v;
Buffer.contents buf
(* ---- Decoder ---- *)
let decode (s : string) : value =
let pos = ref 0 in
let len = String.length s in
let byte () =
if !pos >= len then raise (Cbor_error "cbor-decode: truncated");
let c = Char.code s.[!pos] in incr pos; c
in
let read_uint ai =
if ai < 24 then ai
else if ai = 24 then byte ()
else if ai = 25 then let a = byte () in let b = byte () in (a lsl 8) lor b
else if ai = 26 then begin
let v = ref 0 in
for _ = 0 to 3 do v := (!v lsl 8) lor byte () done; !v
end else if ai = 27 then begin
let v = ref 0 in
for _ = 0 to 7 do v := (!v lsl 8) lor byte () done; !v
end else raise (Cbor_error "cbor-decode: bad additional info")
in
let read_bytes n =
if !pos + n > len then raise (Cbor_error "cbor-decode: truncated");
let r = String.sub s !pos n in pos := !pos + n; r
in
let rec item () =
let b = byte () in
let major = b lsr 5 and ai = b land 0x1f in
match major with
| 0 -> Integer (read_uint ai)
| 1 -> Integer (-1 - read_uint ai)
| 2 -> String (read_bytes (read_uint ai))
| 3 -> String (read_bytes (read_uint ai))
| 4 ->
let n = read_uint ai in
List (List.init n (fun _ -> item ()))
| 5 ->
let n = read_uint ai in
let d = make_dict () in
for _ = 1 to n do
let k = match item () with
| String k -> k
| _ -> raise (Cbor_error "cbor-decode: non-string map key")
in
Hashtbl.replace d k (item ())
done;
Dict d
| 6 ->
(* Tag: tag-42 CID link → pass the inner item through. *)
ignore (read_uint ai); item ()
| 7 ->
(match ai with
| 20 -> Bool false
| 21 -> Bool true
| 22 -> Nil
| 23 -> Nil
| _ ->
raise (Cbor_error
"cbor-decode: floats/simple unsupported (dag-cbor subset)"))
| _ -> raise (Cbor_error "cbor-decode: bad major type")
in
let v = item () in
v

66
hosts/ocaml/lib/sx_cid.ml
View File

@@ -1,66 +0,0 @@
(** CIDv1 computation — pure OCaml, WASM-safe.
Multihash + CIDv1 + multibase base32-lower (RFC 4648, no pad,
multibase prefix 'b'). Codecs: dag-cbor 0x71, raw 0x55. Hash
codes: sha2-256 0x12, sha3-256 0x16. Reference: the multiformats
specs (unsigned-varint, multihash, cid, multibase). No deps. *)
open Sx_types
(* Unsigned LEB128 (multiformats unsigned-varint). *)
let varint (n : int) : string =
let buf = Buffer.create 4 in
let n = ref n in
let cont = ref true in
while !cont do
let b = !n land 0x7f in
n := !n lsr 7;
if !n = 0 then (Buffer.add_char buf (Char.chr b); cont := false)
else Buffer.add_char buf (Char.chr (b lor 0x80))
done;
Buffer.contents buf
(* RFC 4648 base32 lowercase, no padding. *)
let b32_alpha = "abcdefghijklmnopqrstuvwxyz234567"
let base32_lower (s : string) : string =
let buf = Buffer.create ((String.length s * 8 + 4) / 5) in
let acc = ref 0 and bits = ref 0 in
String.iter (fun c ->
acc := (!acc lsl 8) lor (Char.code c);
bits := !bits + 8;
while !bits >= 5 do
bits := !bits - 5;
Buffer.add_char buf b32_alpha.[(!acc lsr !bits) land 0x1f]
done) s;
if !bits > 0 then
Buffer.add_char buf b32_alpha.[(!acc lsl (5 - !bits)) land 0x1f];
Buffer.contents buf
(* "abef" -> the 2 raw bytes. *)
let unhex (h : string) : string =
let n = String.length h / 2 in
let b = Bytes.create n in
for i = 0 to n - 1 do
Bytes.set b i
(Char.chr (int_of_string ("0x" ^ String.sub h (2 * i) 2)))
done;
Bytes.unsafe_to_string b
(* multihash = varint(code) || varint(len) || digest *)
let multihash (code : int) (digest : string) : string =
varint code ^ varint (String.length digest) ^ digest
(* CIDv1 = 0x01 || varint(codec) || multihash ; multibase 'b' base32. *)
let cidv1 (codec : int) (mh : string) : string =
"b" ^ base32_lower ("\x01" ^ varint codec ^ mh)
let codec_dag_cbor = 0x71
let mh_sha2_256 = 0x12
(* Canonicalize an SX value: dag-cbor encode -> sha2-256 ->
multihash -> CIDv1 (dag-cbor codec). *)
let cid_from_sx (v : value) : string =
let cbor = Sx_cbor.encode v in
let digest = unhex (Sx_sha2.sha256_hex cbor) in
cidv1 codec_dag_cbor (multihash mh_sha2_256 digest)

25
hosts/ocaml/lib/sx_compiler.ml
View File

@@ -200,30 +200,7 @@ and compile_qq_list em items scope =
(* compile-call *)
and compile_call em head args scope tail_p =
(let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in
(* Specialized opcode for hot 2-arg / 1-arg primitives. *)
let specialized_op = (match name, argc with
| String "+", Number 2.0 -> Some 160
| String "-", Number 2.0 -> Some 161
| String "*", Number 2.0 -> Some 162
| String "/", Number 2.0 -> Some 163
| String "=", Number 2.0 -> Some 164
| String "<", Number 2.0 -> Some 165
| String ">", Number 2.0 -> Some 166
| String "cons", Number 2.0 -> Some 172
| String "not", Number 1.0 -> Some 167
| String "len", Number 1.0 -> Some 168
| String "first", Number 1.0 -> Some 169
| String "rest", Number 1.0 -> Some 170
| _ -> None) in
(let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in
(match specialized_op with
| Some op -> emit_op em (Number (float_of_int op))
| None ->
let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in
let () = ignore ((emit_op (em) ((Number 52.0)))) in
let () = ignore ((emit_u16 (em) (name_idx))) in
emit_byte (em) (argc)))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args))))))))))
(let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) (argc)))))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args))))))))))
(* compile *)
and compile expr =

289
hosts/ocaml/lib/sx_ed25519.ml
View File

@@ -1,289 +0,0 @@
(** Ed25519 signature verification — pure OCaml, WASM-safe.
RFC 8032 §5.1.7 cofactorless verify over edwards25519. Includes a
minimal arbitrary-precision unsigned bignum (no Zarith / no deps)
and twisted-Edwards extended-coordinate point arithmetic. Verify
is total: malformed inputs return [false], never raise. SHA-512
is reused from {!Sx_sha2}. Reference: RFC 8032, RFC 7748. *)
(* ---- Minimal bignum: int array, little-endian, base 2^26. ---- *)
let bits = 26
let base = 1 lsl bits
let mask = base - 1
type bn = int array (* normalized: no high zero limbs, length >= 1 *)
let norm (a : bn) : bn =
let n = ref (Array.length a) in
while !n > 1 && a.(!n - 1) = 0 do decr n done;
if !n = Array.length a then a else Array.sub a 0 !n
let bzero : bn = [| 0 |]
let of_int n : bn =
if n = 0 then bzero
else begin
let r = ref [] and n = ref n in
while !n > 0 do r := (!n land mask) :: !r; n := !n lsr bits done;
norm (Array.of_list (List.rev !r))
end
let is_zero (a : bn) = Array.length a = 1 && a.(0) = 0
let cmp (a : bn) (b : bn) : int =
let a = norm a and b = norm b in
let la = Array.length a and lb = Array.length b in
if la <> lb then compare la lb
else begin
let r = ref 0 and i = ref (la - 1) in
while !r = 0 && !i >= 0 do
if a.(!i) <> b.(!i) then r := compare a.(!i) b.(!i);
decr i
done; !r
end
let add (a : bn) (b : bn) : bn =
let la = Array.length a and lb = Array.length b in
let n = (max la lb) + 1 in
let r = Array.make n 0 in
let carry = ref 0 in
for i = 0 to n - 1 do
let s = !carry
+ (if i < la then a.(i) else 0)
+ (if i < lb then b.(i) else 0) in
r.(i) <- s land mask; carry := s lsr bits
done;
norm r
(* a - b, requires a >= b *)
let sub (a : bn) (b : bn) : bn =
let la = Array.length a and lb = Array.length b in
let r = Array.make la 0 in
let borrow = ref 0 in
for i = 0 to la - 1 do
let s = a.(i) - !borrow - (if i < lb then b.(i) else 0) in
if s < 0 then (r.(i) <- s + base; borrow := 1)
else (r.(i) <- s; borrow := 0)
done;
norm r
let mul (a : bn) (b : bn) : bn =
let la = Array.length a and lb = Array.length b in
let r = Array.make (la + lb) 0 in
for i = 0 to la - 1 do
let carry = ref 0 in
for j = 0 to lb - 1 do
let s = r.(i + j) + a.(i) * b.(j) + !carry in
r.(i + j) <- s land mask; carry := s lsr bits
done;
r.(i + lb) <- r.(i + lb) + !carry
done;
norm r
let numbits (a : bn) : int =
let a = norm a in
let hi = Array.length a - 1 in
if hi = 0 && a.(0) = 0 then 0
else begin
let b = ref 0 and v = ref a.(hi) in
while !v > 0 do incr b; v := !v lsr 1 done;
hi * bits + !b
end
let bit (a : bn) (i : int) : int =
let limb = i / bits and off = i mod bits in
if limb >= Array.length a then 0 else (a.(limb) lsr off) land 1
(* r = a mod m (m > 0), binary long division. *)
let bn_mod (a : bn) (m : bn) : bn =
if cmp a m < 0 then norm a
else begin
let r = ref bzero in
for i = numbits a - 1 downto 0 do
(* r = r*2 + bit *)
r := add !r !r;
if bit a i = 1 then r := add !r [| 1 |];
if cmp !r m >= 0 then r := sub !r m
done;
!r
end
let div_small (a : bn) (d : int) : bn =
let la = Array.length a in
let q = Array.make la 0 in
let rem = ref 0 in
for i = la - 1 downto 0 do
let cur = (!rem lsl bits) lor a.(i) in
q.(i) <- cur / d; rem := cur mod d
done;
norm q
let powmod (b0 : bn) (e : bn) (m : bn) : bn =
let result = ref [| 1 |] and b = ref (bn_mod b0 m) in
let nb = numbits e in
for i = 0 to nb - 1 do
if bit e i = 1 then result := bn_mod (mul !result !b) m;
b := bn_mod (mul !b !b) m
done;
!result
let of_bytes_le (s : string) : bn =
let acc = ref bzero in
for i = String.length s - 1 downto 0 do
acc := add (mul !acc (of_int 256)) (of_int (Char.code s.[i]))
done;
!acc
let to_bytes_le (a : bn) (n : int) : string =
let b = Bytes.make n '\000' in
let cur = ref (norm a) in
for i = 0 to n - 1 do
let q = div_small !cur 256 in
let r =
let qm = mul q (of_int 256) in
let d = sub !cur qm in
if is_zero d then 0 else d.(0)
in
Bytes.set b i (Char.chr r);
cur := q
done;
Bytes.unsafe_to_string b
(* ---- Field GF(p), p = 2^255 - 19 ---- *)
let p =
let twop255 = Array.make 11 0 in (* 11*26 = 286 > 255 *)
let limb = 255 / bits and off = 255 mod bits in
twop255.(limb) <- 1 lsl off;
sub (norm twop255) (of_int 19)
let fmod a = bn_mod a p
let fadd a b = fmod (add a b)
let fsub a b = fmod (add a (sub p (fmod b)))
let fmul a b = fmod (mul a b)
let fpow a e = powmod a e p
let finv a = fpow a (sub p (of_int 2)) (* Fermat: a^(p-2) *)
(* group order L = 2^252 + 27742317777372353535851937790883648493 *)
let ell =
of_bytes_le
"\xed\xd3\xf5\x5c\x1a\x63\x12\x58\xd6\x9c\xf7\xa2\xde\xf9\xde\x14\
\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10"
(* d = -121665 / 121666 mod p *)
let dconst =
let inv666 = finv (of_int 121666) in
fmod (mul (fsub (of_int 0) (of_int 121665)) inv666)
(* sqrt(-1) = 2^((p-1)/4) mod p *)
let sqrtm1 = fpow (of_int 2) (div_small (sub p (of_int 1)) 4)
(* ---- edwards25519 points in extended coords (X,Y,Z,T) ---- *)
type pt = { x : bn; y : bn; z : bn; t : bn }
let identity = { x = bzero; y = of_int 1; z = of_int 1; t = bzero }
(* add-2008-hwcd-3, complete for a = -1 on ed25519 *)
let padd (p1 : pt) (p2 : pt) : pt =
let a = fmul (fsub p1.y p1.x) (fsub p2.y p2.x) in
let b = fmul (fadd p1.y p1.x) (fadd p2.y p2.x) in
let c = fmul (fmul p1.t (fmul (of_int 2) dconst)) p2.t in
let dd = fmul (fmul p1.z (of_int 2)) p2.z in
let e = fsub b a in
let f = fsub dd c in
let g = fadd dd c in
let h = fadd b a in
{ x = fmul e f; y = fmul g h; t = fmul e h; z = fmul f g }
let scalar_mul (n : bn) (q : pt) : pt =
let r = ref identity in
for i = numbits n - 1 downto 0 do
r := padd !r !r;
if bit n i = 1 then r := padd !r q
done;
!r
let pnegate (q : pt) : pt =
{ q with x = fsub (of_int 0) q.x; t = fsub (of_int 0) q.t }
(* Decompress a 32-byte little-endian point encoding. *)
let decompress (s : string) : pt option =
if String.length s <> 32 then None
else begin
let sign = (Char.code s.[31] lsr 7) land 1 in
let s' = Bytes.of_string s in
Bytes.set s' 31 (Char.chr (Char.code s.[31] land 0x7f));
let y = of_bytes_le (Bytes.unsafe_to_string s') in
if cmp y p >= 0 then None
else begin
let y2 = fmul y y in
let u = fsub y2 (of_int 1) in
let v = fadd (fmul dconst y2) (of_int 1) in
(* x = u v^3 (u v^7)^((p-5)/8) *)
let v3 = fmul (fmul v v) v in
let v7 = fmul (fmul v3 v3) v in
let exp = div_small (sub p (of_int 5)) 8 in
let x0 = fmul (fmul u v3) (fpow (fmul u v7) exp) in
let vx2 = fmul v (fmul x0 x0) in
let x =
if cmp vx2 u = 0 then Some x0
else if cmp vx2 (fsub (of_int 0) u) = 0 then Some (fmul x0 sqrtm1)
else None
in
match x with
| None -> None
| Some x ->
if is_zero x && sign = 1 then None
else begin
let x = if (bit x 0) <> sign then fsub (of_int 0) x else x in
Some { x; y; z = of_int 1; t = fmul x y }
end
end
end
(* Encode a point to 32-byte little-endian (y with x-parity bit). *)
let encode (q : pt) : string =
let zi = finv q.z in
let x = fmul q.x zi and y = fmul q.y zi in
let b = Bytes.of_string (to_bytes_le y 32) in
let last = Char.code (Bytes.get b 31) lor ((bit x 0) lsl 7) in
Bytes.set b 31 (Char.chr last);
Bytes.unsafe_to_string b
(* base point: y = 4/5 mod p, x even (sign 0). *)
let base_point =
let by = fmul (of_int 4) (finv (of_int 5)) in
match decompress (to_bytes_le by 32) with
| Some pt -> pt
| None -> failwith "ed25519: base point decompress failed"
let unhex (h : string) : string =
let n = String.length h / 2 in
let b = Bytes.create n in
for i = 0 to n - 1 do
Bytes.set b i
(Char.chr (int_of_string ("0x" ^ String.sub h (2 * i) 2)))
done;
Bytes.unsafe_to_string b
let sha512_bytes s = unhex (Sx_sha2.sha512_hex s)
(* RFC 8032 §5.1.7 cofactorless: encode([S]B - [k]A) == R. *)
let verify ~pubkey ~msg ~sig_ : bool =
if String.length pubkey <> 32 || String.length sig_ <> 64 then false
else
let rb = String.sub sig_ 0 32 in
let sb = String.sub sig_ 32 32 in
let s = of_bytes_le sb in
if cmp s ell >= 0 then false
else
match decompress pubkey with
| None -> false
| Some a ->
let h = sha512_bytes (rb ^ pubkey ^ msg) in
let k = bn_mod (of_bytes_le h) ell in
let sb_pt = scalar_mul s base_point in
let ka = scalar_mul k a in
let chk = padd sb_pt (pnegate ka) in
(try encode chk = rb with _ -> false)

62
hosts/ocaml/lib/sx_parser.ml
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;

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

File diff suppressed because it is too large Load Diff

369
hosts/ocaml/lib/sx_ref.ml
View File

File diff suppressed because one or more lines are too long

220
hosts/ocaml/lib/sx_rsa.ml
View File

@@ -1,220 +0,0 @@
(** RSASSA-PKCS1-v1_5 verification with SHA-256 — pure OCaml,
WASM-safe. Self-contained minimal bignum (modexp only), a tiny
DER reader for SubjectPublicKeyInfo, and the fixed SHA-256
DigestInfo prefix. Verify only on public data — constant time
not required. Reference: RFC 8017 §8.2.2, §9.2. No deps. *)
(* ---- Minimal unsigned bignum: int array, little-endian, base 2^26 ---- *)
let bits = 26
let base = 1 lsl bits
let mask = base - 1
type bn = int array
let norm a =
let n = ref (Array.length a) in
while !n > 1 && a.(!n - 1) = 0 do decr n done;
if !n = Array.length a then a else Array.sub a 0 !n
let bzero : bn = [| 0 |]
let is_zero a = Array.length a = 1 && a.(0) = 0
let cmp a b =
let a = norm a and b = norm b in
let la = Array.length a and lb = Array.length b in
if la <> lb then compare la lb
else begin
let r = ref 0 and i = ref (la - 1) in
while !r = 0 && !i >= 0 do
if a.(!i) <> b.(!i) then r := compare a.(!i) b.(!i);
decr i
done; !r
end
let add a b =
let la = Array.length a and lb = Array.length b in
let n = (max la lb) + 1 in
let r = Array.make n 0 and carry = ref 0 in
for i = 0 to n - 1 do
let s = !carry + (if i < la then a.(i) else 0)
+ (if i < lb then b.(i) else 0) in
r.(i) <- s land mask; carry := s lsr bits
done;
norm r
let sub a b = (* requires a >= b *)
let la = Array.length a and lb = Array.length b in
let r = Array.make la 0 and borrow = ref 0 in
for i = 0 to la - 1 do
let s = a.(i) - !borrow - (if i < lb then b.(i) else 0) in
if s < 0 then (r.(i) <- s + base; borrow := 1)
else (r.(i) <- s; borrow := 0)
done;
norm r
let mul a b =
let la = Array.length a and lb = Array.length b in
let r = Array.make (la + lb) 0 in
for i = 0 to la - 1 do
let carry = ref 0 in
for j = 0 to lb - 1 do
let s = r.(i + j) + a.(i) * b.(j) + !carry in
r.(i + j) <- s land mask; carry := s lsr bits
done;
r.(i + lb) <- r.(i + lb) + !carry
done;
norm r
let numbits a =
let a = norm a in
let hi = Array.length a - 1 in
if hi = 0 && a.(0) = 0 then 0
else begin
let b = ref 0 and v = ref a.(hi) in
while !v > 0 do incr b; v := !v lsr 1 done;
hi * bits + !b
end
let bit a i =
let limb = i / bits and off = i mod bits in
if limb >= Array.length a then 0 else (a.(limb) lsr off) land 1
let bn_mod a m = (* binary long division, m > 0 *)
if cmp a m < 0 then norm a
else begin
let r = ref bzero in
for i = numbits a - 1 downto 0 do
r := add !r !r;
if bit a i = 1 then r := add !r [| 1 |];
if cmp !r m >= 0 then r := sub !r m
done;
!r
end
let powmod b0 e m =
let result = ref [| 1 |] and b = ref (bn_mod b0 m) in
for i = 0 to numbits e - 1 do
if bit e i = 1 then result := bn_mod (mul !result !b) m;
b := bn_mod (mul !b !b) m
done;
!result
let of_bytes_be (s : string) : bn =
let acc = ref bzero in
for i = 0 to String.length s - 1 do
acc := add (mul !acc [| 256 |]) [| Char.code s.[i] |]
done;
!acc
let div_small a d =
let la = Array.length a in
let q = Array.make la 0 and rem = ref 0 in
for i = la - 1 downto 0 do
let cur = (!rem lsl bits) lor a.(i) in
q.(i) <- cur / d; rem := cur mod d
done;
norm q
let to_bytes_be (a : bn) (n : int) : string =
let b = Bytes.make n '\000' in
let cur = ref (norm a) in
for i = n - 1 downto 0 do
let q = div_small !cur 256 in
let r =
let d = sub !cur (mul q [| 256 |]) in
if is_zero d then 0 else d.(0)
in
Bytes.set b i (Char.chr r);
cur := q
done;
Bytes.unsafe_to_string b
(* ---- Minimal DER reader (for SubjectPublicKeyInfo) ---- *)
exception Der of string
(* Returns (tag, content_start, content_len, next). *)
let der_tlv s pos =
if pos + 2 > String.length s then raise (Der "short");
let tag = Char.code s.[pos] in
let l0 = Char.code s.[pos + 1] in
let len, hdr =
if l0 < 0x80 then l0, 2
else begin
let nb = l0 land 0x7f in
if pos + 2 + nb > String.length s then raise (Der "short len");
let v = ref 0 in
for i = 0 to nb - 1 do
v := (!v lsl 8) lor Char.code s.[pos + 2 + i]
done;
!v, 2 + nb
end
in
(tag, pos + hdr, len, pos + hdr + len)
(* SPKI DER -> (n, e) as bignums. *)
let parse_spki (der : string) : bn * bn =
let tag, c, _l, _ = der_tlv der 0 in
if tag <> 0x30 then raise (Der "spki: outer not SEQUENCE");
(* AlgorithmIdentifier SEQUENCE — skip. *)
let _, _, _, after_alg = der_tlv der c in
(* BIT STRING. *)
let bt, bc, bl, _ = der_tlv der after_alg in
if bt <> 0x03 then raise (Der "spki: expected BIT STRING");
(* First content byte = unused bits (must be 0). *)
let rpk_start = bc + 1 in
ignore bl;
let st, sc, _, _ = der_tlv der rpk_start in
if st <> 0x30 then raise (Der "spki: RSAPublicKey not SEQUENCE");
let nt, nc, nl, after_n = der_tlv der sc in
if nt <> 0x02 then raise (Der "spki: modulus not INTEGER");
let et, ec, el, _ = der_tlv der after_n in
if et <> 0x02 then raise (Der "spki: exponent not INTEGER");
let n = of_bytes_be (String.sub der nc nl) in
let e = of_bytes_be (String.sub der ec el) in
(n, e)
(* SHA-256 DigestInfo DER prefix (RFC 8017 §9.2 note 1). *)
let sha256_digestinfo_prefix =
"\x30\x31\x30\x0d\x06\x09\x60\x86\x48\x01\x65\x03\x04\x02\x01\x05\x00\x04\x20"
let unhex h =
let n = String.length h / 2 in
let b = Bytes.create n in
for i = 0 to n - 1 do
Bytes.set b i (Char.chr (int_of_string ("0x" ^ String.sub h (2 * i) 2)))
done;
Bytes.unsafe_to_string b
(* RSASSA-PKCS1-v1_5 verify with SHA-256. Total: any malformed
input yields false (caller wraps, but be defensive here too). *)
let verify ~spki ~msg ~sig_ : bool =
try
let n, e = parse_spki spki in
let k = (numbits n + 7) / 8 in
if String.length sig_ <> k then false
else begin
let s = of_bytes_be sig_ in
if cmp s n >= 0 then false
else begin
let m = powmod s e n in
let em = to_bytes_be m k in
(* EM = 0x00 01 FF..FF 00 || DigestInfo || H *)
let h = unhex (Sx_sha2.sha256_hex msg) in
let t = sha256_digestinfo_prefix ^ h in
let tlen = String.length t in
if k < tlen + 11 then false
else begin
let ok = ref (em.[0] = '\x00' && em.[1] = '\x01') in
let ps_end = k - tlen - 1 in
for i = 2 to ps_end - 1 do
if em.[i] <> '\xff' then ok := false
done;
if em.[ps_end] <> '\x00' then ok := false;
if String.sub em (ps_end + 1) tlen <> t then ok := false;
!ok
end
end
end
with _ -> false

101
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -6,72 +6,11 @@
open Sx_types
(** Fast path equality — same as Sx_primitives.safe_eq for the common cases
that show up in hot dispatch (string vs string, etc). Falls through to
the registered "=" primitive for complex cases. *)
let rec _fast_eq a b =
if a == b then true
else match a, b with
| String x, String y -> x = y
| Integer x, Integer y -> x = y
| Number x, Number y -> x = y
| Integer x, Number y -> float_of_int x = y
| Number x, Integer y -> x = float_of_int y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
| Symbol x, Symbol y -> x = y
| Keyword x, Keyword y -> x = y
| List la, List lb ->
(try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false)
| _ -> false
(** Call a registered primitive by name.
Fast path for hot dispatch primitives ([=], [<], [>], [<=], [>=], [empty?],
[first], [rest], [len]) skips the Hashtbl lookup entirely — these are
called millions of times in the CEK [step_continue]/[step_eval] dispatch. *)
(** Call a registered primitive by name. *)
let prim_call name args =
(* Hot path: most-frequently-called primitives by step_continue dispatch *)
match name, args with
| "=", [a; b] -> Bool (_fast_eq a b)
| "empty?", [List []] -> Bool true
| "empty?", [List _] -> Bool false
| "empty?", [ListRef { contents = [] }] -> Bool true
| "empty?", [ListRef _] -> Bool false
| "empty?", [Nil] -> Bool true
| "first", [List (x :: _)] -> x
| "first", [List []] -> Nil
| "first", [ListRef { contents = (x :: _) }] -> x
| "first", [ListRef _] -> Nil
| "first", [Nil] -> Nil
| "rest", [List (_ :: xs)] -> List xs
| "rest", [List []] -> List []
| "rest", [ListRef { contents = (_ :: xs) }] -> List xs
| "rest", [ListRef _] -> List []
| "rest", [Nil] -> List []
| "len", [List l] -> Integer (List.length l)
| "len", [ListRef r] -> Integer (List.length !r)
| "len", [String s] -> Integer (String.length s)
| "len", [Nil] -> Integer 0
| "<", [Integer x; Integer y] -> Bool (x < y)
| "<", [Number x; Number y] -> Bool (x < y)
| "<", [Integer x; Number y] -> Bool (float_of_int x < y)
| "<", [Number x; Integer y] -> Bool (x < float_of_int y)
| ">", [Integer x; Integer y] -> Bool (x > y)
| ">", [Number x; Number y] -> Bool (x > y)
| ">", [Integer x; Number y] -> Bool (float_of_int x > y)
| ">", [Number x; Integer y] -> Bool (x > float_of_int y)
| "<=", [Integer x; Integer y] -> Bool (x <= y)
| "<=", [Number x; Number y] -> Bool (x <= y)
| "<=", [Integer x; Number y] -> Bool (float_of_int x <= y)
| "<=", [Number x; Integer y] -> Bool (x <= float_of_int y)
| ">=", [Integer x; Integer y] -> Bool (x >= y)
| ">=", [Number x; Number y] -> Bool (x >= y)
| ">=", [Integer x; Number y] -> Bool (float_of_int x >= y)
| ">=", [Number x; Integer y] -> Bool (x >= float_of_int y)
| _ ->
match Hashtbl.find_opt Sx_primitives.primitives name with
| Some f -> f args
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
match Hashtbl.find_opt Sx_primitives.primitives name with
| Some f -> f args
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
(** Convert any SX value to an OCaml string (internal). *)
let value_to_str = function
@@ -107,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
@@ -217,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
@@ -270,17 +206,8 @@ let get_val container key =
| _ -> Nil)
| Dict d, String k -> dict_get d k
| Dict d, Keyword k -> dict_get d k
| AdtValue a, String k | AdtValue a, Keyword k ->
(match k with
| "_adt" -> Bool true
| "_type" -> String a.av_type
| "_ctor" -> String a.av_ctor
| "_fields" -> List (Array.to_list a.av_fields)
| _ -> Nil)
| (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) *)
@@ -454,28 +381,19 @@ 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))
let host_warn msg =
prerr_endline (value_to_str msg);
Nil
let dynamic_wind_call before body after _env =
ignore (sx_call before []);
let result = sx_call body [] in
@@ -611,4 +529,3 @@ let jit_try_call f args =
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel)
| _ -> incr _jit_skip; _jit_skip_sentinel

212
hosts/ocaml/lib/sx_sha2.ml
View File

@@ -1,212 +0,0 @@
(** SHA-2 (SHA-256, SHA-512) — pure OCaml, WASM-safe.
No C stubs, no external deps. Used by the fed-sx host primitives
[crypto-sha256] / [crypto-sha512]. Reference: FIPS 180-4. *)
(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words held in native int,
masked to 32 bits after every arithmetic op. ---- *)
let mask32 = 0xFFFFFFFF
let k256 = [|
0x428a2f98; 0x71374491; 0xb5c0fbcf; 0xe9b5dba5;
0x3956c25b; 0x59f111f1; 0x923f82a4; 0xab1c5ed5;
0xd807aa98; 0x12835b01; 0x243185be; 0x550c7dc3;
0x72be5d74; 0x80deb1fe; 0x9bdc06a7; 0xc19bf174;
0xe49b69c1; 0xefbe4786; 0x0fc19dc6; 0x240ca1cc;
0x2de92c6f; 0x4a7484aa; 0x5cb0a9dc; 0x76f988da;
0x983e5152; 0xa831c66d; 0xb00327c8; 0xbf597fc7;
0xc6e00bf3; 0xd5a79147; 0x06ca6351; 0x14292967;
0x27b70a85; 0x2e1b2138; 0x4d2c6dfc; 0x53380d13;
0x650a7354; 0x766a0abb; 0x81c2c92e; 0x92722c85;
0xa2bfe8a1; 0xa81a664b; 0xc24b8b70; 0xc76c51a3;
0xd192e819; 0xd6990624; 0xf40e3585; 0x106aa070;
0x19a4c116; 0x1e376c08; 0x2748774c; 0x34b0bcb5;
0x391c0cb3; 0x4ed8aa4a; 0x5b9cca4f; 0x682e6ff3;
0x748f82ee; 0x78a5636f; 0x84c87814; 0x8cc70208;
0x90befffa; 0xa4506ceb; 0xbef9a3f7; 0xc67178f2 |]
let rotr32 x n = ((x lsr n) lor (x lsl (32 - n))) land mask32
let sha256_hex (msg : string) : string =
let h = [| 0x6a09e667; 0xbb67ae85; 0x3c6ef372; 0xa54ff53a;
0x510e527f; 0x9b05688c; 0x1f83d9ab; 0x5be0cd19 |] in
let len = String.length msg in
(* Padded length: multiple of 64 bytes. *)
let bitlen = len * 8 in
let padlen =
let r = (len + 1) mod 64 in
if r <= 56 then 56 - r else 120 - r
in
let total = len + 1 + padlen + 8 in
let buf = Bytes.make total '\000' in
Bytes.blit_string msg 0 buf 0 len;
Bytes.set buf len '\x80';
(* 64-bit big-endian bit length (we cap at OCaml int range). *)
for i = 0 to 7 do
Bytes.set buf (total - 1 - i)
(Char.chr ((bitlen lsr (8 * i)) land 0xFF))
done;
let w = Array.make 64 0 in
let nblocks = total / 64 in
for b = 0 to nblocks - 1 do
let base = b * 64 in
for t = 0 to 15 do
let o = base + t * 4 in
w.(t) <-
(Char.code (Bytes.get buf o) lsl 24)
lor (Char.code (Bytes.get buf (o + 1)) lsl 16)
lor (Char.code (Bytes.get buf (o + 2)) lsl 8)
lor (Char.code (Bytes.get buf (o + 3)))
done;
for t = 16 to 63 do
let s0 =
(rotr32 w.(t - 15) 7) lxor (rotr32 w.(t - 15) 18)
lxor (w.(t - 15) lsr 3) in
let s1 =
(rotr32 w.(t - 2) 17) lxor (rotr32 w.(t - 2) 19)
lxor (w.(t - 2) lsr 10) in
w.(t) <- (w.(t - 16) + s0 + w.(t - 7) + s1) land mask32
done;
let a = ref h.(0) and bb = ref h.(1) and c = ref h.(2)
and d = ref h.(3) and e = ref h.(4) and f = ref h.(5)
and g = ref h.(6) and hh = ref h.(7) in
for t = 0 to 63 do
let s1 =
(rotr32 !e 6) lxor (rotr32 !e 11) lxor (rotr32 !e 25) in
let ch = (!e land !f) lxor ((lnot !e land mask32) land !g) in
let t1 = (!hh + s1 + ch + k256.(t) + w.(t)) land mask32 in
let s0 =
(rotr32 !a 2) lxor (rotr32 !a 13) lxor (rotr32 !a 22) in
let maj = (!a land !bb) lxor (!a land !c) lxor (!bb land !c) in
let t2 = (s0 + maj) land mask32 in
hh := !g; g := !f; f := !e;
e := (!d + t1) land mask32;
d := !c; c := !bb; bb := !a;
a := (t1 + t2) land mask32
done;
h.(0) <- (h.(0) + !a) land mask32;
h.(1) <- (h.(1) + !bb) land mask32;
h.(2) <- (h.(2) + !c) land mask32;
h.(3) <- (h.(3) + !d) land mask32;
h.(4) <- (h.(4) + !e) land mask32;
h.(5) <- (h.(5) + !f) land mask32;
h.(6) <- (h.(6) + !g) land mask32;
h.(7) <- (h.(7) + !hh) land mask32
done;
let out = Buffer.create 64 in
Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08x" x)) h;
Buffer.contents out
(* ---- SHA-512 (FIPS 180-4 §6.4). 64-bit words via Int64.
128-bit length append; we only support messages whose bit length
fits in 64 bits (high word is always zero). ---- *)
let k512 = [|
0x428a2f98d728ae22L; 0x7137449123ef65cdL; 0xb5c0fbcfec4d3b2fL;
0xe9b5dba58189dbbcL; 0x3956c25bf348b538L; 0x59f111f1b605d019L;
0x923f82a4af194f9bL; 0xab1c5ed5da6d8118L; 0xd807aa98a3030242L;
0x12835b0145706fbeL; 0x243185be4ee4b28cL; 0x550c7dc3d5ffb4e2L;
0x72be5d74f27b896fL; 0x80deb1fe3b1696b1L; 0x9bdc06a725c71235L;
0xc19bf174cf692694L; 0xe49b69c19ef14ad2L; 0xefbe4786384f25e3L;
0x0fc19dc68b8cd5b5L; 0x240ca1cc77ac9c65L; 0x2de92c6f592b0275L;
0x4a7484aa6ea6e483L; 0x5cb0a9dcbd41fbd4L; 0x76f988da831153b5L;
0x983e5152ee66dfabL; 0xa831c66d2db43210L; 0xb00327c898fb213fL;
0xbf597fc7beef0ee4L; 0xc6e00bf33da88fc2L; 0xd5a79147930aa725L;
0x06ca6351e003826fL; 0x142929670a0e6e70L; 0x27b70a8546d22ffcL;
0x2e1b21385c26c926L; 0x4d2c6dfc5ac42aedL; 0x53380d139d95b3dfL;
0x650a73548baf63deL; 0x766a0abb3c77b2a8L; 0x81c2c92e47edaee6L;
0x92722c851482353bL; 0xa2bfe8a14cf10364L; 0xa81a664bbc423001L;
0xc24b8b70d0f89791L; 0xc76c51a30654be30L; 0xd192e819d6ef5218L;
0xd69906245565a910L; 0xf40e35855771202aL; 0x106aa07032bbd1b8L;
0x19a4c116b8d2d0c8L; 0x1e376c085141ab53L; 0x2748774cdf8eeb99L;
0x34b0bcb5e19b48a8L; 0x391c0cb3c5c95a63L; 0x4ed8aa4ae3418acbL;
0x5b9cca4f7763e373L; 0x682e6ff3d6b2b8a3L; 0x748f82ee5defb2fcL;
0x78a5636f43172f60L; 0x84c87814a1f0ab72L; 0x8cc702081a6439ecL;
0x90befffa23631e28L; 0xa4506cebde82bde9L; 0xbef9a3f7b2c67915L;
0xc67178f2e372532bL; 0xca273eceea26619cL; 0xd186b8c721c0c207L;
0xeada7dd6cde0eb1eL; 0xf57d4f7fee6ed178L; 0x06f067aa72176fbaL;
0x0a637dc5a2c898a6L; 0x113f9804bef90daeL; 0x1b710b35131c471bL;
0x28db77f523047d84L; 0x32caab7b40c72493L; 0x3c9ebe0a15c9bebcL;
0x431d67c49c100d4cL; 0x4cc5d4becb3e42b6L; 0x597f299cfc657e2aL;
0x5fcb6fab3ad6faecL; 0x6c44198c4a475817L |]
let ( &: ) = Int64.logand
let ( |: ) = Int64.logor
let ( ^: ) = Int64.logxor
let ( +: ) = Int64.add
let lnot64 = Int64.lognot
let rotr64 x n =
(Int64.shift_right_logical x n) |: (Int64.shift_left x (64 - n))
let sha512_hex (msg : string) : string =
let h = [| 0x6a09e667f3bcc908L; 0xbb67ae8584caa73bL;
0x3c6ef372fe94f82bL; 0xa54ff53a5f1d36f1L;
0x510e527fade682d1L; 0x9b05688c2b3e6c1fL;
0x1f83d9abfb41bd6bL; 0x5be0cd19137e2179L |] in
let len = String.length msg in
let bitlen = len * 8 in
(* Pad to a multiple of 128 bytes; 16-byte big-endian length. *)
let padlen =
let r = (len + 1) mod 128 in
if r <= 112 then 112 - r else 240 - r
in
let total = len + 1 + padlen + 16 in
let buf = Bytes.make total '\000' in
Bytes.blit_string msg 0 buf 0 len;
Bytes.set buf len '\x80';
for i = 0 to 7 do
Bytes.set buf (total - 1 - i)
(Char.chr ((bitlen lsr (8 * i)) land 0xFF))
done;
let w = Array.make 80 0L in
let nblocks = total / 128 in
for b = 0 to nblocks - 1 do
let base = b * 128 in
for t = 0 to 15 do
let o = base + t * 8 in
let v = ref 0L in
for j = 0 to 7 do
v := Int64.logor (Int64.shift_left !v 8)
(Int64.of_int (Char.code (Bytes.get buf (o + j))))
done;
w.(t) <- !v
done;
for t = 16 to 79 do
let s0 =
(rotr64 w.(t - 15) 1) ^: (rotr64 w.(t - 15) 8)
^: (Int64.shift_right_logical w.(t - 15) 7) in
let s1 =
(rotr64 w.(t - 2) 19) ^: (rotr64 w.(t - 2) 61)
^: (Int64.shift_right_logical w.(t - 2) 6) in
w.(t) <- w.(t - 16) +: s0 +: w.(t - 7) +: s1
done;
let a = ref h.(0) and bb = ref h.(1) and c = ref h.(2)
and d = ref h.(3) and e = ref h.(4) and f = ref h.(5)
and g = ref h.(6) and hh = ref h.(7) in
for t = 0 to 79 do
let s1 = (rotr64 !e 14) ^: (rotr64 !e 18) ^: (rotr64 !e 41) in
let ch = (!e &: !f) ^: ((lnot64 !e) &: !g) in
let t1 = !hh +: s1 +: ch +: k512.(t) +: w.(t) in
let s0 = (rotr64 !a 28) ^: (rotr64 !a 34) ^: (rotr64 !a 39) in
let maj = (!a &: !bb) ^: (!a &: !c) ^: (!bb &: !c) in
let t2 = s0 +: maj in
hh := !g; g := !f; f := !e;
e := !d +: t1;
d := !c; c := !bb; bb := !a;
a := t1 +: t2
done;
h.(0) <- h.(0) +: !a;
h.(1) <- h.(1) +: !bb;
h.(2) <- h.(2) +: !c;
h.(3) <- h.(3) +: !d;
h.(4) <- h.(4) +: !e;
h.(5) <- h.(5) +: !f;
h.(6) <- h.(6) +: !g;
h.(7) <- h.(7) +: !hh
done;
let out = Buffer.create 128 in
Array.iter
(fun x -> Buffer.add_string out (Printf.sprintf "%016Lx" x)) h;
Buffer.contents out

107
hosts/ocaml/lib/sx_sha3.ml
View File

@@ -1,107 +0,0 @@
(** SHA-3 (SHA3-256) — pure OCaml, WASM-safe.
Keccak-f[1600] permutation + SHA-3 multi-rate padding (domain byte
0x06, NOT the legacy Keccak 0x01). Reference: FIPS 202. No deps. *)
let ( ^: ) = Int64.logxor
let ( &: ) = Int64.logand
let lnot64 = Int64.lognot
let rotl64 x n =
if n = 0 then x
else
Int64.logor (Int64.shift_left x n) (Int64.shift_right_logical x (64 - n))
(* FIPS 202 Table 2 — ρ rotation offsets, indexed lane = x + 5*y. *)
let rho = [|
0; 1; 62; 28; 27;
36; 44; 6; 55; 20;
3; 10; 43; 25; 39;
41; 45; 15; 21; 8;
18; 2; 61; 56; 14 |]
(* FIPS 202 §3.2.5 — round constants RC[0..23] for ι. *)
let rc = [|
0x0000000000000001L; 0x0000000000008082L; 0x800000000000808aL;
0x8000000080008000L; 0x000000000000808bL; 0x0000000080000001L;
0x8000000080008081L; 0x8000000000008009L; 0x000000000000008aL;
0x0000000000000088L; 0x0000000080008009L; 0x000000008000000aL;
0x000000008000808bL; 0x800000000000008bL; 0x8000000000008089L;
0x8000000000008003L; 0x8000000000008002L; 0x8000000000000080L;
0x000000000000800aL; 0x800000008000000aL; 0x8000000080008081L;
0x8000000000008080L; 0x0000000080000001L; 0x8000000080008008L |]
let keccak_f (a : int64 array) : unit =
let c = Array.make 5 0L and d = Array.make 5 0L in
let b = Array.make 25 0L in
for round = 0 to 23 do
(* θ *)
for x = 0 to 4 do
c.(x) <- a.(x) ^: a.(x + 5) ^: a.(x + 10)
^: a.(x + 15) ^: a.(x + 20)
done;
for x = 0 to 4 do
d.(x) <- c.((x + 4) mod 5) ^: (rotl64 c.((x + 1) mod 5) 1)
done;
for x = 0 to 4 do
for y = 0 to 4 do
a.(x + 5 * y) <- a.(x + 5 * y) ^: d.(x)
done
done;
(* ρ and π: B[y, 2x+3y] = rotl(A[x,y], rho[x,y]) *)
for x = 0 to 4 do
for y = 0 to 4 do
let nx = y and ny = (2 * x + 3 * y) mod 5 in
b.(nx + 5 * ny) <- rotl64 a.(x + 5 * y) rho.(x + 5 * y)
done
done;
(* χ *)
for y = 0 to 4 do
for x = 0 to 4 do
a.(x + 5 * y) <-
b.(x + 5 * y)
^: ((lnot64 b.((x + 1) mod 5 + 5 * y))
&: b.((x + 2) mod 5 + 5 * y))
done
done;
(* ι *)
a.(0) <- a.(0) ^: rc.(round)
done
let sha3_256_hex (msg : string) : string =
let rate = 136 (* bytes: (1600 - 2*256) / 8 *) in
let len = String.length msg in
(* pad10*1 with SHA-3 domain byte 0x06; last byte ORed with 0x80. *)
let q = rate - (len mod rate) in
let padded = Bytes.make (len + q) '\000' in
Bytes.blit_string msg 0 padded 0 len;
if q = 1 then
Bytes.set padded len '\x86'
else begin
Bytes.set padded len '\x06';
Bytes.set padded (len + q - 1) '\x80'
end;
let total = Bytes.length padded in
let a = Array.make 25 0L in
let nblocks = total / rate in
for blk = 0 to nblocks - 1 do
let base = blk * rate in
(* Absorb: XOR rate bytes into the state, little-endian lanes. *)
for j = 0 to rate - 1 do
let lane = j / 8 and sh = (j mod 8) * 8 in
let byte = Int64.of_int (Char.code (Bytes.get padded (base + j))) in
a.(lane) <- a.(lane) ^: (Int64.shift_left byte sh)
done;
keccak_f a
done;
(* Squeeze 32 bytes (fits in the first 4 lanes; rate > 32). *)
let out = Buffer.create 64 in
for j = 0 to 31 do
let lane = j / 8 and sh = (j mod 8) * 8 in
let byte =
Int64.to_int
(Int64.logand (Int64.shift_right_logical a.(lane) sh) 0xFFL)
in
Buffer.add_string out (Printf.sprintf "%02x" byte)
done;
Buffer.contents out

271
hosts/ocaml/lib/sx_types.ml
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,35 +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. *)
| AdtValue of adt_value (** Native algebraic data type instance — opaque sum type. *)
(** Algebraic data type instance — produced by [define-type] constructors.
[av_type] is the type name (e.g. "Maybe"), [av_ctor] is the constructor
name (e.g. "Just"), [av_fields] are the positional field values. *)
and adt_value = {
av_type : string;
av_ctor : string;
av_fields : value array;
}
(** 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. *)
@@ -138,8 +108,6 @@ and lambda = {
l_closure : env;
mutable l_name : string option;
mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
mutable l_call_count : int; (** Tiered-compilation counter — JIT after threshold calls *)
l_uid : int; (** Unique identity for LRU cache tracking *)
}
and component = {
@@ -424,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>"
@@ -446,60 +413,12 @@ let unwrap_env_val = function
| Env e -> e
| _ -> raise (Eval_error "make_lambda: expected env for closure")
(* Lambda UID — minted on construction, used as LRU cache key (Phase 2). *)
let lambda_uid_counter = ref 0
let next_lambda_uid () = incr lambda_uid_counter; !lambda_uid_counter
let make_lambda params body closure =
let ps = match params with
| List items -> List.map value_to_string items
| _ -> value_to_string_list params
in
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0; l_uid = next_lambda_uid () }
(** {1 JIT cache control}
Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].
These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
them without creating a sx_primitives → sx_vm dependency cycle. *)
let jit_threshold = ref 4
let jit_compiled_count = ref 0
let jit_skipped_count = ref 0
let jit_threshold_skipped_count = ref 0
(** {2 JIT cache LRU eviction — Phase 2}
Once a lambda crosses the threshold, its [l_compiled] slot is filled.
To bound memory under unbounded compilation pressure, track all live
compiled lambdas in FIFO order, and evict from the head when the count
exceeds [jit_budget].
[lambda_uid_counter] mints unique identities on lambda creation; the
LRU queue holds these IDs paired with a back-reference to the lambda
so we can clear its [l_compiled] slot on eviction.
Budget of 0 = no cache (disable JIT entirely).
Budget of [max_int] = unbounded (legacy behaviour). Default 5000 is
a generous ceiling for any realistic page; the test harness compiles
~3000 distinct one-shot lambdas in a full run but tiered compilation
(Phase 1) means most never enter the cache, so steady-state count
stays small.
[lambda_uid_counter] and [next_lambda_uid] are defined above
[make_lambda] (which uses them on construction). *)
let jit_budget = ref 5000
let jit_evicted_count = ref 0
(** Live compiled lambdas in FIFO order — front is oldest, back is newest.
Each entry is (uid, lambda); on eviction we clear lambda.l_compiled and
drop from the queue. Using a mutable Queue rather than a hand-rolled
linked list because eviction is amortised O(1) at the head and inserts
are O(1) at the tail. *)
let jit_cache_queue : (int * value) Queue.t = Queue.create ()
let jit_cache_size () = Queue.length jit_cache_queue
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
let make_component name params has_children body closure affinity =
let n = value_to_string name in
@@ -542,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"
@@ -555,7 +473,7 @@ let type_of = function
| Macro _ -> "macro"
| Thunk _ -> "thunk"
| Continuation (_, _) -> "continuation"
| CallccContinuation (_, _) -> "continuation"
| CallccContinuation _ -> "continuation"
| NativeFn _ -> "function"
| Signal _ -> "signal"
| RawHTML _ -> "raw-html"
@@ -570,17 +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"
| AdtValue a -> a.av_type
let is_nil = function Nil -> true | _ -> false
let is_lambda = function Lambda _ -> true | _ -> false
@@ -596,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
@@ -709,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))
@@ -867,15 +773,13 @@ let dict_vals (d : dict) =
(** {1 Value display} *)
(* Single shared buffer for the entire inspect recursion — eliminates
the per-level [String.concat (List.map inspect ...)] allocation. *)
let rec inspect_into buf = function
| Nil -> Buffer.add_string buf "nil"
| Bool true -> Buffer.add_string buf "true"
| Bool false -> Buffer.add_string buf "false"
| Integer n -> Buffer.add_string buf (string_of_int n)
| Number n -> Buffer.add_string buf (format_number n)
let rec inspect = function
| Nil -> "nil"
| Bool true -> "true"
| Bool false -> "false"
| Number n -> format_number n
| String s ->
let buf = Buffer.create (String.length s + 2) in
Buffer.add_char buf '"';
String.iter (function
| '"' -> Buffer.add_string buf "\\\""
@@ -884,129 +788,46 @@ let rec inspect_into buf = function
| '\r' -> Buffer.add_string buf "\\r"
| '\t' -> Buffer.add_string buf "\\t"
| c -> Buffer.add_char buf c) s;
Buffer.add_char buf '"'
| Symbol s -> Buffer.add_string buf s
| Keyword k -> Buffer.add_char buf ':'; Buffer.add_string buf k
Buffer.add_char buf '"';
Buffer.contents buf
| Symbol s -> s
| Keyword k -> ":" ^ k
| List items | ListRef { contents = items } ->
Buffer.add_char buf '(';
(match items with
| [] -> ()
| x :: rest ->
inspect_into buf x;
List.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) rest);
Buffer.add_char buf ')'
"(" ^ String.concat " " (List.map inspect items) ^ ")"
| Dict d ->
Buffer.add_char buf '{';
let first = ref true in
Hashtbl.iter (fun k v ->
if !first then first := false else Buffer.add_char buf ' ';
Buffer.add_char buf ':'; Buffer.add_string buf k;
Buffer.add_char buf ' '; inspect_into buf v) d;
Buffer.add_char buf '}'
let pairs = Hashtbl.fold (fun k v acc ->
(Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
"{" ^ String.concat " " pairs ^ "}"
| Lambda l ->
let tag = match l.l_name with Some n -> n | None -> "lambda" in
Buffer.add_char buf '<'; Buffer.add_string buf tag;
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " l.l_params);
Buffer.add_string buf ")>"
Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
| Component c ->
Buffer.add_string buf "<Component ~"; Buffer.add_string buf c.c_name;
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " c.c_params);
Buffer.add_string buf ")>"
Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
| Island i ->
Buffer.add_string buf "<Island ~"; Buffer.add_string buf i.i_name;
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " i.i_params);
Buffer.add_string buf ")>"
Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
| Macro m ->
let tag = match m.m_name with Some n -> n | None -> "macro" in
Buffer.add_char buf '<'; Buffer.add_string buf tag;
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " m.m_params);
Buffer.add_string buf ")>"
| Thunk _ -> Buffer.add_string buf "<thunk>"
| Continuation (_, _) -> Buffer.add_string buf "<continuation>"
| CallccContinuation (_, _) -> Buffer.add_string buf "<callcc-continuation>"
| NativeFn (name, _) ->
Buffer.add_string buf "<native:"; Buffer.add_string buf name; Buffer.add_char buf '>'
| Signal _ -> Buffer.add_string buf "<signal>"
| RawHTML s ->
Buffer.add_string buf "\"<raw-html:";
Buffer.add_string buf (string_of_int (String.length s));
Buffer.add_string buf ">\""
| Spread _ -> Buffer.add_string buf "<spread>"
| SxExpr s ->
Buffer.add_string buf "\"<sx-expr:";
Buffer.add_string buf (string_of_int (String.length s));
Buffer.add_string buf ">\""
| Env _ -> Buffer.add_string buf "<env>"
| CekState _ -> Buffer.add_string buf "<cek-state>"
| CekFrame f ->
Buffer.add_string buf "<frame:"; Buffer.add_string buf f.cf_type; Buffer.add_char buf '>'
| VmClosure cl ->
Buffer.add_string buf "<vm:";
Buffer.add_string buf (match cl.vm_name with Some n -> n | None -> "anon");
Buffer.add_char buf '>'
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
| Thunk _ -> "<thunk>"
| Continuation (_, _) -> "<continuation>"
| CallccContinuation _ -> "<callcc-continuation>"
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
| Signal _ -> "<signal>"
| RawHTML s -> Printf.sprintf "\"<raw-html:%d>\"" (String.length s)
| Spread _ -> "<spread>"
| SxExpr s -> Printf.sprintf "\"<sx-expr:%d>\"" (String.length s)
| Env _ -> "<env>"
| CekState _ -> "<cek-state>"
| CekFrame f -> Printf.sprintf "<frame:%s>" f.cf_type
| VmClosure cl -> Printf.sprintf "<vm:%s>" (match cl.vm_name with Some n -> n | None -> "anon")
| Record r ->
Buffer.add_string buf "<record:"; Buffer.add_string buf r.r_type.rt_name;
Array.iteri (fun i v ->
Buffer.add_char buf ' ';
Buffer.add_string buf r.r_type.rt_fields.(i);
Buffer.add_char buf '=';
inspect_into buf v) r.r_fields;
Buffer.add_char buf '>'
| Parameter p ->
Buffer.add_string buf "<parameter:"; Buffer.add_string buf p.pm_uid; Buffer.add_char buf '>'
let fields = Array.to_list (Array.mapi (fun i v ->
Printf.sprintf "%s=%s" r.r_type.rt_fields.(i) (inspect v)
) r.r_fields) in
Printf.sprintf "<record:%s %s>" r.r_type.rt_name (String.concat " " fields)
| Parameter p -> Printf.sprintf "<parameter:%s>" p.pm_uid
| Vector arr ->
Buffer.add_string buf "#(";
Array.iteri (fun i v ->
if i > 0 then Buffer.add_char buf ' ';
inspect_into buf v) arr;
Buffer.add_char buf ')'
| VmFrame f ->
Buffer.add_string buf (Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base)
| VmMachine m ->
Buffer.add_string buf (Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames))
| StringBuffer b ->
Buffer.add_string buf (Printf.sprintf "<string-buffer:%d>" (Buffer.length b))
| HashTable ht ->
Buffer.add_string buf (Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht))
| Char n ->
Buffer.add_string buf "#\\";
(match n with
| 32 -> Buffer.add_string buf "space"
| 10 -> Buffer.add_string buf "newline"
| 9 -> Buffer.add_string buf "tab"
| 13 -> Buffer.add_string buf "return"
| 0 -> Buffer.add_string buf "nul"
| 27 -> Buffer.add_string buf "escape"
| 127 -> Buffer.add_string buf "delete"
| 8 -> Buffer.add_string buf "backspace"
| _ -> Buffer.add_utf_8_uchar buf (Uchar.of_int n))
| Eof -> Buffer.add_string buf "#!eof"
| Port { sp_kind = PortInput (_, pos); sp_closed } ->
Buffer.add_string buf (Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else ""))
| Port { sp_kind = PortOutput b; sp_closed } ->
Buffer.add_string buf (Printf.sprintf "<output-port:len=%d%s>" (Buffer.length b) (if sp_closed then ":closed" else ""))
| Rational (n, d) ->
Buffer.add_string buf (string_of_int n); Buffer.add_char buf '/';
Buffer.add_string buf (string_of_int d)
| SxSet ht ->
Buffer.add_string buf (Printf.sprintf "<set:%d>" (Hashtbl.length ht))
| SxRegexp (src, flags, _) ->
Buffer.add_string buf "#/"; Buffer.add_string buf src;
Buffer.add_char buf '/'; Buffer.add_string buf flags
| SxBytevector b ->
Buffer.add_string buf "#u8(";
let n = Bytes.length b in
for i = 0 to n - 1 do
if i > 0 then Buffer.add_char buf ' ';
Buffer.add_string buf (string_of_int (Char.code (Bytes.get b i)))
done;
Buffer.add_char buf ')'
| AdtValue a ->
Buffer.add_char buf '('; Buffer.add_string buf a.av_ctor;
Array.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) a.av_fields;
Buffer.add_char buf ')'
let inspect v =
let buf = Buffer.create 64 in
inspect_into buf v;
Buffer.contents buf
let elts = Array.to_list (Array.map inspect arr) in
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)

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

@@ -44,11 +44,6 @@ type vm = {
ip past OP_PERFORM, stack ready for a result push). *)
exception VmSuspended of value * vm
(** Raised by the extension dispatch fallthrough when an opcode in the
extension range (≥ 200) is encountered with no handler registered.
Carries the offending opcode id. See plans/sx-vm-opcode-extension.md. *)
exception Invalid_opcode of int
(* Register the VM suspension converter so sx_runtime.sx_apply_cek can
catch VmSuspended and convert it to CekPerformRequest without a
direct dependency on this module. *)
@@ -62,24 +57,6 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
ref (fun _ _ -> None)
(** Forward reference for extension opcode dispatch — Phase B installs the
real registry's dispatch function here at module init. Until then, any
opcode in the extension range raises [Invalid_opcode]. Same forward-ref
pattern as [jit_compile_ref] above; keeps [Sx_vm_extensions] free to
depend on [Sx_vm]'s [vm] / [frame] types without a cycle. *)
let extension_dispatch_ref : (int -> vm -> frame -> unit) ref =
ref (fun op _vm _frame -> raise (Invalid_opcode op))
(** Forward reference for extension opcode → name lookup, used by
[opcode_name] / [disassemble] for human-readable disassembly. The
registry installs a real lookup at module init; default returns
[None] (then [opcode_name] falls back to "UNKNOWN_n"). *)
let extension_opcode_name_ref : (int -> string option) ref =
ref (fun _ -> None)
(* JIT threshold and counters live in Sx_types so primitives can read them
without creating a sx_primitives → sx_vm dependency cycle. *)
(** Sentinel closure indicating JIT compilation was attempted and failed.
Prevents retrying compilation on every call. *)
let jit_failed_sentinel = {
@@ -208,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
@@ -222,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. *)
@@ -350,18 +326,7 @@ and call_closure_reuse cl args =
vm.sp <- saved_sp;
raise e);
vm.frames <- saved_frames;
(* Snapshot/restore sp around the popped result.
OP_RETURN normally leaves sp = saved_sp + 1, but the bytecode-exhausted
path (or a callee that returns a closure whose own RETURN leaves extra
stack residue) can leave sp inconsistent. Read the result at the
expected slot and reset sp explicitly so the parent frame's
intermediate values are not corrupted. *)
let result =
if vm.sp > saved_sp then vm.stack.(vm.sp - 1)
else Nil
in
vm.sp <- saved_sp;
result
pop vm
| None ->
call_closure cl args cl.vm_env_ref
@@ -387,29 +352,13 @@ and vm_call vm f args =
| None ->
if l.l_name <> None
then begin
l.l_call_count <- l.l_call_count + 1;
if l.l_call_count >= !Sx_types.jit_threshold && !Sx_types.jit_budget > 0 then begin
l.l_compiled <- Some jit_failed_sentinel;
match !jit_compile_ref l vm.globals with
| Some cl ->
incr Sx_types.jit_compiled_count;
l.l_compiled <- Some cl;
(* Phase 2 LRU: track this compiled lambda; if cache exceeds budget,
evict the oldest by clearing its l_compiled slot. *)
Queue.add (l.l_uid, Lambda l) Sx_types.jit_cache_queue;
while Queue.length Sx_types.jit_cache_queue > !Sx_types.jit_budget do
(match Queue.pop Sx_types.jit_cache_queue with
| (_, Lambda ev_l) -> ev_l.l_compiled <- None; incr Sx_types.jit_evicted_count
| _ -> ())
done;
push_closure_frame vm cl args
| None ->
incr Sx_types.jit_skipped_count;
push vm (cek_call_or_suspend vm f (List args))
end else begin
incr Sx_types.jit_threshold_skipped_count;
l.l_compiled <- Some jit_failed_sentinel;
match !jit_compile_ref l vm.globals with
| Some cl ->
l.l_compiled <- Some cl;
push_closure_frame vm cl args
| None ->
push vm (cek_call_or_suspend vm f (List args))
end
end
else
push vm (cek_call_or_suspend vm f (List args)))
@@ -681,9 +630,7 @@ and run vm =
(* Read upvalue descriptors from bytecode *)
let uv_count = match code_val with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Integer n) -> n
| Some (Number n) -> int_of_float n
| _ -> 0)
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0
in
let upvalues = Array.init uv_count (fun _ ->
@@ -783,67 +730,51 @@ and run vm =
| 160 (* OP_ADD *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Integer x, Integer y -> Integer (x + y)
| Number x, Number y -> Number (x +. y)
| Integer x, Number y -> Number (float_of_int x +. y)
| Number x, Integer y -> Number (x +. float_of_int y)
| _ -> (Hashtbl.find Sx_primitives.primitives "+") [a; b])
| 161 (* OP_SUB *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Integer x, Integer y -> Integer (x - y)
| Number x, Number y -> Number (x -. y)
| Integer x, Number y -> Number (float_of_int x -. y)
| Number x, Integer y -> Number (x -. float_of_int y)
| _ -> (Hashtbl.find Sx_primitives.primitives "-") [a; b])
| 162 (* OP_MUL *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Integer x, Integer y -> Integer (x * y)
| Number x, Number y -> Number (x *. y)
| Integer x, Number y -> Number (float_of_int x *. y)
| Number x, Integer y -> Number (x *. float_of_int y)
| _ -> (Hashtbl.find Sx_primitives.primitives "*") [a; b])
| 163 (* OP_DIV *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Integer x, Integer y when y <> 0 && x mod y = 0 -> Integer (x / y)
| Integer x, Integer y -> Number (float_of_int x /. float_of_int y)
| Number x, Number y -> Number (x /. y)
| Integer x, Number y -> Number (float_of_int x /. y)
| Number x, Integer y -> Number (x /. float_of_int y)
| _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
| 164 (* OP_EQ *) ->
let b = pop vm and a = pop vm in
push vm (Bool (Sx_runtime._fast_eq 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
| Integer x, Integer y -> Bool (x < y)
| Number x, Number y -> Bool (x < y)
| Integer x, Number y -> Bool (float_of_int x < y)
| Number x, Integer y -> Bool (x < float_of_int y)
| String x, String y -> Bool (x < y)
| _ -> Sx_runtime.prim_call "<" [a; b])
| _ -> (Hashtbl.find Sx_primitives.primitives "<") [a; b])
| 166 (* OP_GT *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Integer x, Integer y -> Bool (x > y)
| Number x, Number y -> Bool (x > y)
| Integer x, Number y -> Bool (float_of_int x > y)
| Number x, Integer y -> Bool (x > float_of_int y)
| String x, String y -> Bool (x > y)
| _ -> Sx_runtime.prim_call ">" [a; b])
| _ -> (Hashtbl.find Sx_primitives.primitives ">") [a; b])
| 167 (* OP_NOT *) ->
let v = pop vm in
push vm (Bool (not (sx_truthy v)))
| 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
@@ -895,15 +826,6 @@ and run vm =
let request = pop vm in
raise (VmSuspended (request, vm))
(* ---- Extension dispatch fallthrough ----
Opcode partition (see plans/sx-vm-opcode-extension.md):
0 reserved / NOP
1-199 core opcodes (current ceiling 175 = OP_DEC)
200-247 extension opcodes (registered via Sx_vm_extensions)
248-255 reserved for future expansion / multi-byte
Any opcode ≥ 200 routes through the extension registry. *)
| op when op >= 200 -> !extension_dispatch_ref op vm frame
| opcode ->
raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d"
opcode (frame.ip - 1)))
@@ -965,17 +887,9 @@ let resume_vm vm result =
let rec restore_reuse pending =
match pending with
| [] -> ()
| (saved_frames, saved_sp) :: rest ->
| (saved_frames, _saved_sp) :: rest ->
let callback_result = pop vm in
vm.frames <- saved_frames;
(* Restore sp to the value captured before the suspended callee was
pushed. The callee's locals/temps may still be on the stack above
saved_sp; without this reset, subsequent LOCAL_GET/SET in the
caller frame (e.g. letrec sibling bindings waiting on the call)
see stale callee data instead of their own slots. Mirrors the
OP_RETURN+sp-reset semantics that sync `call_closure_reuse`
relies on for clean caller-frame state. *)
if saved_sp < vm.sp then vm.sp <- saved_sp;
push vm callback_result;
(try
run vm;
@@ -1056,62 +970,6 @@ let _jit_is_broken_name n =
|| n = "hs-repeat-while" || n = "hs-repeat-until"
|| n = "hs-for-each" || n = "hs-put!"
(** Scan bytecode for any extension opcode (≥ 200, the registry's
[Sx_vm_extensions.extension_min]). Walks operand bytes correctly
so values that happen to be ≥200 (e.g. a CONST u16 index pointing
into a large pool) do not trigger false positives. CLOSURE's
dynamic upvalue descriptors are read from the constant pool entry
at the same index it pushes.
Used by [jit_compile_lambda] (Phase E of the opcode-extension
plan): a lambda whose compiled body contains any extension opcode
is routed through interpretation rather than JIT. Extensions
interpret their opcodes via the registry; the JIT does not
currently know how to compile them.
Operand-size logic mirrors [opcode_operand_size] (which is defined
later, in the disassembly section); inlined here so this helper can
sit before [jit_compile_lambda] in the file. *)
let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
let core_operand_size = function
| 1 | 20 | 21 | 64 | 65 | 128 -> 2 (* u16 *)
| 16 | 17 | 18 | 19 | 48 | 49 | 144 -> 1 (* u8 *)
| 32 | 33 | 34 | 35 -> 2 (* i16 *)
| 52 -> 3 (* CALL_PRIM: u16 + u8 *)
| _ -> 0
in
let len = Array.length bc in
let ip = ref 0 in
let found = ref false in
while not !found && !ip < len do
let op = bc.(!ip) in
if op >= 200 then found := true
else begin
ip := !ip + 1;
let extra = match op with
| 51 (* CLOSURE *) when !ip + 1 < len ->
let lo = bc.(!ip) in
let hi = bc.(!ip + 1) in
let idx = lo lor (hi lsl 8) in
let uv_count =
if idx < Array.length consts then
(match consts.(idx) with
| Dict d ->
(match Hashtbl.find_opt d "upvalue-count" with
| Some (Integer n) -> n
| Some (Number n) -> int_of_float n
| _ -> 0)
| _ -> 0)
else 0
in
2 + uv_count * 2
| _ -> core_operand_size op
in
ip := !ip + extra
end
done;
!found
let jit_compile_lambda (l : lambda) globals =
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
if !_jit_compiling then (
@@ -1174,18 +1032,8 @@ let jit_compile_lambda (l : lambda) globals =
if idx < Array.length outer_code.vc_constants then
let inner_val = outer_code.vc_constants.(idx) in
let code = code_from_value inner_val in
(* Phase E: if the inner lambda's bytecode contains any
extension opcode (≥200), skip JIT and let the lambda run
interpreted via CEK. Extension opcodes dispatch correctly
through the VM's registry fallthrough, but the JIT has no
knowledge of them and shouldn't claim ownership. *)
if bytecode_uses_extension_opcodes code.vc_bytecode code.vc_constants then begin
Printf.eprintf "[jit] SKIP %s: bytecode uses extension opcodes (interpret-only in v1)\n%!"
fn_name;
None
end else
Some { vm_code = code; vm_upvalues = [||];
vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
Some { vm_code = code; vm_upvalues = [||];
vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
else begin
Printf.eprintf "[jit] FAIL %s: closure index %d out of bounds (pool=%d)\n%!"
fn_name idx (Array.length outer_code.vc_constants);
@@ -1295,12 +1143,7 @@ let opcode_name = function
| 164 -> "EQ" | 165 -> "LT" | 166 -> "GT" | 167 -> "NOT"
| 168 -> "LEN" | 169 -> "FIRST" | 170 -> "REST" | 171 -> "NTH"
| 172 -> "CONS" | 173 -> "NEG" | 174 -> "INC" | 175 -> "DEC"
| n ->
(* Extension opcodes (≥200) get their human-readable name from the
registry; defaults to UNKNOWN_n if the extension isn't loaded. *)
(match !extension_opcode_name_ref n with
| Some name -> name
| None -> Printf.sprintf "UNKNOWN_%d" n)
| n -> Printf.sprintf "UNKNOWN_%d" n
(** Number of extra operand bytes consumed by each opcode.
Returns (format, total_bytes) where format describes the operand types. *)
@@ -1428,9 +1271,7 @@ let trace_run src globals =
let code_val2 = frame.closure.vm_code.vc_constants.(idx) in
let uv_count = match code_val2 with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Integer n) -> n
| Some (Number n) -> int_of_float n
| _ -> 0)
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0 in
let upvalues = Array.init uv_count (fun _ ->
let is_local = read_u8 frame in
@@ -1551,9 +1392,7 @@ let disassemble (code : vm_code) =
if op = 51 && idx < Array.length consts then begin
let uv_count = match consts.(idx) with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Integer n) -> n
| Some (Number n) -> int_of_float n
| _ -> 0)
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0 in
ip := !ip + uv_count * 2
end

48
hosts/ocaml/lib/sx_vm_extension.ml
View File

@@ -1,48 +0,0 @@
(** {1 VM extension interface}
Type definitions for VM bytecode extensions. See
[plans/sx-vm-opcode-extension.md].
An extension is a first-class module of type [EXTENSION]: it has a
stable [name], an [init] that returns its private state, and an
[opcodes] function that lists the opcodes it provides.
Opcode handlers receive the live [vm] and the active [frame]. They
read operands via [Sx_vm.read_u8] / [read_u16], manipulate the stack
via [push] / [pop] / [peek], and update the frame's [ip] as needed. *)
(** A handler for an extension opcode. Reads operands from bytecode,
manipulates the VM stack, updates the frame's instruction pointer.
May raise exceptions (which propagate via the existing VM error path). *)
type handler = Sx_vm.vm -> Sx_vm.frame -> unit
(** State an extension carries alongside the VM. Opaque to the VM core;
extensions extend this with their own constructor and cast as needed.
Extensible variant — extensions add cases:
{[
type Sx_vm_extension.extension_state +=
| ErlangState of erlang_scheduler
]} *)
type extension_state = ..
(** An extension is a first-class module of this signature. *)
module type EXTENSION = sig
(** Stable name for this extension (e.g. ["erlang"], ["guest_vm"]).
Used as the lookup key in the registry and as the prefix for opcode
names ([erlang.OP_PATTERN_TUPLE_2] etc). *)
val name : string
(** Initialize per-instance state. Called once when [register] is
invoked on this extension. *)
val init : unit -> extension_state
(** Opcodes this extension provides. Each is
[(opcode_id, opcode_name, handler)].
[opcode_id] must be in the range 200-247 (the extension partition;
see the partition comment at the top of [Sx_vm]'s dispatch loop).
Conflicts with already-registered opcodes cause [register] to
fail. *)
val opcodes : extension_state -> (int * string * handler) list
end

120
hosts/ocaml/lib/sx_vm_extensions.ml
View File

@@ -1,120 +0,0 @@
(** {1 VM extension registry}
Holds the live registry of extension opcodes and installs the
[dispatch] function into [Sx_vm.extension_dispatch_ref] at module
init time, replacing Phase A's stub.
See [plans/sx-vm-opcode-extension.md] and [Sx_vm_extension] for the
extension interface. *)
open Sx_vm_extension
(** The opcode range an extension is allowed to claim.
Mirrors the partition comment in [Sx_vm]. *)
let extension_min = 200
let extension_max = 247
(** opcode_id → handler *)
let by_id : (int, handler) Hashtbl.t = Hashtbl.create 64
(** opcode_name → opcode_id *)
let by_name : (string, int) Hashtbl.t = Hashtbl.create 64
(** opcode_id → opcode_name (reverse of [by_name]; used by
[Sx_vm.opcode_name] for disassembly). *)
let name_of_id_table : (int, string) Hashtbl.t = Hashtbl.create 64
(** extension_name → state *)
let states : (string, extension_state) Hashtbl.t = Hashtbl.create 8
(** Registered extension names, newest first. *)
let extensions : string list ref = ref []
(** Dispatch an extension opcode to its registered handler. Raises
[Sx_vm.Invalid_opcode] if no handler is registered for [op]. *)
let dispatch op vm frame =
match Hashtbl.find_opt by_id op with
| Some handler -> handler vm frame
| None -> raise (Sx_vm.Invalid_opcode op)
(** Register an extension. Fails if the extension name is already
registered, or if any opcode_id is outside the extension range or
collides with an already-registered opcode. *)
let register (m : (module EXTENSION)) =
let module M = (val m) in
if Hashtbl.mem states M.name then
failwith (Printf.sprintf
"Sx_vm_extensions: extension %S already registered" M.name);
let st = M.init () in
let ops = M.opcodes st in
List.iter (fun (id, opname, _h) ->
if id < extension_min || id > extension_max then
failwith (Printf.sprintf
"Sx_vm_extensions: opcode %d (%s) outside extension range %d-%d"
id opname extension_min extension_max);
if Hashtbl.mem by_id id then
failwith (Printf.sprintf
"Sx_vm_extensions: opcode %d (%s) already registered" id opname);
if Hashtbl.mem by_name opname then
failwith (Printf.sprintf
"Sx_vm_extensions: opcode name %S already registered" opname)
) ops;
Hashtbl.add states M.name st;
List.iter (fun (id, opname, h) ->
Hashtbl.add by_id id h;
Hashtbl.add by_name opname id;
Hashtbl.add name_of_id_table id opname
) ops;
extensions := M.name :: !extensions
(** Look up the opcode_id for an opcode_name. Returns [None] if no
extension provides that opcode. *)
let id_of_name name = Hashtbl.find_opt by_name name
(** Look up the opcode_name for an opcode_id. Returns [None] if no
extension provides that opcode. Used by disassembly. *)
let name_of_id id = Hashtbl.find_opt name_of_id_table id
(** Look up the state of an extension by name. Returns [None] if the
extension is not registered. *)
let state_of_extension name = Hashtbl.find_opt states name
(** Names of all registered extensions, newest first. *)
let registered_extensions () = !extensions
(** Test-only: clear the registry. Used by unit tests to isolate
extensions between test cases. The dispatch_ref is left in place. *)
let _reset_for_tests () =
Hashtbl.clear by_id;
Hashtbl.clear by_name;
Hashtbl.clear name_of_id_table;
Hashtbl.clear states;
extensions := []
(** Install our [dispatch] into [Sx_vm.extension_dispatch_ref] and our
[name_of_id] into [Sx_vm.extension_opcode_name_ref], replacing
the Phase A stubs. Idempotent. Called automatically at module init. *)
let install_dispatch () =
Sx_vm.extension_dispatch_ref := dispatch;
Sx_vm.extension_opcode_name_ref := name_of_id
let () = install_dispatch ()
(** Compiler-side opcode lookup: register the [extension-opcode-id]
primitive. Compilers ([lib/compiler.sx]) call this to emit
extension opcodes by name. Returns [Integer id] when registered,
[Nil] otherwise — so missing extensions degrade to a fallback
rather than failure. *)
let () =
Sx_primitives.register "extension-opcode-id" (fun args ->
match args with
| [Sx_types.String name] ->
(match id_of_name name with
| Some id -> Sx_types.Integer id
| None -> Sx_types.Nil)
| [Sx_types.Symbol name] ->
(match id_of_name name with
| Some id -> Sx_types.Integer id
| None -> Sx_types.Nil)
| _ -> raise (Sx_types.Eval_error
"extension-opcode-id: expected one string or symbol"))

4
hosts/ocaml/lib/sx_vm_ref.ml
View File

@@ -270,9 +270,7 @@ let vm_create_closure vm_val frame_val code_val =
let f = unwrap_frame frame_val in
let uv_count = match code_val with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Integer n) -> n
| Some (Number n) -> int_of_float n
| _ -> 0)
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0
in
let upvalues = Array.init uv_count (fun _ ->

4
hosts/ocaml/sx_vm_ref.ml
View File

@@ -265,9 +265,7 @@ let vm_create_closure vm_val frame_val code_val =
let f = unwrap_frame frame_val in
let uv_count = match code_val with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Integer n) -> n
| Some (Number n) -> int_of_float n
| _ -> 0)
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0
in
let upvalues = Array.init uv_count (fun _ ->

10
hosts/ocaml/transpiler.sx
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

116
lib/apl/conformance.sh
View File

@@ -1,116 +0,0 @@
#!/usr/bin/env bash
# lib/apl/conformance.sh — run APL test suites, emit scoreboard.json + scoreboard.md.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found." >&2
exit 1
fi
SUITES=(structural operators dfn tradfn valence programs system idioms eval-ops pipeline)
OUT_JSON="lib/apl/scoreboard.json"
OUT_MD="lib/apl/scoreboard.md"
run_suite() {
local suite=$1
local file="lib/apl/tests/${suite}.sx"
local TMP
TMP=$(mktemp)
cat > "$TMP" << EPOCHS
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/r7rs.sx")
(load "lib/apl/runtime.sx")
(load "lib/apl/tokenizer.sx")
(load "lib/apl/parser.sx")
(load "lib/apl/transpile.sx")
(epoch 2)
(eval "(define apl-test-pass 0)")
(eval "(define apl-test-fail 0)")
(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (set! apl-test-fail (+ apl-test-fail 1)))))")
(epoch 3)
(load "${file}")
(epoch 4)
(eval "(list apl-test-pass apl-test-fail)")
EPOCHS
local OUTPUT
OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null)
rm -f "$TMP"
local LINE
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 4 //; s/\)$//')
fi
local P F
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
P=${P:-0}
F=${F:-0}
echo "${P} ${F}"
}
declare -A SUITE_PASS
declare -A SUITE_FAIL
TOTAL_PASS=0
TOTAL_FAIL=0
echo "Running APL conformance suite..." >&2
for s in "${SUITES[@]}"; do
read -r p f < <(run_suite "$s")
SUITE_PASS[$s]=$p
SUITE_FAIL[$s]=$f
TOTAL_PASS=$((TOTAL_PASS + p))
TOTAL_FAIL=$((TOTAL_FAIL + f))
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
done
# scoreboard.json
{
printf '{\n'
printf ' "suites": {\n'
first=1
for s in "${SUITES[@]}"; do
if [ $first -eq 0 ]; then printf ',\n'; fi
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
first=0
done
printf '\n },\n'
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
printf '}\n'
} > "$OUT_JSON"
# scoreboard.md
{
printf '# APL Conformance Scoreboard\n\n'
printf '_Generated by `lib/apl/conformance.sh`_\n\n'
printf '| Suite | Pass | Fail | Total |\n'
printf '|-------|-----:|-----:|------:|\n'
for s in "${SUITES[@]}"; do
p=${SUITE_PASS[$s]}
f=${SUITE_FAIL[$s]}
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
done
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
printf '\n'
printf '## Notes\n\n'
printf '%s\n' '- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.'
printf '%s\n' '- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.'
} > "$OUT_MD"
echo "Wrote $OUT_JSON and $OUT_MD" >&2
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
[ "$TOTAL_FAIL" -eq 0 ]

711
lib/apl/parser.sx
View File

@@ -1,711 +0,0 @@
; APL Parser — right-to-left expression parser
;
; Takes a token list (output of apl-tokenize) and produces an AST.
; APL evaluates right-to-left with no precedence among functions.
; Operators bind to the function immediately to their left in the source.
;
; AST node types:
; (:num n) number literal
; (:str s) string literal
; (:vec n1 n2 ...) strand (juxtaposed literals)
; (:name "x") name reference / alpha / omega
; (:assign "x" expr) assignment x←expr
; (:monad fn arg) monadic function call
; (:dyad fn left right) dyadic function call
; (:derived-fn op fn) derived function: f/ f¨ f⍨
; (:derived-fn2 "." f g) inner product: f.g
; (:outer "∘." fn) outer product: ∘.f
; (:fn-glyph "⍳") function reference
; (:fn-name "foo") named-function reference (dfn variable)
; (:dfn stmt...) {⍺+⍵} anonymous function
; (:guard cond expr) cond:expr guard inside dfn
; (:program stmt...) multi-statement sequence
; ============================================================
; Glyph classification sets
; ============================================================
(define
apl-parse-op-glyphs
(list "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
(define
apl-parse-fn-glyphs
(list
"+"
"-"
"×"
"÷"
"*"
"⍟"
"⌈"
"⌊"
"|"
"!"
"?"
"○"
"~"
"<"
"≤"
"="
"≥"
">"
"≠"
"≢"
"≡"
"∊"
"∧"
"∨"
"⍱"
"⍲"
","
"⍪"
"⍴"
"⌽"
"⊖"
"⍉"
"↑"
"↓"
"⊂"
"⊃"
"⊆"
"∪"
"∩"
"⍳"
"⍸"
"⌷"
"⍋"
"⍒"
"⊥"
"⊤"
"⊣"
"⊢"
"⍎"
"⍕"))
(define apl-quad-fn-names (list "⎕FMT" "⎕←"))
(define apl-known-fn-names (list))
; ============================================================
; Token accessors
; ============================================================
(define
apl-collect-fn-bindings
(fn
(stmt-groups)
(set! apl-known-fn-names (list))
(for-each
(fn
(toks)
(when
(and
(>= (len toks) 3)
(= (tok-type (nth toks 0)) :name)
(= (tok-type (nth toks 1)) :assign)
(= (tok-type (nth toks 2)) :lbrace))
(set!
apl-known-fn-names
(cons (tok-val (nth toks 0)) apl-known-fn-names))))
stmt-groups)))
(define
apl-parse-op-glyph?
(fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
(define
apl-parse-fn-glyph?
(fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs)))
(define tok-type (fn (tok) (get tok :type)))
; ============================================================
; Collect trailing operators starting at index i
; Returns {:ops (op ...) :end new-i}
; ============================================================
(define tok-val (fn (tok) (get tok :value)))
(define
is-op-tok?
(fn
(tok)
(and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok)))))
; ============================================================
; Build a derived-fn node by chaining operators left-to-right
; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
; ============================================================
(define
is-fn-tok?
(fn
(tok)
(or
(and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok)))
(and
(= (tok-type tok) :name)
(or
(some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)
(some (fn (q) (= q (tok-val tok))) apl-known-fn-names))))))
; ============================================================
; Find matching close bracket/paren/brace
; Returns the index of the matching close token
; ============================================================
(define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list))))
(define
collect-ops-loop
(fn
(tokens i acc)
(if
(>= i (len tokens))
{:end i :ops acc}
(let
((tok (nth tokens i)))
(if
(is-op-tok? tok)
(collect-ops-loop tokens (+ i 1) (append acc (tok-val tok)))
{:end i :ops acc})))))
; ============================================================
; Segment collection: scan tokens left-to-right, building
; a list of {:kind "val"/"fn" :node ast} segments.
; Operators following function glyphs are merged into
; derived-fn nodes during this pass.
; ============================================================
(define
build-derived-fn
(fn
(fn-node ops)
(if
(= (len ops) 0)
fn-node
(build-derived-fn (list :derived-fn (first ops) fn-node) (rest ops)))))
(define
find-matching-close
(fn
(tokens start open-type close-type)
(find-matching-close-loop tokens start open-type close-type 1)))
; ============================================================
; Build tree from segment list
;
; The segments are in left-to-right order.
; APL evaluates right-to-left, so the LEFTMOST function is
; the outermost (last-evaluated) node.
;
; Patterns:
; [val] → val node
; [fn val ...] → (:monad fn (build-tree rest))
; [val fn val ...] → (:dyad fn val (build-tree rest))
; [val val ...] → (:vec val1 val2 ...) — strand
; ============================================================
; Find the index of the first function segment (returns -1 if none)
(define
find-matching-close-loop
(fn
(tokens i open-type close-type depth)
(if
(>= i (len tokens))
(len tokens)
(let
((tt (tok-type (nth tokens i))))
(cond
((= tt open-type)
(find-matching-close-loop
tokens
(+ i 1)
open-type
close-type
(+ depth 1)))
((= tt close-type)
(if
(= depth 1)
i
(find-matching-close-loop
tokens
(+ i 1)
open-type
close-type
(- depth 1))))
(true
(find-matching-close-loop
tokens
(+ i 1)
open-type
close-type
depth)))))))
(define
collect-segments
(fn (tokens) (collect-segments-loop tokens 0 (list))))
; Build an array node from 0..n value segments
; If n=1 → return that segment's node
; If n>1 → return (:vec node1 node2 ...)
(define
collect-segments-loop
(fn
(tokens i acc)
(if
(>= i (len tokens))
acc
(let
((tok (nth tokens i)) (n (len tokens)))
(let
((tt (tok-type tok)) (tv (tok-val tok)))
(cond
((or (= tt :diamond) (= tt :newline) (= tt :semi))
(collect-segments-loop tokens (+ i 1) acc))
((= tt :num)
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :num tv)})))
((= tt :str)
(collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
((= tt :name)
(cond
((and (< (+ i 1) (len tokens)) (= (tok-type (nth tokens (+ i 1))) :assign))
(let
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
(let
((rhs-expr (parse-apl-expr rhs-tokens)))
(collect-segments-loop
tokens
(len tokens)
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)})))))
((some (fn (q) (= q tv)) apl-quad-fn-names)
(let
((op-result (collect-ops tokens (+ i 1))))
(let
((ops (get op-result :ops))
(ni (get op-result :end)))
(let
((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
(collect-segments-loop
tokens
ni
(append acc {:kind "fn" :node fn-node}))))))
((some (fn (q) (= q tv)) apl-known-fn-names)
(let
((op-result (collect-ops tokens (+ i 1))))
(let
((ops (get op-result :ops))
(ni (get op-result :end)))
(let
((fn-node (build-derived-fn (list :fn-name tv) ops)))
(collect-segments-loop
tokens
ni
(append acc {:kind "fn" :node fn-node}))))))
(else
(let
((br (maybe-bracket (list :name tv) tokens (+ i 1))))
(collect-segments-loop
tokens
(nth br 1)
(append acc {:kind "val" :node (nth br 0)}))))))
((= tt :lparen)
(let
((end (find-matching-close tokens (+ i 1) :lparen :rparen)))
(let
((inner-tokens (slice tokens (+ i 1) end))
(after (+ end 1)))
(let
((inner-segs (collect-segments inner-tokens)))
(if
(and
(>= (len inner-segs) 2)
(every? (fn (s) (= (get s :kind) "fn")) inner-segs))
(let
((train-node (cons :train (map (fn (s) (get s :node)) inner-segs))))
(collect-segments-loop
tokens
after
(append acc {:kind "fn" :node train-node})))
(let
((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after)))
(collect-segments-loop
tokens
(nth br 1)
(append acc {:kind "val" :node (nth br 0)}))))))))
((= tt :lbrace)
(let
((end (find-matching-close tokens (+ i 1) :lbrace :rbrace)))
(let
((inner-tokens (slice tokens (+ i 1) end))
(after (+ end 1)))
(collect-segments-loop tokens after (append acc {:kind "fn" :node (parse-dfn inner-tokens)})))))
((= tt :glyph)
(cond
((or (= tv "⍺") (= tv "⍵"))
(if
(and
(< (+ i 1) (len tokens))
(= (tok-type (nth tokens (+ i 1))) :assign))
(let
((rhs-tokens (slice tokens (+ i 2) (len tokens))))
(let
((rhs-expr (parse-apl-expr rhs-tokens)))
(collect-segments-loop
tokens
(len tokens)
(append acc {:kind "val" :node (list :assign-expr tv rhs-expr)}))))
(collect-segments-loop
tokens
(+ i 1)
(append acc {:kind "val" :node (list :name tv)}))))
((= tv "∇")
(collect-segments-loop
tokens
(+ i 1)
(append acc {:kind "fn" :node (list :fn-glyph "∇")})))
((and (= tv "∘") (< (+ i 1) n) (= (tok-val (nth tokens (+ i 1))) "."))
(if
(and (< (+ i 2) n) (is-fn-tok? (nth tokens (+ i 2))))
(let
((fn-tv (tok-val (nth tokens (+ i 2)))))
(let
((op-result (collect-ops tokens (+ i 3))))
(let
((ops (get op-result :ops))
(ni (get op-result :end)))
(let
((fn-node (build-derived-fn (list :fn-glyph fn-tv) ops)))
(collect-segments-loop
tokens
ni
(append acc {:kind "fn" :node (list :outer "∘." fn-node)}))))))
(collect-segments-loop tokens (+ i 1) acc)))
((apl-parse-fn-glyph? tv)
(let
((op-result (collect-ops tokens (+ i 1))))
(let
((ops (get op-result :ops))
(ni (get op-result :end)))
(if
(and
(= (len ops) 1)
(= (first ops) ".")
(< ni n)
(is-fn-tok? (nth tokens ni)))
(let
((g-tv (tok-val (nth tokens ni))))
(let
((op-result2 (collect-ops tokens (+ ni 1))))
(let
((ops2 (get op-result2 :ops))
(ni2 (get op-result2 :end)))
(let
((g-node (build-derived-fn (list :fn-glyph g-tv) ops2)))
(collect-segments-loop
tokens
ni2
(append acc {:kind "fn" :node (list :derived-fn2 "." (list :fn-glyph tv) g-node)}))))))
(let
((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
(collect-segments-loop
tokens
ni
(append acc {:kind "fn" :node fn-node})))))))
((apl-parse-op-glyph? tv)
(if
(or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
(let
((next-i (+ i 1)))
(let
((next-tok (if (< next-i n) (nth tokens next-i) nil)))
(let
((mod (if (and next-tok (= (tok-type next-tok) :glyph) (or (= (get next-tok :value) "⍨") (= (get next-tok :value) "¨"))) (get next-tok :value) nil))
(base-fn-node (list :fn-glyph tv)))
(let
((node (if mod (list :derived-fn mod base-fn-node) base-fn-node))
(advance (if mod 2 1)))
(collect-segments-loop
tokens
(+ i advance)
(append acc {:kind "fn" :node node}))))))
(collect-segments-loop tokens (+ i 1) acc)))
(true (collect-segments-loop tokens (+ i 1) acc))))
(true (collect-segments-loop tokens (+ i 1) acc))))))))
(define find-first-fn (fn (segs) (find-first-fn-loop segs 0)))
; ============================================================
; Split token list on statement separators (diamond / newline)
; Only splits at depth 0 (ignores separators inside { } or ( ) )
; ============================================================
(define
find-first-fn-loop
(fn
(segs i)
(if
(>= i (len segs))
-1
(if
(= (get (nth segs i) :kind) "fn")
i
(find-first-fn-loop segs (+ i 1))))))
(define
segs-to-array
(fn
(segs)
(if
(= (len segs) 1)
(get (first segs) :node)
(cons :vec (map (fn (s) (get s :node)) segs)))))
; ============================================================
; Parse a dfn body (tokens between { and })
; Handles guard expressions: cond : expr
; ============================================================
(define
build-tree
(fn
(segs)
(cond
((= (len segs) 0) nil)
((= (len segs) 1) (get (first segs) :node))
((every? (fn (s) (= (get s :kind) "val")) segs)
(segs-to-array segs))
(true
(let
((fn-idx (find-first-fn segs)))
(cond
((= fn-idx -1) (segs-to-array segs))
((= fn-idx 0)
(list
:monad (get (first segs) :node)
(build-tree (rest segs))))
(true
(let
((left-segs (slice segs 0 fn-idx))
(fn-seg (nth segs fn-idx))
(right-segs (slice segs (+ fn-idx 1))))
(list
:dyad (get fn-seg :node)
(segs-to-array left-segs)
(build-tree right-segs))))))))))
(define
split-statements
(fn (tokens) (split-statements-loop tokens (list) (list) 0)))
(define
split-statements-loop
(fn
(tokens current-stmt acc depth)
(if
(= (len tokens) 0)
(if (> (len current-stmt) 0) (append acc (list current-stmt)) acc)
(let
((tok (first tokens))
(rest-toks (rest tokens))
(tt (tok-type (first tokens))))
(cond
((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
(split-statements-loop
rest-toks
(append current-stmt tok)
acc
(+ depth 1)))
((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
(split-statements-loop
rest-toks
(append current-stmt tok)
acc
(- depth 1)))
((and (> depth 0) (or (= tt :diamond) (= tt :newline)))
(split-statements-loop
rest-toks
(append current-stmt tok)
acc
depth))
((and (= depth 0) (or (= tt :diamond) (= tt :newline)))
(if
(> (len current-stmt) 0)
(split-statements-loop
rest-toks
(list)
(append acc (list current-stmt))
depth)
(split-statements-loop rest-toks (list) acc depth)))
(true
(split-statements-loop
rest-toks
(append current-stmt tok)
acc
depth)))))))
(define
parse-dfn
(fn
(tokens)
(let
((stmt-groups (split-statements tokens)))
(let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts)))))
; ============================================================
; Parse a single statement (assignment or expression)
; ============================================================
(define
parse-dfn-stmt
(fn
(tokens)
(let
((colon-idx (find-top-level-colon tokens 0)))
(if
(>= colon-idx 0)
(let
((cond-tokens (slice tokens 0 colon-idx))
(body-tokens (slice tokens (+ colon-idx 1))))
(list
:guard (parse-apl-expr cond-tokens)
(parse-apl-expr body-tokens)))
(parse-stmt tokens)))))
; ============================================================
; Parse an expression from a flat token list
; ============================================================
(define
find-top-level-colon
(fn (tokens i) (find-top-level-colon-loop tokens i 0)))
; ============================================================
; Main entry point
; parse-apl: string → AST
; ============================================================
(define
find-top-level-colon-loop
(fn
(tokens i depth)
(if
(>= i (len tokens))
-1
(let
((tok (nth tokens i)) (tt (tok-type (nth tokens i))))
(cond
((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
(find-top-level-colon-loop tokens (+ i 1) (+ depth 1)))
((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
(find-top-level-colon-loop tokens (+ i 1) (- depth 1)))
((and (= tt :colon) (= depth 0)) i)
(true (find-top-level-colon-loop tokens (+ i 1) depth)))))))
(define
parse-stmt
(fn
(tokens)
(if
(and
(>= (len tokens) 2)
(= (tok-type (nth tokens 0)) :name)
(= (tok-type (nth tokens 1)) :assign))
(list
:assign (tok-val (nth tokens 0))
(parse-apl-expr (slice tokens 2)))
(parse-apl-expr tokens))))
(define
parse-apl-expr
(fn
(tokens)
(let
((segs (collect-segments tokens)))
(if (= (len segs) 0) nil (build-tree segs)))))
(define
parse-apl
(fn
(src)
(let
((tokens (apl-tokenize src)))
(let
((stmt-groups (split-statements tokens)))
(begin
(apl-collect-fn-bindings stmt-groups)
(if
(= (len stmt-groups) 0)
nil
(if
(= (len stmt-groups) 1)
(parse-stmt (first stmt-groups))
(cons :program (map parse-stmt stmt-groups)))))))))
(define
split-bracket-loop
(fn
(tokens current acc depth)
(if
(= (len tokens) 0)
(append acc (list current))
(let
((tok (first tokens)) (more (rest tokens)))
(let
((tt (tok-type tok)))
(cond
((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
(split-bracket-loop
more
(append current (list tok))
acc
(+ depth 1)))
((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
(split-bracket-loop
more
(append current (list tok))
acc
(- depth 1)))
((and (= tt :semi) (= depth 0))
(split-bracket-loop
more
(list)
(append acc (list current))
depth))
(else
(split-bracket-loop more (append current (list tok)) acc depth))))))))
(define
split-bracket-content
(fn (tokens) (split-bracket-loop tokens (list) (list) 0)))
(define
maybe-bracket
(fn
(val-node tokens after)
(if
(and
(< after (len tokens))
(= (tok-type (nth tokens after)) :lbracket))
(let
((end (find-matching-close tokens (+ after 1) :lbracket :rbracket)))
(let
((inner-tokens (slice tokens (+ after 1) end))
(next-after (+ end 1)))
(let
((sections (split-bracket-content inner-tokens)))
(if
(= (len sections) 1)
(let
((idx-expr (parse-apl-expr inner-tokens)))
(let
((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
(maybe-bracket indexed tokens next-after)))
(let
((axis-exprs (map (fn (toks) (if (= (len toks) 0) :all (parse-apl-expr toks))) sections)))
(let
((indexed (cons :bracket (cons val-node axis-exprs))))
(maybe-bracket indexed tokens next-after)))))))
(list val-node after))))

1549
lib/apl/runtime.sx
View File

File diff suppressed because it is too large Load Diff

17
lib/apl/scoreboard.json
View File

@@ -1,17 +0,0 @@
{
"suites": {
"structural": {"pass": 94, "fail": 0},
"operators": {"pass": 117, "fail": 0},
"dfn": {"pass": 24, "fail": 0},
"tradfn": {"pass": 25, "fail": 0},
"valence": {"pass": 14, "fail": 0},
"programs": {"pass": 45, "fail": 0},
"system": {"pass": 13, "fail": 0},
"idioms": {"pass": 64, "fail": 0},
"eval-ops": {"pass": 14, "fail": 0},
"pipeline": {"pass": 40, "fail": 0}
},
"total_pass": 450,
"total_fail": 0,
"total": 450
}

22
lib/apl/scoreboard.md
View File

@@ -1,22 +0,0 @@
# APL Conformance Scoreboard
_Generated by `lib/apl/conformance.sh`_
| Suite | Pass | Fail | Total |
|-------|-----:|-----:|------:|
| structural | 94 | 0 | 94 |
| operators | 117 | 0 | 117 |
| dfn | 24 | 0 | 24 |
| tradfn | 25 | 0 | 25 |
| valence | 14 | 0 | 14 |
| programs | 45 | 0 | 45 |
| system | 13 | 0 | 13 |
| idioms | 64 | 0 | 64 |
| eval-ops | 14 | 0 | 14 |
| pipeline | 40 | 0 | 40 |
| **Total** | **450** | **0** | **450** |
## Notes
- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.
- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.

70
lib/apl/test.sh
View File

@@ -1,70 +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:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="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/r7rs.sx")
(load "lib/apl/runtime.sx")
(load "lib/apl/tokenizer.sx")
(load "lib/apl/parser.sx")
(load "lib/apl/transpile.sx")
(epoch 2)
(eval "(define apl-test-pass 0)")
(eval "(define apl-test-fail 0)")
(eval "(define apl-test-fails (list))")
(eval "(define apl-test (fn (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 {:name name :got got :expected expected})))))))")
(epoch 3)
(load "lib/apl/tests/structural.sx")
(load "lib/apl/tests/operators.sx")
(load "lib/apl/tests/dfn.sx")
(load "lib/apl/tests/tradfn.sx")
(load "lib/apl/tests/valence.sx")
(load "lib/apl/tests/programs.sx")
(load "lib/apl/tests/system.sx")
(load "lib/apl/tests/idioms.sx")
(load "lib/apl/tests/eval-ops.sx")
(load "lib/apl/tests/pipeline.sx")
(load "lib/apl/tests/programs-e2e.sx")
(epoch 4)
(eval "(list apl-test-pass apl-test-fail)")
EPOCHS
OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
if [ -z "$LINE" ]; then
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 4 //; 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 ]

227
lib/apl/tests/dfn.sx
View File

@@ -1,227 +0,0 @@
; Tests for apl-eval-ast and apl-call-dfn (manual AST construction).
(define rv (fn (arr) (get arr :ravel)))
(define sh (fn (arr) (get arr :shape)))
(define mknum (fn (n) (list :num n)))
(define mkname (fn (s) (list :name s)))
(define mkfg (fn (g) (list :fn-glyph g)))
(define mkmon (fn (g a) (list :monad (mkfg g) a)))
(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
(define mkdfn1 (fn (body) (list :dfn body)))
(define mkprog (fn (stmts) (cons :program stmts)))
(define mkasg (fn (mkname expr) (list :assign mkname expr)))
(define mkgrd (fn (c e) (list :guard c e)))
(define mkdfn (fn (stmts) (cons :dfn stmts)))
(apl-test
"eval :num literal"
(rv (apl-eval-ast (mknum 42) {}))
(list 42))
(apl-test
"eval :num literal shape"
(sh (apl-eval-ast (mknum 42) {}))
(list))
(apl-test
"eval :dyad +"
(rv (apl-eval-ast (mkdyd "+" (mknum 2) (mknum 3)) {}))
(list 5))
(apl-test
"eval :dyad ×"
(rv (apl-eval-ast (mkdyd "×" (mknum 6) (mknum 7)) {}))
(list 42))
(apl-test
"eval :monad - (negate)"
(rv (apl-eval-ast (mkmon "-" (mknum 7)) {}))
(list -7))
(apl-test
"eval :monad ⌊ (floor)"
(rv (apl-eval-ast (mkmon "⌊" (mknum 3)) {}))
(list 3))
(apl-test
"eval :name ⍵ from env"
(rv (apl-eval-ast (mkname "⍵") {:omega (apl-scalar 99) :alpha nil}))
(list 99))
(apl-test
"eval :name ⍺ from env"
(rv (apl-eval-ast (mkname "⍺") {:omega nil :alpha (apl-scalar 7)}))
(list 7))
(apl-test
"dfn {⍵+1} called monadic"
(rv
(apl-call-dfn-m
(mkdfn1 (mkdyd "+" (mkname "⍵") (mknum 1)))
(apl-scalar 5)))
(list 6))
(apl-test
"dfn {⍺+⍵} called dyadic"
(rv
(apl-call-dfn
(mkdfn1 (mkdyd "+" (mkname "⍺") (mkname "⍵")))
(apl-scalar 4)
(apl-scalar 9)))
(list 13))
(apl-test
"dfn {⍺×⍵} dyadic on vectors"
(rv
(apl-call-dfn
(mkdfn1 (mkdyd "×" (mkname "⍺") (mkname "⍵")))
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 10 40 90))
(apl-test
"dfn {-⍵} monadic negate"
(rv
(apl-call-dfn-m
(mkdfn1 (mkmon "-" (mkname "⍵")))
(make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"dfn {⍺-⍵} dyadic subtract scalar"
(rv
(apl-call-dfn
(mkdfn1 (mkdyd "-" (mkname "⍺") (mkname "⍵")))
(apl-scalar 10)
(apl-scalar 3)))
(list 7))
(apl-test
"dfn {⌈⍺,⍵} not used (just verify : missing) — ceiling of right"
(rv
(apl-call-dfn-m (mkdfn1 (mkmon "⌈" (mkname "⍵"))) (apl-scalar 5)))
(list 5))
(apl-test
"dfn nested dyad"
(rv
(apl-call-dfn
(mkdfn1
(mkdyd "+" (mkname "⍺") (mkdyd "×" (mkname "⍵") (mknum 2))))
(apl-scalar 1)
(apl-scalar 3)))
(list 7))
(apl-test
"dfn local assign x←⍵+1; ⍺×x"
(rv
(apl-call-dfn
(mkdfn
(list
(mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 1)))
(mkdyd "×" (mkname "⍺") (mkname "x"))))
(apl-scalar 3)
(apl-scalar 4)))
(list 15))
(apl-test
"dfn guard: 0=⍵:99; ⍵×2 (true branch)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99))
(mkdyd "×" (mkname "⍵") (mknum 2))))
(apl-scalar 0)))
(list 99))
(apl-test
"dfn guard: 0=⍵:99; ⍵×2 (false branch)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99))
(mkdyd "×" (mkname "⍵") (mknum 2))))
(apl-scalar 5)))
(list 10))
(apl-test
"dfn default ⍺←10 used (monadic call)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkasg "⍺" (mknum 10))
(mkdyd "+" (mkname "⍺") (mkname "⍵"))))
(apl-scalar 5)))
(list 15))
(apl-test
"dfn default ⍺←10 ignored when ⍺ given (dyadic call)"
(rv
(apl-call-dfn
(mkdfn
(list
(mkasg "⍺" (mknum 10))
(mkdyd "+" (mkname "⍺") (mkname "⍵"))))
(apl-scalar 100)
(apl-scalar 5)))
(list 105))
(apl-test
"dfn ∇ recursion: factorial via guard"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1))
(mkdyd
"×"
(mkname "⍵")
(mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1))))))
(apl-scalar 5)))
(list 120))
(apl-test
"dfn ∇ recursion: 3 → 6 (factorial)"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1))
(mkdyd
"×"
(mkname "⍵")
(mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1))))))
(apl-scalar 3)))
(list 6))
(apl-test
"dfn local: x←⍵+10; y←x×2; y"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 10)))
(mkasg "y" (mkdyd "×" (mkname "x") (mknum 2)))
(mkname "y")))
(apl-scalar 5)))
(list 30))
(apl-test
"dfn first guard wins: many guards"
(rv
(apl-call-dfn-m
(mkdfn
(list
(mkgrd (mkdyd "=" (mknum 1) (mkname "⍵")) (mknum 100))
(mkgrd (mkdyd "=" (mknum 2) (mkname "⍵")) (mknum 200))
(mkgrd (mkdyd "=" (mknum 3) (mkname "⍵")) (mknum 300))
(mknum 0)))
(apl-scalar 2)))
(list 200))

147
lib/apl/tests/eval-ops.sx
View File

@@ -1,147 +0,0 @@
; Tests for operator handling in apl-eval-ast (Phase 7).
; Manual AST construction; verifies :derived-fn / :outer / :derived-fn2
; route through apl-resolve-monadic / apl-resolve-dyadic correctly.
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
(define mknum (fn (n) (list :num n)))
(define mkfg (fn (g) (list :fn-glyph g)))
(define mkmon (fn (g a) (list :monad g a)))
(define mkdyd (fn (g l r) (list :dyad g l r)))
(define mkder (fn (op f) (list :derived-fn op f)))
(define mkdr2 (fn (op f g) (list :derived-fn2 op f g)))
(define mkout (fn (f) (list :outer "∘." f)))
; helper: literal vector AST via :vec (from list of values)
(define mkvec (fn (xs) (cons :vec (map (fn (n) (mknum n)) xs))))
; ---------- monadic operators ----------
(apl-test
"eval-ast +/ ⍳5 → 15"
(mkrv
(apl-eval-ast
(mkmon (mkder "/" (mkfg "+")) (mkmon (mkfg "⍳") (mknum 5)))
{}))
(list 15))
(apl-test
"eval-ast ×/ ⍳5 → 120"
(mkrv
(apl-eval-ast
(mkmon (mkder "/" (mkfg "×")) (mkmon (mkfg "⍳") (mknum 5)))
{}))
(list 120))
(apl-test
"eval-ast ⌈/ — max reduce"
(mkrv
(apl-eval-ast
(mkmon (mkder "/" (mkfg "⌈")) (mkvec (list 3 1 4 1 5 9 2 6)))
{}))
(list 9))
(apl-test
"eval-ast +\\ scan"
(mkrv
(apl-eval-ast
(mkmon (mkder "\\" (mkfg "+")) (mkvec (list 1 2 3 4 5)))
{}))
(list 1 3 6 10 15))
(apl-test
"eval-ast +⌿ first-axis reduce on vector"
(mkrv
(apl-eval-ast
(mkmon (mkder "⌿" (mkfg "+")) (mkvec (list 1 2 3 4 5)))
{}))
(list 15))
(apl-test
"eval-ast -¨ each-negate"
(mkrv
(apl-eval-ast
(mkmon (mkder "¨" (mkfg "-")) (mkvec (list 1 2 3 4)))
{}))
(list -1 -2 -3 -4))
(apl-test
"eval-ast +⍨ commute (double via x+x)"
(mkrv
(apl-eval-ast (mkmon (mkder "⍨" (mkfg "+")) (mknum 7)) {}))
(list 14))
; ---------- dyadic operators ----------
(apl-test
"eval-ast outer ∘.× — multiplication table"
(mkrv
(apl-eval-ast
(mkdyd
(mkout (mkfg "×"))
(mkvec (list 1 2 3))
(mkvec (list 1 2 3)))
{}))
(list 1 2 3 2 4 6 3 6 9))
(apl-test
"eval-ast outer ∘.× shape (3 3)"
(mksh
(apl-eval-ast
(mkdyd
(mkout (mkfg "×"))
(mkvec (list 1 2 3))
(mkvec (list 1 2 3)))
{}))
(list 3 3))
(apl-test
"eval-ast inner +.× — dot product"
(mkrv
(apl-eval-ast
(mkdyd
(mkdr2 "." (mkfg "+") (mkfg "×"))
(mkvec (list 1 2 3))
(mkvec (list 4 5 6)))
{}))
(list 32))
(apl-test
"eval-ast inner ∧.= equal vectors"
(mkrv
(apl-eval-ast
(mkdyd
(mkdr2 "." (mkfg "∧") (mkfg "="))
(mkvec (list 1 2 3))
(mkvec (list 1 2 3)))
{}))
(list 1))
(apl-test
"eval-ast each-dyadic +¨"
(mkrv
(apl-eval-ast
(mkdyd
(mkder "¨" (mkfg "+"))
(mkvec (list 1 2 3))
(mkvec (list 10 20 30)))
{}))
(list 11 22 33))
(apl-test
"eval-ast commute -⍨ (subtract swapped)"
(mkrv
(apl-eval-ast
(mkdyd (mkder "⍨" (mkfg "-")) (mknum 5) (mknum 3))
{}))
(list -2))
; ---------- nested operators ----------
(apl-test
"eval-ast +/¨ — sum of each"
(mkrv
(apl-eval-ast
(mkmon (mkder "/" (mkfg "+")) (mkvec (list 10 20 30)))
{}))
(list 60))

359
lib/apl/tests/idioms.sx
View File

@@ -1,359 +0,0 @@
; APL idiom corpus — classic Roger Hui / Phil Last idioms expressed
; through our runtime primitives. Each test names the APL one-liner
; and verifies the equivalent runtime call.
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
; ---------- reductions ----------
(apl-test
"+/⍵ — sum"
(mkrv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 15))
(apl-test
"(+/⍵)÷⍴⍵ — mean"
(mkrv
(apl-div
(apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5)))
(apl-scalar 5)))
(list 3))
(apl-test
"⌈/⍵ — max"
(mkrv (apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9))))
(list 9))
(apl-test
"⌊/⍵ — min"
(mkrv (apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9))))
(list 1))
(apl-test
"(⌈/⍵)-⌊/⍵ — range"
(mkrv
(apl-sub
(apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9)))
(apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9)))))
(list 8))
(apl-test
"×/⍵ — product"
(mkrv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4))))
(list 24))
(apl-test
"+\\⍵ — running sum"
(mkrv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 1 3 6 10 15))
; ---------- sort / order ----------
(apl-test
"⍵[⍋⍵] — sort ascending"
(mkrv (apl-quicksort (make-array (list 5) (list 3 1 4 1 5))))
(list 1 1 3 4 5))
(apl-test
"⌽⍵ — reverse"
(mkrv (apl-reverse (make-array (list 5) (list 1 2 3 4 5))))
(list 5 4 3 2 1))
(apl-test
"⊃⌽⍵ — last element"
(mkrv
(apl-disclose (apl-reverse (make-array (list 4) (list 10 20 30 40)))))
(list 40))
(apl-test
"1↑⍵ — first element"
(mkrv
(apl-take (apl-scalar 1) (make-array (list 4) (list 10 20 30 40))))
(list 10))
(apl-test
"1↓⍵ — drop first"
(mkrv
(apl-drop (apl-scalar 1) (make-array (list 4) (list 10 20 30 40))))
(list 20 30 40))
(apl-test
"¯1↓⍵ — drop last"
(mkrv
(apl-drop (apl-scalar -1) (make-array (list 4) (list 10 20 30 40))))
(list 10 20 30))
; ---------- counts / membership ----------
(apl-test
"≢⍵ — tally"
(mkrv (apl-tally (make-array (list 7) (list 9 8 7 6 5 4 3))))
(list 7))
(apl-test
"+/⍵=v — count occurrences of v"
(mkrv
(apl-reduce
apl-add
(apl-eq (make-array (list 7) (list 1 2 3 2 1 3 2)) (apl-scalar 2))))
(list 3))
(apl-test
"0=N|M — divisibility test"
(mkrv (apl-eq (apl-scalar 0) (apl-mod (apl-scalar 3) (apl-scalar 12))))
(list 1))
; ---------- shape constructors ----------
(apl-test
"N⍴1 — vector of N ones"
(mkrv (apl-reshape (apl-scalar 5) (apl-scalar 1)))
(list 1 1 1 1 1))
(apl-test
"(N N)⍴0 — N×N zero matrix"
(mkrv (apl-reshape (make-array (list 2) (list 3 3)) (apl-scalar 0)))
(list 0 0 0 0 0 0 0 0 0))
(apl-test
"⍳∘.=⍳ — N×N identity matrix"
(mkrv
(apl-outer apl-eq (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3))))
(list 1 0 0 0 1 0 0 0 1))
(apl-test
"⍳∘.×⍳ — multiplication table"
(mkrv
(apl-outer apl-mul (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3))))
(list 1 2 3 2 4 6 3 6 9))
; ---------- numerical idioms ----------
(apl-test
"+\\⍳N — triangular numbers"
(mkrv (apl-scan apl-add (apl-iota (apl-scalar 5))))
(list 1 3 6 10 15))
(apl-test
"+/⍳N=N×(N+1)÷2 — sum of 1..N"
(mkrv (apl-reduce apl-add (apl-iota (apl-scalar 10))))
(list 55))
(apl-test
"×/⍳N — factorial via iota"
(mkrv (apl-reduce apl-mul (apl-iota (apl-scalar 5))))
(list 120))
(apl-test
"2|⍵ — parity (1=odd)"
(mkrv (apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 0 1 0 1))
(apl-test
"+/2|⍵ — count odd"
(mkrv
(apl-reduce
apl-add
(apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5)))))
(list 3))
; ---------- boolean idioms ----------
(apl-test
"∧/⍵ — all-true"
(mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 1 1))))
(list 1))
(apl-test
"∧/⍵ — all-true with zero is false"
(mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 0 1))))
(list 0))
(apl-test
"∨/⍵ — any-true"
(mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 1 0))))
(list 1))
(apl-test
"∨/⍵ — any-true all zero is false"
(mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 0 0))))
(list 0))
; ---------- selection / scaling ----------
(apl-test
"⍵×⍵ — square each"
(mkrv
(apl-mul
(make-array (list 4) (list 1 2 3 4))
(make-array (list 4) (list 1 2 3 4))))
(list 1 4 9 16))
(apl-test
"+/⍵×⍵ — sum of squares"
(mkrv
(apl-reduce
apl-add
(apl-mul
(make-array (list 4) (list 1 2 3 4))
(make-array (list 4) (list 1 2 3 4)))))
(list 30))
(apl-test
"⍵-(+/⍵)÷⍴⍵ — mean-centered"
(mkrv
(apl-sub
(make-array (list 5) (list 2 4 6 8 10))
(apl-div
(apl-reduce apl-add (make-array (list 5) (list 2 4 6 8 10)))
(apl-scalar 5))))
(list -4 -2 0 2 4))
; ---------- shape / structure ----------
(apl-test
",⍵ — ravel"
(mkrv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"⍴⍴⍵ — rank"
(mkrv
(apl-shape (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6)))))
(list 2))
(apl-test
"src: +/⍳N → triangular(N)"
(mkrv (apl-run "+/⍳100"))
(list 5050))
(apl-test "src: ×/⍳N → N!" (mkrv (apl-run "×/⍳6")) (list 720))
(apl-test
"src: ⌈/V — max"
(mkrv (apl-run "⌈/3 1 4 1 5 9 2 6"))
(list 9))
(apl-test
"src: ⌊/V — min"
(mkrv (apl-run "⌊/3 1 4 1 5 9 2 6"))
(list 1))
(apl-test
"src: range = (⌈/V) - ⌊/V"
(mkrv (apl-run "(⌈/3 1 4 1 5 9 2 6) - ⌊/3 1 4 1 5 9 2 6"))
(list 8))
(apl-test
"src: +\\V — running sum"
(mkrv (apl-run "+\\1 2 3 4 5"))
(list 1 3 6 10 15))
(apl-test
"src: ×\\V — running product"
(mkrv (apl-run "×\\1 2 3 4 5"))
(list 1 2 6 24 120))
(apl-test
"src: V × V — squares"
(mkrv (apl-run "(⍳5) × ⍳5"))
(list 1 4 9 16 25))
(apl-test
"src: +/V × V — sum of squares"
(mkrv (apl-run "+/(⍳5) × ⍳5"))
(list 55))
(apl-test "src: ∧/V — all-true" (mkrv (apl-run "∧/1 1 1 1")) (list 1))
(apl-test "src: ∨/V — any-true" (mkrv (apl-run "∨/0 0 1 0")) (list 1))
(apl-test "src: 0 = N|M — divides" (mkrv (apl-run "0 = 3 | 12")) (list 1))
(apl-test
"src: 2 | V — parity"
(mkrv (apl-run "2 | 1 2 3 4 5 6"))
(list 1 0 1 0 1 0))
(apl-test
"src: +/2|V — count odd"
(mkrv (apl-run "+/2 | 1 2 3 4 5 6"))
(list 3))
(apl-test "src: ⍴ V" (mkrv (apl-run "⍴ 1 2 3 4 5")) (list 5))
(apl-test
"src: ⍴⍴ M — rank"
(mkrv (apl-run "⍴ ⍴ (2 3) ⍴ ⍳6"))
(list 2))
(apl-test
"src: N⍴1 — vector of ones"
(mkrv (apl-run "5 ⍴ 1"))
(list 1 1 1 1 1))
(apl-test
"src: ⍳N ∘.= ⍳N — identity matrix"
(mkrv (apl-run "(⍳3) ∘.= ⍳3"))
(list 1 0 0 0 1 0 0 0 1))
(apl-test
"src: ⍳N ∘.× ⍳N — multiplication table"
(mkrv (apl-run "(⍳3) ∘.× ⍳3"))
(list 1 2 3 2 4 6 3 6 9))
(apl-test
"src: V +.× V — dot product"
(mkrv (apl-run "1 2 3 +.× 4 5 6"))
(list 32))
(apl-test
"src: ∧.= V — vectors equal?"
(mkrv (apl-run "1 2 3 ∧.= 1 2 3"))
(list 1))
(apl-test
"src: V[1] — first element"
(mkrv (apl-run "(10 20 30 40)[1]"))
(list 10))
(apl-test
"src: 1↑V — first via take"
(mkrv (apl-run "1 ↑ 10 20 30 40"))
(list 10))
(apl-test
"src: 1↓V — drop first"
(mkrv (apl-run "1 ↓ 10 20 30 40"))
(list 20 30 40))
(apl-test
"src: ¯1↓V — drop last"
(mkrv (apl-run "¯1 ↓ 10 20 30 40"))
(list 10 20 30))
(apl-test
"src: ⌽V — reverse"
(mkrv (apl-run "⌽ 1 2 3 4 5"))
(list 5 4 3 2 1))
(apl-test
"src: ≢V — tally"
(mkrv (apl-run "≢ 9 8 7 6 5 4 3 2 1"))
(list 9))
(apl-test
"src: ,M — ravel"
(mkrv (apl-run ", (2 3) ⍴ ⍳6"))
(list 1 2 3 4 5 6))
(apl-test
"src: A=V — count occurrences"
(mkrv (apl-run "+/2 = 1 2 3 2 1 3 2"))
(list 3))
(apl-test
"src: ⌈/(V × V) — max squared"
(mkrv (apl-run "⌈/(1 2 3 4 5) × 1 2 3 4 5"))
(list 25))

791
lib/apl/tests/operators.sx
View File

@@ -1,791 +0,0 @@
(define rv (fn (arr) (get arr :ravel)))
(define sh (fn (arr) (get arr :shape)))
(apl-test
"reduce +/ vector"
(rv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 15))
(apl-test
"reduce x/ vector"
(rv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4))))
(list 24))
(apl-test
"reduce max/ vector"
(rv (apl-reduce apl-max (make-array (list 5) (list 3 1 4 1 5))))
(list 5))
(apl-test
"reduce min/ vector"
(rv (apl-reduce apl-min (make-array (list 3) (list 3 1 4))))
(list 1))
(apl-test
"reduce and/ all true"
(rv (apl-reduce apl-and (make-array (list 3) (list 1 1 1))))
(list 1))
(apl-test
"reduce or/ with true"
(rv (apl-reduce apl-or (make-array (list 3) (list 0 0 1))))
(list 1))
(apl-test
"reduce +/ single element"
(rv (apl-reduce apl-add (make-array (list 1) (list 42))))
(list 42))
(apl-test
"reduce +/ scalar no-op"
(rv (apl-reduce apl-add (apl-scalar 7)))
(list 7))
(apl-test
"reduce +/ shape is scalar"
(sh (apl-reduce apl-add (make-array (list 4) (list 1 2 3 4))))
(list))
(apl-test
"reduce +/ matrix row sums shape"
(sh (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2))
(apl-test
"reduce +/ matrix row sums values"
(rv (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 6 15))
(apl-test
"reduce max/ matrix row maxima"
(rv (apl-reduce apl-max (make-array (list 2 3) (list 3 1 4 1 5 9))))
(list 4 9))
(apl-test
"reduce-first +/ vector same as reduce"
(rv (apl-reduce-first apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 15))
(apl-test
"reduce-first +/ matrix col sums shape"
(sh
(apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3))
(apl-test
"reduce-first +/ matrix col sums values"
(rv
(apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 5 7 9))
(apl-test
"reduce-first max/ matrix col maxima"
(rv
(apl-reduce-first apl-max (make-array (list 3 2) (list 1 9 2 8 3 7))))
(list 3 9))
(apl-test
"scan +\\ vector"
(rv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 1 3 6 10 15))
(apl-test
"scan x\\ vector cumulative product"
(rv (apl-scan apl-mul (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 6 24 120))
(apl-test
"scan max\\ vector running max"
(rv (apl-scan apl-max (make-array (list 5) (list 3 1 4 1 5))))
(list 3 3 4 4 5))
(apl-test
"scan min\\ vector running min"
(rv (apl-scan apl-min (make-array (list 5) (list 3 1 4 1 5))))
(list 3 1 1 1 1))
(apl-test
"scan +\\ single element"
(rv (apl-scan apl-add (make-array (list 1) (list 42))))
(list 42))
(apl-test
"scan +\\ scalar no-op"
(rv (apl-scan apl-add (apl-scalar 7)))
(list 7))
(apl-test
"scan +\\ vector preserves shape"
(sh (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 5))
(apl-test
"scan +\\ matrix preserves shape"
(sh (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"scan +\\ matrix row-wise"
(rv (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 3 6 4 9 15))
(apl-test
"scan max\\ matrix row-wise running max"
(rv (apl-scan apl-max (make-array (list 2 3) (list 3 1 4 1 5 9))))
(list 3 3 4 1 5 9))
(apl-test
"scan-first +\\ vector same as scan"
(rv (apl-scan-first apl-add (make-array (list 5) (list 1 2 3 4 5))))
(list 1 3 6 10 15))
(apl-test
"scan-first +\\ scalar no-op"
(rv (apl-scan-first apl-add (apl-scalar 9)))
(list 9))
(apl-test
"scan-first +\\ matrix preserves shape"
(sh (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"scan-first +\\ matrix col-wise"
(rv (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 5 7 9))
(apl-test
"scan-first max\\ matrix col-wise running max"
(rv (apl-scan-first apl-max (make-array (list 3 2) (list 3 1 4 1 5 9))))
(list 3 1 4 1 5 9))
(apl-test
"each negate vector"
(rv (apl-each apl-neg-m (make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"each negate vector preserves shape"
(sh (apl-each apl-neg-m (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"each reciprocal vector"
(rv (apl-each apl-recip (make-array (list 3) (list 1 2 4))))
(list 1 (/ 1 2) (/ 1 4)))
(apl-test
"each abs vector"
(rv (apl-each apl-abs (make-array (list 4) (list -1 2 -3 4))))
(list 1 2 3 4))
(apl-test "each scalar" (rv (apl-each apl-neg-m (apl-scalar 5))) (list -5))
(apl-test
"each scalar shape"
(sh (apl-each apl-neg-m (apl-scalar 5)))
(list))
(apl-test
"each negate matrix shape"
(sh (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"each negate matrix values"
(rv (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list -1 -2 -3 -4 -5 -6))
(apl-test
"each-dyadic scalar+scalar"
(rv (apl-each-dyadic apl-add (apl-scalar 3) (apl-scalar 4)))
(list 7))
(apl-test
"each-dyadic scalar+vector"
(rv
(apl-each-dyadic
apl-add
(apl-scalar 10)
(make-array (list 3) (list 1 2 3))))
(list 11 12 13))
(apl-test
"each-dyadic vector+scalar"
(rv
(apl-each-dyadic
apl-add
(make-array (list 3) (list 1 2 3))
(apl-scalar 10)))
(list 11 12 13))
(apl-test
"each-dyadic vector+vector"
(rv
(apl-each-dyadic
apl-add
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 11 22 33))
(apl-test
"each-dyadic mul matrix+matrix shape"
(sh
(apl-each-dyadic
apl-mul
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 2 2) (list 5 6 7 8))))
(list 2 2))
(apl-test
"each-dyadic mul matrix+matrix values"
(rv
(apl-each-dyadic
apl-mul
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 2 2) (list 5 6 7 8))))
(list 5 12 21 32))
(apl-test
"outer product mult table values"
(rv
(apl-outer
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 1 2 3 2 4 6 3 6 9))
(apl-test
"outer product mult table shape"
(sh
(apl-outer
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 3 3))
(apl-test
"outer product add table values"
(rv
(apl-outer
apl-add
(make-array (list 2) (list 1 2))
(make-array (list 3) (list 10 20 30))))
(list 11 21 31 12 22 32))
(apl-test
"outer product add table shape"
(sh
(apl-outer
apl-add
(make-array (list 2) (list 1 2))
(make-array (list 3) (list 10 20 30))))
(list 2 3))
(apl-test
"outer product scalar+vector shape"
(sh
(apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"outer product scalar+vector values"
(rv
(apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3))))
(list 5 10 15))
(apl-test
"outer product vector+scalar shape"
(sh
(apl-outer apl-mul (make-array (list 3) (list 1 2 3)) (apl-scalar 10)))
(list 3))
(apl-test
"outer product scalar+scalar"
(rv (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7)))
(list 42))
(apl-test
"outer product scalar+scalar shape"
(sh (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7)))
(list))
(apl-test
"outer product equality identity matrix values"
(rv
(apl-outer
apl-eq
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 1 0 0 0 1 0 0 0 1))
(apl-test
"outer product matrix+vector rank doubling shape"
(sh
(apl-outer
apl-add
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 3) (list 10 20 30))))
(list 2 2 3))
(apl-test
"outer product matrix+vector rank doubling values"
(rv
(apl-outer
apl-add
(make-array (list 2 2) (list 1 2 3 4))
(make-array (list 3) (list 10 20 30))))
(list 11 21 31 12 22 32 13 23 33 14 24 34))
(apl-test
"inner +.× dot product"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 4 5 6))))
(list 32))
(apl-test
"inner +.× dot product shape is scalar"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 4 5 6))))
(list))
(apl-test
"inner +.× matrix multiply 2x3 * 3x2 shape"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 2) (list 7 8 9 10 11 12))))
(list 2 2))
(apl-test
"inner +.× matrix multiply 2x3 * 3x2 values"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 2) (list 7 8 9 10 11 12))))
(list 58 64 139 154))
(apl-test
"inner +.× identity matrix 2x2"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 2 2) (list 1 0 0 1))
(make-array (list 2 2) (list 5 6 7 8))))
(list 5 6 7 8))
(apl-test
"inner ∧.= equal vectors"
(rv
(apl-inner
apl-and
apl-eq
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list 1))
(apl-test
"inner ∧.= unequal vectors"
(rv
(apl-inner
apl-and
apl-eq
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 9 3))))
(list 0))
(apl-test
"inner +.× matrix * vector shape"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 7 8 9))))
(list 2))
(apl-test
"inner +.× matrix * vector values"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 7 8 9))))
(list 50 122))
(apl-test
"inner +.× vector * matrix shape"
(sh
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3 2) (list 4 5 6 7 8 9))))
(list 2))
(apl-test
"inner +.× vector * matrix values"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 3) (list 1 2 3))
(make-array (list 3 2) (list 4 5 6 7 8 9))))
(list 40 46))
(apl-test
"inner +.× single-element vectors"
(rv
(apl-inner
apl-add
apl-mul
(make-array (list 1) (list 6))
(make-array (list 1) (list 7))))
(list 42))
(apl-test
"commute +⍨ scalar doubles"
(rv (apl-commute apl-add (apl-scalar 5)))
(list 10))
(apl-test
"commute ×⍨ vector squares"
(rv (apl-commute apl-mul (make-array (list 4) (list 1 2 3 4))))
(list 1 4 9 16))
(apl-test
"commute +⍨ vector doubles"
(rv (apl-commute apl-add (make-array (list 3) (list 1 2 3))))
(list 2 4 6))
(apl-test
"commute +⍨ shape preserved"
(sh (apl-commute apl-add (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"commute ×⍨ matrix shape preserved"
(sh (apl-commute apl-mul (make-array (list 2 2) (list 1 2 3 4))))
(list 2 2))
(apl-test
"commute-dyadic -⍨ swaps subtraction"
(rv (apl-commute-dyadic apl-sub (apl-scalar 5) (apl-scalar 3)))
(list -2))
(apl-test
"commute-dyadic ÷⍨ swaps division"
(rv (apl-commute-dyadic apl-div (apl-scalar 4) (apl-scalar 12)))
(list 3))
(apl-test
"commute-dyadic -⍨ on vectors"
(rv
(apl-commute-dyadic
apl-sub
(make-array (list 3) (list 10 20 30))
(make-array (list 3) (list 1 2 3))))
(list -9 -18 -27))
(apl-test
"commute-dyadic +⍨ commutative same result"
(rv
(apl-commute-dyadic
apl-add
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 11 22 33))
(apl-test
"commute-dyadic ×⍨ commutative same result"
(rv
(apl-commute-dyadic
apl-mul
(make-array (list 3) (list 2 3 4))
(make-array (list 3) (list 5 6 7))))
(list 10 18 28))
(apl-test
"compose -∘| scalar (negative abs)"
(rv (apl-compose apl-neg-m apl-abs (apl-scalar -7)))
(list -7))
(apl-test
"compose -∘| vector"
(rv
(apl-compose apl-neg-m apl-abs (make-array (list 4) (list -1 2 -3 4))))
(list -1 -2 -3 -4))
(apl-test
"compose ⌊∘- (floor of negate)"
(rv (apl-compose apl-floor apl-neg-m (make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"compose -∘| matrix shape preserved"
(sh
(apl-compose apl-neg-m apl-abs (make-array (list 2 2) (list -1 2 -3 4))))
(list 2 2))
(apl-test
"compose-dyadic +∘- equals subtract scalar"
(rv (apl-compose-dyadic apl-add apl-neg-m (apl-scalar 10) (apl-scalar 3)))
(list 7))
(apl-test
"compose-dyadic +∘- equals subtract vector"
(rv
(apl-compose-dyadic
apl-add
apl-neg-m
(make-array (list 3) (list 10 20 30))
(make-array (list 3) (list 1 2 3))))
(list 9 18 27))
(apl-test
"compose-dyadic -∘| (subtract abs)"
(rv (apl-compose-dyadic apl-sub apl-abs (apl-scalar 10) (apl-scalar -3)))
(list 7))
(apl-test
"compose-dyadic ×∘- (multiply by negative)"
(rv
(apl-compose-dyadic
apl-mul
apl-neg-m
(make-array (list 3) (list 2 3 4))
(make-array (list 3) (list 1 2 3))))
(list -2 -6 -12))
(apl-test
"compose-dyadic shape preserved"
(sh
(apl-compose-dyadic
apl-add
apl-neg-m
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 2 3) (list 1 1 1 1 1 1))))
(list 2 3))
(apl-test
"power n=0 identity"
(rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 0 (apl-scalar 5)))
(list 5))
(apl-test
"power increment by 3"
(rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 3 (apl-scalar 0)))
(list 3))
(apl-test
"power double 4 times = 16"
(rv (apl-power (fn (a) (apl-mul a (apl-scalar 2))) 4 (apl-scalar 1)))
(list 16))
(apl-test
"power on vector +5"
(rv
(apl-power
(fn (a) (apl-add a (apl-scalar 1)))
5
(make-array (list 3) (list 1 2 3))))
(list 6 7 8))
(apl-test
"power on vector preserves shape"
(sh
(apl-power
(fn (a) (apl-add a (apl-scalar 1)))
5
(make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"power on matrix"
(rv
(apl-power
(fn (a) (apl-mul a (apl-scalar 3)))
2
(make-array (list 2 2) (list 1 2 3 4))))
(list 9 18 27 36))
(apl-test
"power-fixed identity stops immediately"
(rv (apl-power-fixed (fn (a) a) (make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"power-fixed floor half scalar to 0"
(rv
(apl-power-fixed
(fn (a) (apl-floor (apl-div a (apl-scalar 2))))
(apl-scalar 100)))
(list 0))
(apl-test
"power-fixed shape preserved"
(sh
(apl-power-fixed (fn (a) a) (make-array (list 2 2) (list 1 2 3 4))))
(list 2 2))
(apl-test
"rank tally⍤1 row tallies"
(rv (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 3))
(apl-test
"rank tally⍤1 row tallies shape"
(sh (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2))
(apl-test
"rank neg⍤0 vector scalar cells"
(rv (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3))))
(list -1 -2 -3))
(apl-test
"rank neg⍤0 vector preserves shape"
(sh (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3))))
(list 3))
(apl-test
"rank neg⍤1 matrix per-row"
(rv (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list -1 -2 -3 -4 -5 -6))
(apl-test
"rank neg⍤1 matrix preserves shape"
(sh (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"rank k>=rank fallthrough"
(rv (apl-rank apl-tally 5 (make-array (list 4) (list 1 2 3 4))))
(list 4))
(apl-test
"rank tally⍤2 whole matrix tally"
(rv
(apl-rank
apl-tally
2
(make-array (list 3 5) (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))))
(list 3))
(apl-test
"rank reverse⍤1 matrix reverse rows"
(rv (apl-rank apl-reverse 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2 1 6 5 4))
(apl-test
"rank tally⍤1 3x4 row tallies"
(rv
(apl-rank
apl-tally
1
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 4 4 4))
(apl-test
"at-replace single index"
(rv
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 2))
(make-array (list 5) (list 1 2 3 4 5))))
(list 1 99 3 4 5))
(apl-test
"at-replace multiple indices vector vals"
(rv
(apl-at-replace
(make-array (list 2) (list 99 88))
(make-array (list 2) (list 2 4))
(make-array (list 5) (list 1 2 3 4 5))))
(list 1 99 3 88 5))
(apl-test
"at-replace scalar broadcast"
(rv
(apl-at-replace
(apl-scalar 0)
(make-array (list 3) (list 1 3 5))
(make-array (list 5) (list 10 20 30 40 50))))
(list 0 20 0 40 0))
(apl-test
"at-replace preserves shape"
(sh
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 2))
(make-array (list 5) (list 1 2 3 4 5))))
(list 5))
(apl-test
"at-replace last index"
(rv
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 5))
(make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 99))
(apl-test
"at-replace on matrix linear-index"
(rv
(apl-at-replace
(apl-scalar 99)
(make-array (list 1) (list 3))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 99 4 5 6))
(apl-test
"at-apply negate at indices"
(rv
(apl-at-apply
apl-neg-m
(make-array (list 3) (list 1 3 5))
(make-array (list 5) (list 1 2 3 4 5))))
(list -1 2 -3 4 -5))
(apl-test
"at-apply double at index 1"
(rv
(apl-at-apply
(fn (a) (apl-mul a (apl-scalar 2)))
(make-array (list 1) (list 1))
(make-array (list 2) (list 5 10))))
(list 10 10))
(apl-test
"at-apply preserves shape"
(sh
(apl-at-apply
apl-neg-m
(make-array (list 2) (list 1 3))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"at-apply on matrix linear-index"
(rv
(apl-at-apply
apl-neg-m
(make-array (list 2) (list 1 6))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list -1 2 3 4 5 -6))

340
lib/apl/tests/parse.sx
View File

@@ -1,340 +0,0 @@
(define apl-test-count 0)
(define apl-test-pass 0)
(define apl-test-fails (list))
(define apl-test
(fn (name actual expected)
(begin
(set! apl-test-count (+ apl-test-count 1))
(if (= actual expected)
(set! apl-test-pass (+ apl-test-pass 1))
(append! apl-test-fails {:name name :actual actual :expected expected})))))
(define tok-types
(fn (src)
(map (fn (t) (get t :type)) (apl-tokenize src))))
(define tok-values
(fn (src)
(map (fn (t) (get t :value)) (apl-tokenize src))))
(define tok-count
(fn (src)
(len (apl-tokenize src))))
(define tok-type-at
(fn (src i)
(get (nth (apl-tokenize src) i) :type)))
(define tok-value-at
(fn (src i)
(get (nth (apl-tokenize src) i) :value)))
(apl-test "empty: no tokens" (tok-count "") 0)
(apl-test "empty: whitespace only" (tok-count " ") 0)
(apl-test "num: zero" (tok-values "0") (list 0))
(apl-test "num: positive" (tok-values "42") (list 42))
(apl-test "num: large" (tok-values "12345") (list 12345))
(apl-test "num: negative" (tok-values "¯5") (list -5))
(apl-test "num: negative zero" (tok-values "¯0") (list 0))
(apl-test "num: strand count" (tok-count "1 2 3") 3)
(apl-test "num: strand types" (tok-types "1 2 3") (list :num :num :num))
(apl-test "num: strand values" (tok-values "1 2 3") (list 1 2 3))
(apl-test "num: neg in strand" (tok-values "1 ¯2 3") (list 1 -2 3))
(apl-test "str: empty" (tok-values "''") (list ""))
(apl-test "str: single char" (tok-values "'a'") (list "a"))
(apl-test "str: word" (tok-values "'hello'") (list "hello"))
(apl-test "str: escaped quote" (tok-values "''''") (list "'"))
(apl-test "str: type" (tok-types "'abc'") (list :str))
(apl-test "name: simple" (tok-values "foo") (list "foo"))
(apl-test "name: type" (tok-types "foo") (list :name))
(apl-test "name: mixed case" (tok-values "MyVar") (list "MyVar"))
(apl-test "name: with digits" (tok-values "x1") (list "x1"))
(apl-test "name: system var" (tok-values "⎕IO") (list "⎕IO"))
(apl-test "name: system var type" (tok-types "⎕IO") (list :name))
(apl-test "glyph: plus" (tok-types "+") (list :glyph))
(apl-test "glyph: plus value" (tok-values "+") (list "+"))
(apl-test "glyph: iota" (tok-values "⍳") (list "⍳"))
(apl-test "glyph: reduce" (tok-values "+/") (list "+" "/"))
(apl-test "glyph: floor" (tok-values "⌊") (list "⌊"))
(apl-test "glyph: rho" (tok-values "⍴") (list "⍴"))
(apl-test "glyph: alpha omega" (tok-types "⍺ ⍵") (list :glyph :glyph))
(apl-test "punct: lparen" (tok-types "(") (list :lparen))
(apl-test "punct: rparen" (tok-types ")") (list :rparen))
(apl-test "punct: brackets" (tok-types "[42]") (list :lbracket :num :rbracket))
(apl-test "punct: braces" (tok-types "{}") (list :lbrace :rbrace))
(apl-test "punct: semi" (tok-types ";") (list :semi))
(apl-test "assign: arrow" (tok-types "x←1") (list :name :assign :num))
(apl-test "diamond: separator" (tok-types "1⋄2") (list :num :diamond :num))
(apl-test "newline: emitted" (tok-types "1\n2") (list :num :newline :num))
(apl-test "comment: skipped" (tok-count "⍝ ignore me") 0)
(apl-test "comment: rest ignored" (tok-count "1 ⍝ note") 1)
(apl-test "colon: bare" (tok-types ":") (list :colon))
(apl-test "keyword: If" (tok-values ":If") (list ":If"))
(apl-test "keyword: type" (tok-types ":While") (list :keyword))
(apl-test "keyword: EndFor" (tok-values ":EndFor") (list ":EndFor"))
(apl-test "expr: +/ ⍳ 5" (tok-types "+/ ⍳ 5") (list :glyph :glyph :glyph :num))
(apl-test "expr: x←42" (tok-count "x←42") 3)
(apl-test "expr: dfn body" (tok-types "{⍺+⍵}")
(list :lbrace :glyph :glyph :glyph :rbrace))
(define apl-tokenize-test-summary
(str "tokenizer " apl-test-pass "/" apl-test-count
(if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails))))
; ===========================================================================
; Parser tests
; ===========================================================================
; Helper: parse an APL source string and return the AST
(define parse
(fn (src) (parse-apl src)))
; Helper: build an expected AST node using keyword-tagged lists
(define num-node (fn (n) (list :num n)))
(define str-node (fn (s) (list :str s)))
(define name-node (fn (n) (list :name n)))
(define fn-node (fn (g) (list :fn-glyph g)))
(define fn-nm (fn (n) (list :fn-name n)))
(define assign-node (fn (nm expr) (list :assign nm expr)))
(define monad-node (fn (f a) (list :monad f a)))
(define dyad-node (fn (f l r) (list :dyad f l r)))
(define derived-fn (fn (op f) (list :derived-fn op f)))
(define derived-fn2 (fn (op f g) (list :derived-fn2 op f g)))
(define outer-node (fn (f) (list :outer "∘." f)))
(define guard-node (fn (c e) (list :guard c e)))
; ---- numeric literals ----
(apl-test "parse: num literal"
(parse "42")
(num-node 42))
(apl-test "parse: negative num"
(parse "¯3")
(num-node -3))
(apl-test "parse: zero"
(parse "0")
(num-node 0))
; ---- string literals ----
(apl-test "parse: str literal"
(parse "'hello'")
(str-node "hello"))
(apl-test "parse: empty str"
(parse "''")
(str-node ""))
; ---- name reference ----
(apl-test "parse: name"
(parse "x")
(name-node "x"))
(apl-test "parse: system name"
(parse "⎕IO")
(name-node "⎕IO"))
; ---- strands (vec nodes) ----
(apl-test "parse: strand 3 nums"
(parse "1 2 3")
(list :vec (num-node 1) (num-node 2) (num-node 3)))
(apl-test "parse: strand 2 nums"
(parse "1 2")
(list :vec (num-node 1) (num-node 2)))
(apl-test "parse: strand with negatives"
(parse "1 ¯2 3")
(list :vec (num-node 1) (num-node -2) (num-node 3)))
; ---- assignment ----
(apl-test "parse: assignment"
(parse "x←42")
(assign-node "x" (num-node 42)))
(apl-test "parse: assignment with spaces"
(parse "x ← 42")
(assign-node "x" (num-node 42)))
(apl-test "parse: assignment of expr"
(parse "r←2+3")
(assign-node "r" (dyad-node (fn-node "+") (num-node 2) (num-node 3))))
; ---- monadic functions ----
(apl-test "parse: monadic iota"
(parse "⍳5")
(monad-node (fn-node "⍳") (num-node 5)))
(apl-test "parse: monadic iota with space"
(parse "⍳ 5")
(monad-node (fn-node "⍳") (num-node 5)))
(apl-test "parse: monadic negate"
(parse "-3")
(monad-node (fn-node "-") (num-node 3)))
(apl-test "parse: monadic floor"
(parse "⌊2")
(monad-node (fn-node "⌊") (num-node 2)))
(apl-test "parse: monadic of name"
(parse "⍴x")
(monad-node (fn-node "⍴") (name-node "x")))
; ---- dyadic functions ----
(apl-test "parse: dyadic plus"
(parse "2+3")
(dyad-node (fn-node "+") (num-node 2) (num-node 3)))
(apl-test "parse: dyadic times"
(parse "2×3")
(dyad-node (fn-node "×") (num-node 2) (num-node 3)))
(apl-test "parse: dyadic with names"
(parse "x+y")
(dyad-node (fn-node "+") (name-node "x") (name-node "y")))
; ---- right-to-left evaluation ----
(apl-test "parse: right-to-left 2×3+4"
(parse "2×3+4")
(dyad-node (fn-node "×") (num-node 2)
(dyad-node (fn-node "+") (num-node 3) (num-node 4))))
(apl-test "parse: right-to-left chain"
(parse "1+2×3-4")
(dyad-node (fn-node "+") (num-node 1)
(dyad-node (fn-node "×") (num-node 2)
(dyad-node (fn-node "-") (num-node 3) (num-node 4)))))
; ---- parenthesized subexpressions ----
(apl-test "parse: parens override order"
(parse "(2+3)×4")
(dyad-node (fn-node "×")
(dyad-node (fn-node "+") (num-node 2) (num-node 3))
(num-node 4)))
(apl-test "parse: nested parens"
(parse "((2+3))")
(dyad-node (fn-node "+") (num-node 2) (num-node 3)))
(apl-test "parse: paren in dyadic right"
(parse "2×(3+4)")
(dyad-node (fn-node "×") (num-node 2)
(dyad-node (fn-node "+") (num-node 3) (num-node 4))))
; ---- operators → derived functions ----
(apl-test "parse: reduce +"
(parse "+/x")
(monad-node (derived-fn "/" (fn-node "+")) (name-node "x")))
(apl-test "parse: reduce iota"
(parse "+/⍳5")
(monad-node (derived-fn "/" (fn-node "+"))
(monad-node (fn-node "⍳") (num-node 5))))
(apl-test "parse: scan"
(parse "+\\x")
(monad-node (derived-fn "\\" (fn-node "+")) (name-node "x")))
(apl-test "parse: each"
(parse "⍳¨x")
(monad-node (derived-fn "¨" (fn-node "⍳")) (name-node "x")))
(apl-test "parse: commute"
(parse "-⍨3")
(monad-node (derived-fn "⍨" (fn-node "-")) (num-node 3)))
(apl-test "parse: stacked ops"
(parse "+/¨x")
(monad-node (derived-fn "¨" (derived-fn "/" (fn-node "+"))) (name-node "x")))
; ---- outer product ----
(apl-test "parse: outer product monadic"
(parse "∘.×")
(outer-node (fn-node "×")))
(apl-test "parse: outer product dyadic names"
(parse "x ∘.× y")
(dyad-node (outer-node (fn-node "×")) (name-node "x") (name-node "y")))
(apl-test "parse: outer product dyadic strands"
(parse "1 2 3 ∘.× 4 5 6")
(dyad-node (outer-node (fn-node "×"))
(list :vec (num-node 1) (num-node 2) (num-node 3))
(list :vec (num-node 4) (num-node 5) (num-node 6))))
; ---- inner product ----
(apl-test "parse: inner product"
(parse "+.×")
(derived-fn2 "." (fn-node "+") (fn-node "×")))
(apl-test "parse: inner product applied"
(parse "a +.× b")
(dyad-node (derived-fn2 "." (fn-node "+") (fn-node "×"))
(name-node "a") (name-node "b")))
; ---- dfn (anonymous function) ----
(apl-test "parse: simple dfn"
(parse "{⍺+⍵}")
(list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵"))))
(apl-test "parse: monadic dfn"
(parse "{⍵×2}")
(list :dfn (dyad-node (fn-node "×") (name-node "⍵") (num-node 2))))
(apl-test "parse: dfn self-ref"
(parse "{⍵≤1:1 ⋄ ⍵×∇ ⍵-1}")
(list :dfn
(guard-node (dyad-node (fn-node "≤") (name-node "⍵") (num-node 1)) (num-node 1))
(dyad-node (fn-node "×") (name-node "⍵")
(monad-node (fn-node "∇") (dyad-node (fn-node "-") (name-node "⍵") (num-node 1))))))
; ---- dfn applied ----
(apl-test "parse: dfn as function"
(parse "{⍺+⍵} 3")
(monad-node
(list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵")))
(num-node 3)))
; ---- multi-statement ----
(apl-test "parse: diamond separator"
(let ((result (parse "x←1 ⋄ x+2")))
(= (first result) :program))
true)
(apl-test "parse: diamond first stmt"
(let ((result (parse "x←1 ⋄ x+2")))
(nth result 1))
(assign-node "x" (num-node 1)))
(apl-test "parse: diamond second stmt"
(let ((result (parse "x←1 ⋄ x+2")))
(nth result 2))
(dyad-node (fn-node "+") (name-node "x") (num-node 2)))
; ---- combined summary ----
(define apl-parse-test-count (- apl-test-count 46))
(define apl-parse-test-pass (- apl-test-pass 46))
(define apl-test-summary
(str
"tokenizer 46/46 | "
"parser " apl-parse-test-pass "/" apl-parse-test-count
(if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails))))

687
lib/apl/tests/pipeline.sx
View File

@@ -1,687 +0,0 @@
; End-to-end pipeline tests: source string → tokenize → parse → eval-ast → array.
; Verifies the full stack as a single function call (apl-run).
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
; ---------- scalars ----------
(apl-test "apl-run \"42\" → scalar 42" (mkrv (apl-run "42")) (list 42))
(apl-test "apl-run \"¯7\" → scalar -7" (mkrv (apl-run "¯7")) (list -7))
; ---------- strands ----------
(apl-test
"apl-run \"1 2 3\" → vector"
(mkrv (apl-run "1 2 3"))
(list 1 2 3))
(apl-test "apl-run \"1 2 3\" shape" (mksh (apl-run "1 2 3")) (list 3))
; ---------- dyadic arithmetic ----------
(apl-test "apl-run \"2 + 3\" → 5" (mkrv (apl-run "2 + 3")) (list 5))
(apl-run "2 × 3 + 4") ; right-to-left
(apl-test
"apl-run \"2 × 3 + 4\" → 14 (right-to-left)"
(mkrv (apl-run "2 × 3 + 4"))
(list 14))
(apl-test
"apl-run \"1 2 3 + 4 5 6\" → 5 7 9"
(mkrv (apl-run "1 2 3 + 4 5 6"))
(list 5 7 9))
(apl-test
"apl-run \"3 × 1 2 3 4\" → scalar broadcast"
(mkrv (apl-run "3 × 1 2 3 4"))
(list 3 6 9 12))
; ---------- monadic primitives ----------
(apl-test
"apl-run \"⍳5\" → 1..5"
(mkrv (apl-run "⍳5"))
(list 1 2 3 4 5))
(apl-test
"apl-run \"-3\" → -3 (monadic negate)"
(mkrv (apl-run "-3"))
(list -3))
(apl-test
"apl-run \"⌈/ 1 3 9 5 7\" → 9 (max-reduce)"
(mkrv (apl-run "⌈/ 1 3 9 5 7"))
(list 9))
(apl-test
"apl-run \"⌊/ 4 7 2 9 1 3\" → 1 (min-reduce)"
(mkrv (apl-run "⌊/ 4 7 2 9 1 3"))
(list 1))
; ---------- operators ----------
(apl-test "apl-run \"+/⍳5\" → 15" (mkrv (apl-run "+/⍳5")) (list 15))
(apl-test "apl-run \"×/⍳5\" → 120" (mkrv (apl-run "×/⍳5")) (list 120))
(apl-test
"apl-run \"⌈/3 1 4 1 5 9 2\" → 9"
(mkrv (apl-run "⌈/3 1 4 1 5 9 2"))
(list 9))
(apl-test
"apl-run \"+\\\\⍳5\" → triangular numbers"
(mkrv (apl-run "+\\⍳5"))
(list 1 3 6 10 15))
; ---------- outer / inner products ----------
(apl-test
"apl-run \"1 2 3 ∘.× 1 2 3\" → mult table values"
(mkrv (apl-run "1 2 3 ∘.× 1 2 3"))
(list 1 2 3 2 4 6 3 6 9))
(apl-test
"apl-run \"1 2 3 +.× 4 5 6\" → dot product 32"
(mkrv (apl-run "1 2 3 +.× 4 5 6"))
(list 32))
; ---------- shape ----------
(apl-test
"apl-run \"⍴ 1 2 3 4 5\" → 5"
(mkrv (apl-run "⍴ 1 2 3 4 5"))
(list 5))
(apl-test "apl-run \"⍴⍳10\" → 10" (mkrv (apl-run "⍴⍳10")) (list 10))
; ---------- comparison ----------
(apl-test "apl-run \"3 < 5\" → 1" (mkrv (apl-run "3 < 5")) (list 1))
(apl-test "apl-run \"5 = 5\" → 1" (mkrv (apl-run "5 = 5")) (list 1))
(apl-test
"apl-run \"1 2 3 = 1 0 3\" → 1 0 1"
(mkrv (apl-run "1 2 3 = 1 0 3"))
(list 1 0 1))
; ---------- famous one-liners ----------
(apl-test
"apl-run \"+/(⍳10)\" → sum 1..10 = 55"
(mkrv (apl-run "+/(⍳10)"))
(list 55))
(apl-test
"apl-run \"×/⍳10\" → 10! = 3628800"
(mkrv (apl-run "×/⍳10"))
(list 3628800))
(apl-test "apl-run \"⎕IO\" → 1" (mkrv (apl-run "⎕IO")) (list 1))
(apl-test "apl-run \"⎕ML\" → 1" (mkrv (apl-run "⎕ML")) (list 1))
(apl-test "apl-run \"⎕FR\" → 1248" (mkrv (apl-run "⎕FR")) (list 1248))
(apl-test "apl-run \"⎕TS\" shape (7)" (mksh (apl-run "⎕TS")) (list 7))
(apl-test "apl-run \"⎕FMT 42\" → \"42\"" (apl-run "⎕FMT 42") "42")
(apl-test
"apl-run \"⎕FMT 1 2 3\" → \"1 2 3\""
(apl-run "⎕FMT 1 2 3")
"1 2 3")
(apl-test
"apl-run \"⎕FMT ⍳5\" → \"1 2 3 4 5\""
(apl-run "⎕FMT ⍳5")
"1 2 3 4 5")
(apl-test "apl-run \"⎕IO + 4\" → 5" (mkrv (apl-run "⎕IO + 4")) (list 5))
(apl-test
"apl-run \"(10 20 30 40 50)[3]\" → 30"
(mkrv (apl-run "(10 20 30 40 50)[3]"))
(list 30))
(apl-test
"apl-run \"(⍳10)[5]\" → 5"
(mkrv (apl-run "(⍳10)[5]"))
(list 5))
(apl-test
"apl-run \"A ← 100 200 300 ⋄ A[2]\" → 200"
(mkrv (apl-run "A ← 100 200 300 ⋄ A[2]"))
(list 200))
(apl-test
"apl-run \"V ← ⍳10 ⋄ V[3]\" → 3"
(mkrv (apl-run "V ← ⍳10 ⋄ V[3]"))
(list 3))
(apl-test
"apl-run \"(10 20 30)[1]\" → 10 (1-indexed)"
(mkrv (apl-run "(10 20 30)[1]"))
(list 10))
(apl-test
"apl-run \"V ← 10 20 30 40 50 ⋄ V[3] + 1\" → 31"
(mkrv (apl-run "V ← 10 20 30 40 50 ⋄ V[3] + 1"))
(list 31))
(apl-test
"apl-run \"(⍳5)[3] × 7\" → 21"
(mkrv (apl-run "(⍳5)[3] × 7"))
(list 21))
(apl-test "decimal: 3.7 → 3.7" (mkrv (apl-run "3.7")) (list 3.7))
(apl-test "decimal: ¯2.5 → -2.5" (mkrv (apl-run "¯2.5")) (list -2.5))
(apl-test "decimal: 1.5 + 2.5 → 4" (mkrv (apl-run "1.5 + 2.5")) (list 4))
(apl-test "decimal: ⌊3.7 → 3" (mkrv (apl-run "⌊ 3.7")) (list 3))
(apl-test "decimal: ⌈3.7 → 4" (mkrv (apl-run "⌈ 3.7")) (list 4))
(apl-test
"⎕← scalar passthrough"
(mkrv (apl-run "⎕← 42"))
(list 42))
(apl-test
"⎕← vector passthrough"
(mkrv (apl-run "⎕← 1 2 3"))
(list 1 2 3))
(apl-test
"string: 'abc' → 3-char vector"
(mkrv (apl-run "'abc'"))
(list "a" "b" "c"))
(apl-test "string: 'a' is rank-0 scalar" (mksh (apl-run "'a'")) (list))
(apl-test "string: 'hello' shape (5)" (mksh (apl-run "'hello'")) (list 5))
(apl-test
"named-fn: f ← {⍺+⍵} ⋄ 3 f 4 → 7"
(mkrv (apl-run "f ← {⍺+⍵} ⋄ 3 f 4"))
(list 7))
(apl-test
"named-fn monadic: sq ← {⍵×⍵} ⋄ sq 7 → 49"
(mkrv (apl-run "sq ← {⍵×⍵} ⋄ sq 7"))
(list 49))
(apl-test
"named-fn dyadic: hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4 → 25"
(mkrv (apl-run "hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4"))
(list 25))
(apl-test
"named-fn: dbl ← {⍵+⍵} ⋄ dbl ⍳5"
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ dbl ⍳5"))
(list 2 4 6 8 10))
(apl-test
"named-fn factorial via ∇ recursion"
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
(list 120))
(apl-test
"named-fn used twice in expr: dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"))
(list 14))
(apl-test
"named-fn with vector arg: neg ← {-⍵} ⋄ neg 1 2 3"
(mkrv (apl-run "neg ← {-⍵} ⋄ neg 1 2 3"))
(list -1 -2 -3))
(apl-test
"multi-axis: M[2;2] → center"
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[2;2]"))
(list 5))
(apl-test
"multi-axis: M[1;] → first row"
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
(list 1 2 3))
(apl-test
"multi-axis: M[;2] → second column"
(mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[;2]"))
(list 2 5 8))
(apl-test
"multi-axis: M[1 2;1 2] → 2x2 block"
(mkrv (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
(list 1 2 4 5))
(apl-test
"multi-axis: M[1 2;1 2] shape (2 2)"
(mksh (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
(list 2 2))
(apl-test
"multi-axis: M[;] full matrix"
(mkrv (apl-run "M ← (2 2) ⍴ 10 20 30 40 ⋄ M[;]"))
(list 10 20 30 40))
(apl-test
"multi-axis: M[1;] shape collapsed"
(mksh (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
(list 3))
(apl-test
"multi-axis: select all rows of column 3"
(mkrv (apl-run "M ← (4 3) ⍴ 1 2 3 4 5 6 7 8 9 10 11 12 ⋄ M[;3]"))
(list 3 6 9 12))
(apl-test
"train: mean = (+/÷≢) on 1..5"
(mkrv (apl-run "(+/÷≢) 1 2 3 4 5"))
(list 3))
(apl-test
"train: mean of 2 4 6 8 10"
(mkrv (apl-run "(+/÷≢) 2 4 6 8 10"))
(list 6))
(apl-test
"train 2-atop: (- ⌊) 5 → -5"
(mkrv (apl-run "(- ⌊) 5"))
(list -5))
(apl-test
"train 3-fork dyadic: 2(+×-)5 → -21"
(mkrv (apl-run "2 (+ × -) 5"))
(list -21))
(apl-test
"train: range = (⌈/-⌊/) on vector"
(mkrv (apl-run "(⌈/-⌊/) 3 1 4 1 5 9 2 6"))
(list 8))
(apl-test
"train: mean of ⍳10 has shape ()"
(mksh (apl-run "(+/÷≢) ⍳10"))
(list))
(apl-test
"compress: 1 0 1 0 1 / 10 20 30 40 50"
(mkrv (apl-run "1 0 1 0 1 / 10 20 30 40 50"))
(list 10 30 50))
(apl-test
"compress: empty mask → empty"
(mkrv (apl-run "0 0 0 / 1 2 3"))
(list))
(apl-test
"primes via classic idiom (multi-stmt)"
(mkrv (apl-run "P ← ⍳ 30 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"primes via classic idiom (n=20)"
(mkrv (apl-run "P ← ⍳ 20 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
(list 2 3 5 7 11 13 17 19))
(apl-test
"compress: filter even values"
(mkrv (apl-run "(0 = 2 | 1 2 3 4 5 6) / 1 2 3 4 5 6"))
(list 2 4 6))
(apl-test "inline-assign: x ← 5" (mkrv (apl-run "x ← 5")) (list 5))
(apl-test
"inline-assign: (2×x) + x←10 → 30"
(mkrv (apl-run "(2 × x) + x ← 10"))
(list 30))
(apl-test
"inline-assign primes one-liner: (2=+⌿0=a∘.|a)/a←⍳30"
(mkrv (apl-run "(2 = +⌿ 0 = a ∘.| a) / a ← ⍳ 30"))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"inline-assign: x is reusable — x + x ← 7 → 14"
(mkrv (apl-run "x + x ← 7"))
(list 14))
(apl-test
"inline-assign in dfn: f ← {x + x ← ⍵} ⋄ f 8 → 16"
(mkrv (apl-run "f ← {x + x ← ⍵} ⋄ f 8"))
(list 16))
(begin (apl-rng-seed! 42) nil)
(apl-test
"?10 with seed 42 → 8 (deterministic)"
(mkrv (apl-run "?10"))
(list 8))
(apl-test "?10 next call → 5" (mkrv (apl-run "?10")) (list 5))
(apl-test
"?100 stays in range"
(let ((v (first (mkrv (apl-run "?100"))))) (and (>= v 1) (<= v 100)))
true)
(begin (apl-rng-seed! 42) nil)
(apl-test
"?10 with re-seed 42 → 8 (reproducible)"
(mkrv (apl-run "?10"))
(list 8))
(apl-test
"apl-run-file: load primes.apl returns dfn AST"
(first (apl-run-file "lib/apl/tests/programs/primes.apl"))
:dfn)
(apl-test
"apl-run-file: life.apl parses without error"
(first (apl-run-file "lib/apl/tests/programs/life.apl"))
:dfn)
(apl-test
"apl-run-file: quicksort.apl parses without error"
(first (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
:dfn)
(apl-test
"apl-run-file: source-then-call returns primes count"
(mksh
(apl-run
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 30")))
(list 10))
(apl-test
"primes one-liner with ⍵-rebind: primes 30"
(mkrv
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 30"))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"primes one-liner: primes 50"
(mkrv
(apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 50"))
(list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
(apl-test
"primes.apl loaded + called via apl-run-file"
(mkrv
(apl-run
(str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 20")))
(list 2 3 5 7 11 13 17 19))
(apl-test
"primes.apl loaded — count of primes ≤ 100"
(first
(mksh
(apl-run
(str
(file-read "lib/apl/tests/programs/primes.apl")
" ⋄ primes 100"))))
25)
(apl-test
"⍉ monadic transpose 2x3 → 3x2"
(mkrv (apl-run "⍉ (2 3) ⍴ ⍳6"))
(list 1 4 2 5 3 6))
(apl-test
"⍉ transpose shape (3 2)"
(mksh (apl-run "⍉ (2 3) ⍴ ⍳6"))
(list 3 2))
(apl-test "⊢ monadic identity" (mkrv (apl-run "⊢ 1 2 3")) (list 1 2 3))
(apl-test
"5 ⊣ 1 2 3 → 5 (left)"
(mkrv (apl-run "5 ⊣ 1 2 3"))
(list 5))
(apl-test
"5 ⊢ 1 2 3 → 1 2 3 (right)"
(mkrv (apl-run "5 ⊢ 1 2 3"))
(list 1 2 3))
(apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")
(begin
(apl-test
"⍸ where: indices of truthy cells"
(mkrv (apl-run "⍸ 0 1 0 1 1"))
(list 2 4 5))
(apl-test
"⍸ where: leading truthy"
(mkrv (apl-run "⍸ 1 0 0 1 1"))
(list 1 4 5))
(apl-test
"⍸ where: all-zero → empty"
(mkrv (apl-run "⍸ 0 0 0"))
(list))
(apl-test
"⍸ where: all-truthy"
(mkrv (apl-run "⍸ 1 1 1"))
(list 1 2 3))
(apl-test
"⍸ where: ⎕IO=1 (1-based)"
(mkrv (apl-run "⍸ (⍳5)=3"))
(list 3))
(apl-test
"⍸ interval-index: 2 4 6 ⍸ 5 → 2"
(mkrv (apl-run "2 4 6 ⍸ 5"))
(list 2))
(apl-test
"⍸ interval-index: 2 4 6 ⍸ 1 3 5 6 7 → 0 1 2 3 3"
(mkrv (apl-run "2 4 6 ⍸ 1 3 5 6 7"))
(list 0 1 2 3 3))
(apl-test
"⍸ interval-index: ⍳5 ⍸ 3 → 3"
(mkrv (apl-run "(⍳5) ⍸ 3"))
(list 3))
(apl-test
"⍸ interval-index: y below all → 0"
(mkrv (apl-run "10 20 30 ⍸ 5"))
(list 0))
(apl-test
"⍸ interval-index: y above all → len breaks"
(mkrv (apl-run "10 20 30 ⍸ 100"))
(list 3)))
(begin
(apl-test
"∪ unique: dedup keeps first-occurrence order"
(mkrv (apl-run "∪ 1 2 1 3 2 1 4"))
(list 1 2 3 4))
(apl-test
"∪ unique: already-unique unchanged"
(mkrv (apl-run "∪ 5 4 3 2 1"))
(list 5 4 3 2 1))
(apl-test "∪ unique: scalar" (mkrv (apl-run "∪ 7")) (list 7))
(apl-test
"∪ unique: string mississippi → misp"
(mkrv (apl-run "∪ 'mississippi'"))
(list "m" "i" "s" "p"))
(apl-test
"∪ union: 1 2 3 ∪ 3 4 5 → 1 2 3 4 5"
(mkrv (apl-run "1 2 3 ∪ 3 4 5"))
(list 1 2 3 4 5))
(apl-test
"∪ union: dedups left side too"
(mkrv (apl-run "1 2 1 ∪ 1 3 2"))
(list 1 2 3))
(apl-test
"∪ union: disjoint → catenated"
(mkrv (apl-run "1 2 ∪ 3 4"))
(list 1 2 3 4))
(apl-test
"∩ intersection: 1 2 3 4 ∩ 2 4 6 → 2 4"
(mkrv (apl-run "1 2 3 4 ∩ 2 4 6"))
(list 2 4))
(apl-test
"∩ intersection: disjoint → empty"
(mkrv (apl-run "1 2 3 ∩ 4 5 6"))
(list))
(apl-test
"∩ intersection: preserves left order"
(mkrv (apl-run "(⍳5) ∩ 5 3 1"))
(list 1 3 5))
(apl-test
"∩ intersection: identical"
(mkrv (apl-run "1 2 3 ∩ 1 2 3"))
(list 1 2 3))
(apl-test
"∪/∩ identity: A ∪ A = ∪A"
(mkrv (apl-run "1 2 1 ∪ 1 2 1"))
(list 1 2)))
(begin
(apl-test
"⊥ decode: 2 2 2 ⊥ 1 0 1 → 5"
(mkrv (apl-run "2 2 2 ⊥ 1 0 1"))
(list 5))
(apl-test
"⊥ decode: 10 10 10 ⊥ 1 2 3 → 123"
(mkrv (apl-run "10 10 10 ⊥ 1 2 3"))
(list 123))
(apl-test
"⊥ decode: 24 60 60 ⊥ 2 3 4 → 7384 (mixed-radix HMS)"
(mkrv (apl-run "24 60 60 ⊥ 2 3 4"))
(list 7384))
(apl-test
"⊥ decode: scalar base 2 ⊥ 1 0 1 0 → 10"
(mkrv (apl-run "2 ⊥ 1 0 1 0"))
(list 10))
(apl-test
"⊥ decode: 16 16 ⊥ 15 15 → 255"
(mkrv (apl-run "16 16 ⊥ 15 15"))
(list 255))
(apl-test
"⊤ encode: 2 2 2 ⊤ 5 → 1 0 1"
(mkrv (apl-run "2 2 2 ⊤ 5"))
(list 1 0 1))
(apl-test
"⊤ encode: 24 60 60 ⊤ 7384 → 2 3 4 (HMS)"
(mkrv (apl-run "24 60 60 ⊤ 7384"))
(list 2 3 4))
(apl-test
"⊤ encode: 2 2 2 2 ⊤ 13 → 1 1 0 1"
(mkrv (apl-run "2 2 2 2 ⊤ 13"))
(list 1 1 0 1))
(apl-test
"⊤ encode: 10 10 ⊤ 42 → 4 2"
(mkrv (apl-run "10 10 ⊤ 42"))
(list 4 2))
(apl-test
"⊤ encode: round-trip B⊥(B⊤N) = N"
(mkrv (apl-run "24 60 60 ⊥ 24 60 60 ⊤ 7384"))
(list 7384))
(apl-test
"⊥ decode: round-trip B⊤(B⊥V) = V"
(mkrv (apl-run "2 2 2 ⊤ 2 2 2 ⊥ 1 0 1"))
(list 1 0 1)))
(begin
(define
mk-parts
(fn (s) (map (fn (p) (get p :ravel)) (get (apl-run s) :ravel))))
(apl-test
"⊆ partition: 1 1 0 1 1 ⊆ 'abcde' → ('ab' 'de')"
(mk-parts "1 1 0 1 1 ⊆ 'abcde'")
(list (list "a" "b") (list "d" "e")))
(apl-test
"⊆ partition: 1 0 0 1 1 ⊆ ⍳5 → ((1) (4 5))"
(mk-parts "1 0 0 1 1 ⊆ ⍳5")
(list (list 1) (list 4 5)))
(apl-test
"⊆ partition: all-zero mask → empty"
(len (get (apl-run "0 0 0 ⊆ 1 2 3") :ravel))
0)
(apl-test
"⊆ partition: all-one mask → single partition"
(mk-parts "1 1 1 ⊆ 7 8 9")
(list (list 7 8 9)))
(apl-test
"⊆ partition: strict increase 1 2 starts new"
(mk-parts "1 2 ⊆ 10 20")
(list (list 10) (list 20)))
(apl-test
"⊆ partition: same level continues 2 2 → one partition"
(mk-parts "2 2 ⊆ 10 20")
(list (list 10 20)))
(apl-test
"⊆ partition: 0 separates"
(mk-parts "1 1 0 0 1 ⊆ 1 2 3 4 5")
(list (list 1 2) (list 5)))
(apl-test
"⊆ partition: outer length matches partition count"
(len (get (apl-run "1 0 1 0 1 ⊆ ⍳5") :ravel))
3))
(begin
(apl-test
"⍎ execute: ⍎ '1 + 2' → 3"
(mkrv (apl-run "⍎ '1 + 2'"))
(list 3))
(apl-test
"⍎ execute: ⍎ '+/⍳10' → 55"
(mkrv (apl-run "⍎ '+/⍳10'"))
(list 55))
(apl-test
"⍎ execute: ⍎ '⌈/ 1 3 9 5 7' → 9"
(mkrv (apl-run "⍎ '⌈/ 1 3 9 5 7'"))
(list 9))
(apl-test
"⍎ execute: ⍎ '⍳5' → 1..5"
(mkrv (apl-run "⍎ '⍳5'"))
(list 1 2 3 4 5))
(apl-test
"⍎ execute: ⍎ '×/⍳5' → 120"
(mkrv (apl-run "⍎ '×/⍳5'"))
(list 120))
(apl-test
"⍎ execute: round-trip ⍎ ⎕FMT 42 → 42"
(mkrv (apl-run "⍎ ⎕FMT 42"))
(list 42))
(apl-test
"⍎ execute: nested ⍎ ⍎"
(mkrv (apl-run "⍎ '⍎ ''2 × 3'''"))
(list 6))
(apl-test
"⍎ execute: with assignment side-effect"
(mkrv (apl-run "⍎ 'q ← 99 ⋄ q + 1'"))
(list 100)))
(begin
(apl-test
"het-inner: 1 ⍵ ∨.∧ X — result is enclosed (5 5)"
(let
((r (apl-run "B ← 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 ⋄ X ← 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂B ⋄ 1 B ∨.∧ X")))
(list
(len (get r :shape))
(= (type-of (first (get r :ravel))) "dict")))
(list 0 true))
(apl-test
"het-inner: ⊃ unwraps to (5 5) board"
(mksh
(apl-run
"B ← 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 ⋄ X ← 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂B ⋄ ⊃ 1 B ∨.∧ X"))
(list 5 5))
(apl-test
"het-inner: homogeneous inner product unaffected"
(mkrv (apl-run "1 2 3 +.× 4 5 6"))
(list 32))
(apl-test
"het-inner: matrix inner product unaffected"
(mkrv (apl-run "(2 2 ⍴ 1 2 3 4) +.× 2 2 ⍴ 5 6 7 8"))
(list 19 22 43 50)))

189
lib/apl/tests/programs-e2e.sx
View File

@@ -1,189 +0,0 @@
; End-to-end tests of the classic-program archetypes — running APL
; source through the full pipeline (tokenize → parse → eval-ast → runtime).
;
; These mirror the algorithms documented in lib/apl/tests/programs/*.apl
; but use forms our pipeline supports today (named functions instead of
; the inline ⍵← rebinding idiom; multi-stmt over single one-liners).
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
; ---------- factorial via ∇ recursion (cf. n-queens style) ----------
(apl-test
"e2e: factorial 5! = 120"
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
(list 120))
(apl-test
"e2e: factorial 7! = 5040"
(mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 7"))
(list 5040))
(apl-test
"e2e: factorial via ×/⍳N (no recursion)"
(mkrv (apl-run "fact ← {×/⍳⍵} ⋄ fact 6"))
(list 720))
; ---------- sum / triangular numbers (sum-1..N) ----------
(apl-test
"e2e: triangular(10) = 55"
(mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 10"))
(list 55))
(apl-test
"e2e: triangular(100) = 5050"
(mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 100"))
(list 5050))
; ---------- sum of squares ----------
(apl-test
"e2e: sum-of-squares 1..5 = 55"
(mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳5"))
(list 55))
(apl-test
"e2e: sum-of-squares 1..10 = 385"
(mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳10"))
(list 385))
; ---------- divisor-counting (prime-sieve building blocks) ----------
(apl-test
"e2e: divisor counts 1..5 via outer mod"
(mkrv (apl-run "P ← ⍳ 5 ⋄ +⌿ 0 = P ∘.| P"))
(list 1 2 2 3 2))
(apl-test
"e2e: divisor counts 1..10"
(mkrv (apl-run "P ← ⍳ 10 ⋄ +⌿ 0 = P ∘.| P"))
(list 1 2 2 3 2 4 2 4 3 4))
(apl-test
"e2e: prime-mask 1..10 (count==2)"
(mkrv (apl-run "P ← ⍳ 10 ⋄ 2 = +⌿ 0 = P ∘.| P"))
(list 0 1 1 0 1 0 1 0 0 0))
; ---------- monadic primitives chained ----------
(apl-test
"e2e: sum of |abs| = 15"
(mkrv (apl-run "+/|¯1 ¯2 ¯3 ¯4 ¯5"))
(list 15))
(apl-test
"e2e: max of squares 1..6"
(mkrv (apl-run "⌈/(⍳6)×⍳6"))
(list 36))
; ---------- nested named functions ----------
(apl-test
"e2e: compose dbl and sq via two named fns"
(mkrv (apl-run "dbl ← {⍵+⍵} ⋄ sq ← {⍵×⍵} ⋄ sq dbl 3"))
(list 36))
(apl-test
"e2e: max-of-two as named dyadic fn"
(mkrv (apl-run "mx ← {⍺⌈⍵} ⋄ 5 mx 3"))
(list 5))
(apl-test
"e2e: sqrt-via-newton 1 step from 1 → 2.5"
(mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1"))
(list 2.5))
(begin
(apl-test
"life.apl: blinker 5×5 → vertical blinker"
(mkrv
(apl-run
"life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0"))
(list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))
(apl-test
"life.apl: blinker oscillates (period 2)"
(mkrv
(apl-run
"life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life life 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0"))
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life.apl: 2×2 block stable"
(mkrv
(apl-run
"life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 4 4 ⍴ 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 0"))
(list 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 0))
(apl-test
"life.apl: empty grid stays empty"
(mkrv
(apl-run
"life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 5 5 ⍴ 0"))
(list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life.apl: source-file as-written runs"
(let
((dfn (apl-run-file "lib/apl/tests/programs/life.apl"))
(board
(apl-run "5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0")))
(get (apl-call-dfn-m dfn board) :ravel))
(list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0)))
(begin
(apl-test
"quicksort.apl: 11-element with duplicates"
(begin
(apl-rng-seed! 42)
(mkrv
(apl-run
"quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 3 1 4 1 5 9 2 6 5 3 5")))
(list 1 1 2 3 3 4 5 5 5 6 9))
(apl-test
"quicksort.apl: already sorted"
(begin
(apl-rng-seed! 42)
(mkrv
(apl-run
"quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 1 2 3 4 5")))
(list 1 2 3 4 5))
(apl-test
"quicksort.apl: reverse sorted"
(begin
(apl-rng-seed! 42)
(mkrv
(apl-run
"quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 5 4 3 2 1")))
(list 1 2 3 4 5))
(apl-test
"quicksort.apl: all equal"
(begin
(apl-rng-seed! 42)
(mkrv
(apl-run
"quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 7 7 7 7")))
(list 7 7 7 7))
(apl-test
"quicksort.apl: single element"
(begin
(apl-rng-seed! 42)
(mkrv
(apl-run
"quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort ,42")))
(list 42))
(apl-test
"quicksort.apl: matches grade-up"
(begin
(apl-rng-seed! 42)
(mkrv
(apl-run
"V ← 8 3 1 9 2 7 5 6 4 ⋄ quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort V")))
(list 1 2 3 4 5 6 7 8 9))
(apl-test
"quicksort.apl: source-file as-written runs"
(begin
(apl-rng-seed! 42)
(let
((dfn (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
(vec (apl-run "5 2 8 1 9 3 7 4 6")))
(get (apl-call-dfn-m dfn vec) :ravel)))
(list 1 2 3 4 5 6 7 8 9)))

304
lib/apl/tests/programs.sx
View File

@@ -1,304 +0,0 @@
; Tests for classic APL programs (lib/apl/tests/programs/*.apl).
; Programs are showcase APL source; runtime impl is in lib/apl/runtime.sx.
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
; ===== primes (Sieve of Eratosthenes) =====
(apl-test "primes 1 → empty" (mkrv (apl-primes 1)) (list))
(apl-test "primes 2 → just 2" (mkrv (apl-primes 2)) (list 2))
(apl-test "primes 10 → 2 3 5 7" (mkrv (apl-primes 10)) (list 2 3 5 7))
(apl-test
"primes 20 → 2 3 5 7 11 13 17 19"
(mkrv (apl-primes 20))
(list 2 3 5 7 11 13 17 19))
(apl-test
"primes 30"
(mkrv (apl-primes 30))
(list 2 3 5 7 11 13 17 19 23 29))
(apl-test
"primes 50"
(mkrv (apl-primes 50))
(list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
(apl-test "primes 7 length" (first (mksh (apl-primes 7))) 4)
(apl-test "primes 100 has 25 primes" (first (mksh (apl-primes 100))) 25)
; ===== compress helper sanity =====
(apl-test
"compress 1 0 1 0 1 / 10 20 30 40 50"
(mkrv
(apl-compress
(make-array (list 5) (list 1 0 1 0 1))
(make-array (list 5) (list 10 20 30 40 50))))
(list 10 30 50))
(apl-test
"compress all-zero mask → empty"
(mkrv
(apl-compress
(make-array (list 3) (list 0 0 0))
(make-array (list 3) (list 1 2 3))))
(list))
(apl-test
"compress all-one mask → full vector"
(mkrv
(apl-compress
(make-array (list 3) (list 1 1 1))
(make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"life: empty 5x5 stays empty"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: horizontal blinker → vertical blinker"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))
(apl-test
"life: vertical blinker → horizontal blinker"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: blinker has period 2"
(mkrv
(apl-life-step
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))))
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: 2x2 block stable on 5x5"
(mkrv
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0))))
(list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0))
(apl-test
"life: shape preserved"
(mksh
(apl-life-step
(make-array
(list 5 5)
(list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))))
(list 5 5))
(apl-test
"life: glider on 6x6 advances"
(mkrv
(apl-life-step
(make-array
(list 6 6)
(list
0
0
0
0
0
0
0
0
1
0
0
0
0
0
0
1
0
0
0
1
1
1
0
0
0
0
0
0
0
0
0
0
0
0
0
0))))
(list
0
0
0
0
0
0
0
0
0
0
0
0
0
1
0
1
0
0
0
0
1
1
0
0
0
0
1
0
0
0
0
0
0
0
0
0))
(apl-test
"mandelbrot c=0 stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0)) 100))
(list 100))
(apl-test
"mandelbrot c=-1 cycle bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1)) 100))
(list 100))
(apl-test
"mandelbrot c=-2 boundary stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list -2)) 100))
(list 100))
(apl-test
"mandelbrot c=0.25 boundary stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.25)) 100))
(list 100))
(apl-test
"mandelbrot c=1 escapes at iter 3"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 1)) 100))
(list 3))
(apl-test
"mandelbrot c=0.5 escapes at iter 5"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.5)) 100))
(list 5))
(apl-test
"mandelbrot batched grid (rank-polymorphic)"
(mkrv (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10))
(list 10 10 10 3 2))
(apl-test
"mandelbrot batched preserves shape"
(mksh (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10))
(list 5))
(apl-test
"mandelbrot c=-1.5 stays bounded"
(mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1.5)) 100))
(list 100))
(apl-test "queens 1 → 1 solution" (mkrv (apl-queens 1)) (list 1))
(apl-test "queens 2 → 0 solutions" (mkrv (apl-queens 2)) (list 0))
(apl-test "queens 3 → 0 solutions" (mkrv (apl-queens 3)) (list 0))
(apl-test "queens 4 → 2 solutions" (mkrv (apl-queens 4)) (list 2))
(apl-test "queens 5 → 10 solutions" (mkrv (apl-queens 5)) (list 10))
(apl-test "queens 6 → 4 solutions" (mkrv (apl-queens 6)) (list 4))
(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
(apl-test
"quicksort empty"
(mkrv (apl-quicksort (make-array (list 0) (list))))
(list))
(apl-test
"quicksort single"
(mkrv (apl-quicksort (make-array (list 1) (list 42))))
(list 42))
(apl-test
"quicksort already sorted"
(mkrv (apl-quicksort (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5))
(apl-test
"quicksort reverse sorted"
(mkrv (apl-quicksort (make-array (list 5) (list 5 4 3 2 1))))
(list 1 2 3 4 5))
(apl-test
"quicksort with duplicates"
(mkrv (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2))))
(list 1 1 2 3 4 5 9))
(apl-test
"quicksort all equal"
(mkrv (apl-quicksort (make-array (list 5) (list 7 7 7 7 7))))
(list 7 7 7 7 7))
(apl-test
"quicksort negatives"
(mkrv (apl-quicksort (make-array (list 5) (list -3 1 -1 2 0))))
(list -3 -1 0 1 2))
(apl-test
"quicksort 11-element pi"
(mkrv
(apl-quicksort (make-array (list 11) (list 3 1 4 1 5 9 2 6 5 3 5))))
(list 1 1 2 3 3 4 5 5 5 6 9))
(apl-test
"quicksort preserves length"
(first
(mksh (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2)))))
7)

22
lib/apl/tests/programs/life.apl
View File

@@ -1,22 +0,0 @@
⍝ Conway's Game of Life — toroidal one-liner
⍝
⍝ The classic Roger Hui formulation:
⍝ life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵}
⍝
⍝ Read right-to-left:
⍝ ⊂⍵ : enclose the board (so it's a single scalar item)
⍝ ¯1 0 1 ⌽¨ ⊂⍵ : produce 3 horizontally-shifted copies
⍝ ¯1 0 1 ∘.⊖ … : outer-product with vertical shifts → 3×3 = 9 shifts
⍝ +/ +/ … : sum the 9 boards element-wise → neighbor-count + self
⍝ 3 4 = … : leading-axis-extended boolean — count is 3 (born) or 4 (survive)
⍝ 1 ⍵ ∨.∧ … : "alive next" iff (count=3) or (alive AND count=4)
⍝ ⊃ … : disclose the enclosed result back to a 2D board
⍝
⍝ Rules in plain language:
⍝ - dead cell + 3 live neighbors → born
⍝ - live cell + 2 or 3 live neighbors → survives
⍝ - all else → dies
⍝
⍝ Toroidal: edges wrap (rotate is cyclic).
life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵}

29
lib/apl/tests/programs/mandelbrot.apl
View File

@@ -1,29 +0,0 @@
⍝ Mandelbrot — real-axis subset
⍝
⍝ For complex c, the Mandelbrot set is { c : |z_n| stays bounded } where
⍝ z_0 = 0, z_{n+1} = z_n² + c.
⍝ Restricting c (and z) to ℝ gives the segment c ∈ [-2, 1/4]
⍝ where the iteration stays bounded.
⍝
⍝ Rank-polymorphic batched-iteration form:
⍝ mandelbrot ← {⍵ ⍵⍵ ⍺⍺ +,(⍺⍺ × ⍺⍺) }
⍝
⍝ Pseudocode (as we don't have ⎕ system fns yet):
⍝ z ← 0×c ⍝ start at zero
⍝ alive ← 1+0×c ⍝ all "still in"
⍝ for k iterations:
⍝ alive ← alive ∧ 4 ≥ z×z ⍝ still bounded?
⍝ z ← alive × c + z×z ⍝ freeze escaped via mask
⍝ count ← count + alive ⍝ tally surviving iters
⍝
⍝ Examples (count after 100 iterations):
⍝ c=0 : 100 (z stays at 0)
⍝ c=-1 : 100 (cycles 0,-1,0,-1,...)
⍝ c=-2 : 100 (settles at 2 — boundary)
⍝ c=0.25 : 100 (boundary — converges to 0.5)
⍝ c=0.5 : 5 (escapes by iteration 6)
⍝ c=1 : 3 (escapes quickly)
⍝
⍝ Real-axis Mandelbrot set: bounded for c ∈ [-2, 0.25].
mandelbrot ← {z←alive←count←0×⍵ ⋄ {alive←alive∧4≥z×z ⋄ z←alive×⍵+z×z ⋄ count+←alive}⍣⍺⊢⍵}

18
lib/apl/tests/programs/n-queens.apl
View File

@@ -1,18 +0,0 @@
⍝ N-Queens — count solutions to placing N non-attacking queens on N×N
⍝
⍝ A solution is encoded as a permutation P of 1..N where P[i] is the
⍝ column of the queen in row i. Rows and columns are then automatically
⍝ unique (it's a permutation). We must additionally rule out queens
⍝ sharing a diagonal: |i-j| = |P[i]-P[j]| for any pair.
⍝
⍝ Backtracking via reduce — the classic Roger Hui style:
⍝ queens ← {≢{⍵,¨⍨↓(0=∊(¨⍳⍴⍵)≠.+|⍵)/⍳⍴⍵}/(⍳⍵)⍴⊂⍳⍵}
⍝
⍝ Plain reading:
⍝ permute 1..N, keep those where no two queens share a diagonal.
⍝
⍝ Known solution counts (OEIS A000170):
⍝ N 1 2 3 4 5 6 7 8 9 10
⍝ q(N) 1 0 0 2 10 4 40 92 352 724
queens ← {≢({(i j)←⍺⍵ ⋄ (|i-j)≠|(P[i])-(P[j])}⌿permutations ⍵)}

16
lib/apl/tests/programs/primes.apl
View File

@@ -1,16 +0,0 @@
⍝ Sieve of Eratosthenes — the classic APL one-liner
⍝ primes ← (2=+⌿0=A∘.|A)/A←⍳N
⍝
⍝ Read right-to-left:
⍝ A ← ⍳N : A is 1..N
⍝ A∘.|A : outer-product residue table — M[i,j] = A[j] mod A[i]
⍝ 0=... : boolean — true where A[i] divides A[j]
⍝ +⌿... : column sums — count of divisors per A[j]
⍝ 2=... : true for numbers with exactly 2 divisors (1 and self) → primes
⍝ .../A : compress — select A[j] where mask[j] is true
⍝
⍝ Examples:
⍝ primes 10 → 2 3 5 7
⍝ primes 30 → 2 3 5 7 11 13 17 19 23 29
primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵}

25
lib/apl/tests/programs/quicksort.apl
View File

@@ -1,25 +0,0 @@
⍝ Quicksort — the classic Roger Hui one-liner
⍝
⍝ Q ← {1≥≢⍵:⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p←⍵⌷⍨?≢⍵}
⍝
⍝ Read right-to-left:
⍝ ?≢⍵ : pick a random index in 1..length
⍝ ⍵⌷⍨… : take that element as pivot p
⍝ ⍵>p : boolean — elements greater than pivot
⍝ ∇⍵⌿⍨… : recursively sort the > partition
⍝ (p=⍵)/⍵ : keep elements equal to pivot
⍝ ⍵<p : boolean — elements less than pivot
⍝ ∇⍵⌿⍨… : recursively sort the < partition
⍝ , : catenate ⟨less⟩ ⟨equal⟩ ⟨greater⟩
⍝ 1≥≢⍵:⍵ : guard — base case for length ≤ 1
⍝
⍝ Stability: not stable on duplicates (but eq-class is preserved as a block).
⍝ Worst case O(N²) on already-sorted input with deterministic pivot;
⍝ randomized pivot selection gives expected O(N log N).
⍝
⍝ Examples:
⍝ Q 3 1 4 1 5 9 2 6 5 3 5 → 1 1 2 3 3 4 5 5 5 6 9
⍝ Q ⍳0 → ⍬ (empty)
⍝ Q ,42 → 42
quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p}

327
lib/apl/tests/runtime.sx
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)

369
lib/apl/tests/scalar.sx
View File

@@ -1,369 +0,0 @@
; APL scalar primitives test suite
; Requires: lib/apl/runtime.sx
; ============================================================
; Test framework
; ============================================================
(define apl-rt-count 0)
(define apl-rt-pass 0)
(define apl-rt-fails (list))
; Element-wise list comparison (handles both List and ListRef)
(define
lists-eq
(fn
(a b)
(if
(and (= (len a) 0) (= (len b) 0))
true
(if
(not (= (len a) (len b)))
false
(if
(not (= (first a) (first b)))
false
(lists-eq (rest a) (rest b)))))))
(define
apl-rt-test
(fn
(name actual expected)
(begin
(set! apl-rt-count (+ apl-rt-count 1))
(if
(equal? actual expected)
(set! apl-rt-pass (+ apl-rt-pass 1))
(append! apl-rt-fails {:actual actual :expected expected :name name})))))
; Test that a ravel equals a plain list (handles ListRef vs List)
(define
ravel-test
(fn
(name arr expected-list)
(begin
(set! apl-rt-count (+ apl-rt-count 1))
(let
((actual (get arr :ravel)))
(if
(lists-eq actual expected-list)
(set! apl-rt-pass (+ apl-rt-pass 1))
(append! apl-rt-fails {:actual actual :expected expected-list :name name}))))))
; Test a scalar ravel value (single-element list)
(define
scalar-test
(fn (name arr expected-val) (ravel-test name arr (list expected-val))))
; ============================================================
; Array constructor tests
; ============================================================
(apl-rt-test
"scalar: shape is empty list"
(get (apl-scalar 5) :shape)
(list))
(apl-rt-test
"scalar: ravel has one element"
(get (apl-scalar 5) :ravel)
(list 5))
(apl-rt-test "scalar: rank 0" (array-rank (apl-scalar 5)) 0)
(apl-rt-test "scalar? returns true for scalar" (scalar? (apl-scalar 5)) true)
(apl-rt-test "scalar: zero" (get (apl-scalar 0) :ravel) (list 0))
(apl-rt-test
"vector: shape is (3)"
(get (apl-vector (list 1 2 3)) :shape)
(list 3))
(apl-rt-test
"vector: ravel matches input"
(get (apl-vector (list 1 2 3)) :ravel)
(list 1 2 3))
(apl-rt-test "vector: rank 1" (array-rank (apl-vector (list 1 2 3))) 1)
(apl-rt-test
"scalar? returns false for vector"
(scalar? (apl-vector (list 1 2 3)))
false)
(apl-rt-test
"make-array: rank 2"
(array-rank (make-array (list 2 3) (list 1 2 3 4 5 6)))
2)
(apl-rt-test
"make-array: shape"
(get (make-array (list 2 3) (list 1 2 3 4 5 6)) :shape)
(list 2 3))
(apl-rt-test
"array-ref: first element"
(array-ref (apl-vector (list 10 20 30)) 0)
10)
(apl-rt-test
"array-ref: last element"
(array-ref (apl-vector (list 10 20 30)) 2)
30)
(apl-rt-test "enclose: wraps in rank-0" (scalar? (enclose 42)) true)
(apl-rt-test
"enclose: ravel contains value"
(get (enclose 42) :ravel)
(list 42))
(apl-rt-test "disclose: unwraps rank-0" (disclose (enclose 42)) 42)
; ============================================================
; Shape primitive tests
; ============================================================
(ravel-test "⍴ scalar: returns empty" (apl-shape (apl-scalar 5)) (list))
(ravel-test
"⍴ vector: returns (3)"
(apl-shape (apl-vector (list 1 2 3)))
(list 3))
(ravel-test
"⍴ matrix: returns (2 3)"
(apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6)))
(list 2 3))
(ravel-test
", ravel scalar: vector of 1"
(apl-ravel (apl-scalar 5))
(list 5))
(apl-rt-test
", ravel vector: same elements"
(get (apl-ravel (apl-vector (list 1 2 3))) :ravel)
(list 1 2 3))
(apl-rt-test
", ravel matrix: all elements"
(get (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))) :ravel)
(list 1 2 3 4 5 6))
(scalar-test "≢ tally scalar: 1" (apl-tally (apl-scalar 5)) 1)
(scalar-test
"≢ tally vector: first dimension"
(apl-tally (apl-vector (list 1 2 3)))
3)
(scalar-test
"≢ tally matrix: first dimension"
(apl-tally (make-array (list 2 3) (list 1 2 3 4 5 6)))
2)
(scalar-test
"≡ depth flat vector: 0"
(apl-depth (apl-vector (list 1 2 3)))
0)
(scalar-test "≡ depth scalar: 0" (apl-depth (apl-scalar 5)) 0)
(scalar-test
"≡ depth nested (enclose in vector): 1"
(apl-depth (enclose (apl-vector (list 1 2 3))))
1)
; ============================================================
; ⍳ iota tests
; ============================================================
(apl-rt-test
"⍳5 shape is (5)"
(get (apl-iota (apl-scalar 5)) :shape)
(list 5))
(ravel-test "⍳5 ravel is 1..5" (apl-iota (apl-scalar 5)) (list 1 2 3 4 5))
(ravel-test "⍳1 ravel is (1)" (apl-iota (apl-scalar 1)) (list 1))
(ravel-test "⍳0 ravel is empty" (apl-iota (apl-scalar 0)) (list))
(apl-rt-test "apl-io is 1" apl-io 1)
; ============================================================
; Arithmetic broadcast tests
; ============================================================
(scalar-test
"+ scalar scalar: 3+4=7"
(apl-add (apl-scalar 3) (apl-scalar 4))
7)
(ravel-test
"+ vector scalar: +10"
(apl-add (apl-vector (list 1 2 3)) (apl-scalar 10))
(list 11 12 13))
(ravel-test
"+ scalar vector: 10+"
(apl-add (apl-scalar 10) (apl-vector (list 1 2 3)))
(list 11 12 13))
(ravel-test
"+ vector vector"
(apl-add (apl-vector (list 1 2 3)) (apl-vector (list 4 5 6)))
(list 5 7 9))
(scalar-test "- negate monadic" (apl-neg-m (apl-scalar 5)) -5)
(scalar-test "- dyadic 10-3=7" (apl-sub (apl-scalar 10) (apl-scalar 3)) 7)
(scalar-test "× signum positive" (apl-signum (apl-scalar 7)) 1)
(scalar-test "× signum negative" (apl-signum (apl-scalar -3)) -1)
(scalar-test "× signum zero" (apl-signum (apl-scalar 0)) 0)
(scalar-test "× dyadic 3×4=12" (apl-mul (apl-scalar 3) (apl-scalar 4)) 12)
(scalar-test "÷ reciprocal 1÷4=0.25" (apl-recip (apl-scalar 4)) 0.25)
(scalar-test
"÷ dyadic 10÷4=2.5"
(apl-div (apl-scalar 10) (apl-scalar 4))
2.5)
(scalar-test "⌈ ceiling 2.3→3" (apl-ceil (apl-scalar 2.3)) 3)
(scalar-test "⌈ max 3 5 → 5" (apl-max (apl-scalar 3) (apl-scalar 5)) 5)
(scalar-test "⌊ floor 2.7→2" (apl-floor (apl-scalar 2.7)) 2)
(scalar-test "⌊ min 3 5 → 3" (apl-min (apl-scalar 3) (apl-scalar 5)) 3)
(scalar-test "* exp monadic e^0=1" (apl-exp (apl-scalar 0)) 1)
(scalar-test
"* pow dyadic 2^10=1024"
(apl-pow (apl-scalar 2) (apl-scalar 10))
1024)
(scalar-test "⍟ ln 1=0" (apl-ln (apl-scalar 1)) 0)
(scalar-test "| abs positive" (apl-abs (apl-scalar 5)) 5)
(scalar-test "| abs negative" (apl-abs (apl-scalar -5)) 5)
(scalar-test "| mod 3|7=1" (apl-mod (apl-scalar 3) (apl-scalar 7)) 1)
(scalar-test "! factorial 5!=120" (apl-fact (apl-scalar 5)) 120)
(scalar-test "! factorial 0!=1" (apl-fact (apl-scalar 0)) 1)
(scalar-test
"! binomial 4 choose 2 = 6"
(apl-binomial (apl-scalar 4) (apl-scalar 2))
6)
(scalar-test "○ pi×0=0" (apl-pi-times (apl-scalar 0)) 0)
(scalar-test "○ trig sin(0)=0" (apl-trig (apl-scalar 1) (apl-scalar 0)) 0)
(scalar-test "○ trig cos(0)=1" (apl-trig (apl-scalar 2) (apl-scalar 0)) 1)
; ============================================================
; Comparison tests
; ============================================================
(scalar-test "< less: 3<5 → 1" (apl-lt (apl-scalar 3) (apl-scalar 5)) 1)
(scalar-test "< less: 5<3 → 0" (apl-lt (apl-scalar 5) (apl-scalar 3)) 0)
(scalar-test
"≤ le equal: 3≤3 → 1"
(apl-le (apl-scalar 3) (apl-scalar 3))
1)
(scalar-test "= eq: 5=5 → 1" (apl-eq (apl-scalar 5) (apl-scalar 5)) 1)
(scalar-test "= ne: 5=6 → 0" (apl-eq (apl-scalar 5) (apl-scalar 6)) 0)
(scalar-test "≥ ge: 5≥3 → 1" (apl-ge (apl-scalar 5) (apl-scalar 3)) 1)
(scalar-test "> gt: 5>3 → 1" (apl-gt (apl-scalar 5) (apl-scalar 3)) 1)
(scalar-test "≠ ne: 5≠3 → 1" (apl-ne (apl-scalar 5) (apl-scalar 3)) 1)
(ravel-test
"comparison vector broadcast: 1 2 3 < 2 → 1 0 0"
(apl-lt (apl-vector (list 1 2 3)) (apl-scalar 2))
(list 1 0 0))
; ============================================================
; Logical tests
; ============================================================
(scalar-test "~ not 0 → 1" (apl-not (apl-scalar 0)) 1)
(scalar-test "~ not 1 → 0" (apl-not (apl-scalar 1)) 0)
(ravel-test
"~ not vector: 1 0 1 0 → 0 1 0 1"
(apl-not (apl-vector (list 1 0 1 0)))
(list 0 1 0 1))
(scalar-test
"∧ and 1∧1 → 1"
(apl-and (apl-scalar 1) (apl-scalar 1))
1)
(scalar-test
"∧ and 1∧0 → 0"
(apl-and (apl-scalar 1) (apl-scalar 0))
0)
(scalar-test "∨ or 0∨1 → 1" (apl-or (apl-scalar 0) (apl-scalar 1)) 1)
(scalar-test "∨ or 0∨0 → 0" (apl-or (apl-scalar 0) (apl-scalar 0)) 0)
(scalar-test
"⍱ nor 0⍱0 → 1"
(apl-nor (apl-scalar 0) (apl-scalar 0))
1)
(scalar-test
"⍱ nor 1⍱0 → 0"
(apl-nor (apl-scalar 1) (apl-scalar 0))
0)
(scalar-test
"⍲ nand 1⍲1 → 0"
(apl-nand (apl-scalar 1) (apl-scalar 1))
0)
(scalar-test
"⍲ nand 1⍲0 → 1"
(apl-nand (apl-scalar 1) (apl-scalar 0))
1)
; ============================================================
; plus-m identity test
; ============================================================
(scalar-test "+ monadic identity: +5 → 5" (apl-plus-m (apl-scalar 5)) 5)
; ============================================================
; Summary
; ============================================================
(define
apl-scalar-summary
(str
"scalar "
apl-rt-pass
"/"
apl-rt-count
(if (= (len apl-rt-fails) 0) "" (str " FAILS: " apl-rt-fails))))

608
lib/apl/tests/structural.sx
View File

@@ -1,608 +0,0 @@
;; lib/apl/tests/structural.sx — Phase 3: structural primitives
;; Tests for: apl-reshape, apl-ravel, apl-transpose, apl-transpose-dyadic
;; Loaded after runtime.sx; shares apl-test / apl-test-pass / apl-test-fail.
(define rv (fn (arr) (get arr :ravel)))
(define sh (fn (arr) (get arr :shape)))
;; ---------------------------------------------------------------------------
;; 1. Ravel (monadic ,)
;; ---------------------------------------------------------------------------
(apl-test "ravel scalar" (rv (apl-ravel (apl-scalar 5))) (list 5))
(apl-test
"ravel vector"
(rv (apl-ravel (make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"ravel matrix"
(rv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"ravel shape is rank-1"
(sh (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 6))
;; ---------------------------------------------------------------------------
;; 2. Reshape (dyadic ⍴)
;; ---------------------------------------------------------------------------
(apl-test
"reshape 2x3 ravel"
(rv
(apl-reshape
(make-array (list 2) (list 2 3))
(make-array (list 6) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"reshape 2x3 shape"
(sh
(apl-reshape
(make-array (list 2) (list 2 3))
(make-array (list 6) (list 1 2 3 4 5 6))))
(list 2 3))
(apl-test
"reshape cycle 6 from 1 2"
(rv
(apl-reshape
(make-array (list 1) (list 6))
(make-array (list 2) (list 1 2))))
(list 1 2 1 2 1 2))
(apl-test
"reshape cycle 2x3 from 1 2"
(rv
(apl-reshape
(make-array (list 2) (list 2 3))
(make-array (list 2) (list 1 2))))
(list 1 2 1 2 1 2))
(apl-test
"reshape scalar fill"
(rv (apl-reshape (make-array (list 1) (list 4)) (apl-scalar 7)))
(list 7 7 7 7))
(apl-test
"reshape truncate"
(rv
(apl-reshape
(make-array (list 1) (list 3))
(make-array (list 6) (list 10 20 30 40 50 60))))
(list 10 20 30))
(apl-test
"reshape matrix to vector"
(sh
(apl-reshape
(make-array (list 1) (list 6))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 6))
(apl-test
"reshape 2x2x3"
(sh
(apl-reshape
(make-array (list 3) (list 2 2 3))
(make-array (list 12) (range 1 13))))
(list 2 2 3))
(apl-test
"reshape to empty"
(rv
(apl-reshape
(make-array (list 1) (list 0))
(make-array (list 3) (list 1 2 3))))
(list))
;; ---------------------------------------------------------------------------
;; 3. Monadic transpose (⍉)
;; ---------------------------------------------------------------------------
(apl-test
"transpose scalar shape"
(sh (apl-transpose (apl-scalar 99)))
(list))
(apl-test
"transpose scalar ravel"
(rv (apl-transpose (apl-scalar 99)))
(list 99))
(apl-test
"transpose vector shape"
(sh (apl-transpose (make-array (list 3) (list 3 1 4))))
(list 3))
(apl-test
"transpose vector ravel"
(rv (apl-transpose (make-array (list 3) (list 3 1 4))))
(list 3 1 4))
(apl-test
"transpose 2x3 shape"
(sh (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2))
(apl-test
"transpose 2x3 ravel"
(rv (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 4 2 5 3 6))
(apl-test
"transpose 3x3"
(rv (apl-transpose (make-array (list 3 3) (list 1 2 3 4 5 6 7 8 9))))
(list 1 4 7 2 5 8 3 6 9))
(apl-test
"transpose 1x4 shape"
(sh (apl-transpose (make-array (list 1 4) (list 1 2 3 4))))
(list 4 1))
(apl-test
"transpose twice identity"
(rv
(apl-transpose
(apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6)))))
(list 1 2 3 4 5 6))
(apl-test
"transpose 3d shape"
(sh (apl-transpose (make-array (list 2 3 4) (range 0 24))))
(list 4 3 2))
;; ---------------------------------------------------------------------------
;; 4. Dyadic transpose (perm⍉arr)
;; ---------------------------------------------------------------------------
(apl-test
"dyadic-transpose identity"
(rv
(apl-transpose-dyadic
(make-array (list 2) (list 1 2))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3 4 5 6))
(apl-test
"dyadic-transpose swap 2x3"
(rv
(apl-transpose-dyadic
(make-array (list 2) (list 2 1))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 4 2 5 3 6))
(apl-test
"dyadic-transpose swap shape"
(sh
(apl-transpose-dyadic
(make-array (list 2) (list 2 1))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2))
(apl-test
"dyadic-transpose 3d shape"
(sh
(apl-transpose-dyadic
(make-array (list 3) (list 2 1 3))
(make-array (list 2 3 4) (range 0 24))))
(list 3 2 4))
(apl-test
"take 3 from front"
(rv (apl-take (apl-scalar 3) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3))
(apl-test
"take 0"
(rv (apl-take (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
(list))
(apl-test
"take -2 from back"
(rv (apl-take (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5))))
(list 4 5))
(apl-test
"take over-take pads with 0"
(rv (apl-take (apl-scalar 7) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5 0 0))
(apl-test
"take matrix 1 row 2 cols shape"
(sh
(apl-take
(make-array (list 2) (list 1 2))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2))
(apl-test
"take matrix 1 row 2 cols ravel"
(rv
(apl-take
(make-array (list 2) (list 1 2))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2))
(apl-test
"take matrix negative row"
(rv
(apl-take
(make-array (list 2) (list -1 3))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6))
(apl-test
"drop 2 from front"
(rv (apl-drop (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
(list 3 4 5))
(apl-test
"drop -2 from back"
(rv (apl-drop (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3))
(apl-test
"drop all"
(rv (apl-drop (apl-scalar 5) (make-array (list 5) (list 1 2 3 4 5))))
(list))
(apl-test
"drop 0"
(rv (apl-drop (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5))
(apl-test
"drop matrix 1 row shape"
(sh
(apl-drop
(make-array (list 2) (list 1 0))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 3))
(apl-test
"drop matrix 1 row ravel"
(rv
(apl-drop
(make-array (list 2) (list 1 0))
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6))
(apl-test
"reverse vector"
(rv (apl-reverse (make-array (list 5) (list 1 2 3 4 5))))
(list 5 4 3 2 1))
(apl-test
"reverse scalar identity"
(rv (apl-reverse (apl-scalar 42)))
(list 42))
(apl-test
"reverse matrix last axis"
(rv (apl-reverse (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 3 2 1 6 5 4))
(apl-test
"reverse-first matrix"
(rv (apl-reverse-first (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6 1 2 3))
(apl-test
"reverse-first vector identity"
(rv (apl-reverse-first (make-array (list 4) (list 1 2 3 4))))
(list 4 3 2 1))
(apl-test
"rotate vector left by 2"
(rv (apl-rotate (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
(list 3 4 5 1 2))
(apl-test
"rotate vector right by 1 (negative)"
(rv (apl-rotate (apl-scalar -1) (make-array (list 5) (list 1 2 3 4 5))))
(list 5 1 2 3 4))
(apl-test
"rotate by 0 is identity"
(rv (apl-rotate (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
(list 1 2 3 4 5))
(apl-test
"rotate matrix last axis"
(rv
(apl-rotate (apl-scalar 1) (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 2 3 1 5 6 4))
(apl-test
"rotate-first matrix"
(rv
(apl-rotate-first
(apl-scalar 1)
(make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 4 5 6 1 2 3))
(apl-test
"cat v,v ravel"
(rv
(apl-catenate
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 4 5))))
(list 1 2 3 4 5))
(apl-test
"cat v,v shape"
(sh
(apl-catenate
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 4 5))))
(list 5))
(apl-test
"cat scalar,v"
(rv (apl-catenate (apl-scalar 99) (make-array (list 3) (list 1 2 3))))
(list 99 1 2 3))
(apl-test
"cat v,scalar"
(rv (apl-catenate (make-array (list 3) (list 1 2 3)) (apl-scalar 99)))
(list 1 2 3 99))
(apl-test
"cat matrix last-axis shape"
(sh
(apl-catenate
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 2 2) (list 7 8 9 10))))
(list 2 5))
(apl-test
"cat matrix last-axis ravel"
(rv
(apl-catenate
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 2 2) (list 7 8 9 10))))
(list 1 2 3 7 8 4 5 6 9 10))
(apl-test
"cat-first v,v shape"
(sh
(apl-catenate-first
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 4 5))))
(list 5))
(apl-test
"cat-first matrix shape"
(sh
(apl-catenate-first
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19))))
(list 5 3))
(apl-test
"cat-first matrix ravel"
(rv
(apl-catenate-first
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19))))
(list 1 2 3 4 5 6 11 12 13 14 15 16 17 18 19))
(apl-test
"squad scalar into vector"
(rv
(apl-squad (apl-scalar 2) (make-array (list 5) (list 10 20 30 40 50))))
(list 20))
(apl-test
"squad first element"
(rv (apl-squad (apl-scalar 1) (make-array (list 3) (list 10 20 30))))
(list 10))
(apl-test
"squad last element"
(rv
(apl-squad (apl-scalar 5) (make-array (list 5) (list 10 20 30 40 50))))
(list 50))
(apl-test
"squad fully specified matrix element"
(rv
(apl-squad
(make-array (list 2) (list 2 3))
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 7))
(apl-test
"squad partial row of matrix shape"
(sh
(apl-squad
(apl-scalar 2)
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 4))
(apl-test
"squad partial row of matrix ravel"
(rv
(apl-squad
(apl-scalar 2)
(make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
(list 5 6 7 8))
(apl-test
"squad partial 3d slice shape"
(sh (apl-squad (apl-scalar 1) (make-array (list 2 3 4) (range 1 25))))
(list 3 4))
(apl-test
"grade-up basic"
(rv (apl-grade-up (make-array (list 5) (list 3 1 4 1 5))))
(list 2 4 1 3 5))
(apl-test
"grade-up shape"
(sh (apl-grade-up (make-array (list 4) (list 4 1 3 2))))
(list 4))
(apl-test
"grade-up no duplicates"
(rv (apl-grade-up (make-array (list 4) (list 4 1 3 2))))
(list 2 4 3 1))
(apl-test
"grade-up already sorted"
(rv (apl-grade-up (make-array (list 3) (list 1 2 3))))
(list 1 2 3))
(apl-test
"grade-up reverse sorted"
(rv (apl-grade-up (make-array (list 3) (list 3 2 1))))
(list 3 2 1))
(apl-test
"grade-down basic"
(rv (apl-grade-down (make-array (list 5) (list 3 1 4 1 5))))
(list 5 3 1 2 4))
(apl-test
"grade-down no duplicates"
(rv (apl-grade-down (make-array (list 4) (list 4 1 3 2))))
(list 1 3 4 2))
(apl-test
"grade-up single element"
(rv (apl-grade-up (make-array (list 1) (list 42))))
(list 1))
(apl-test
"enclose shape is scalar"
(sh (apl-enclose (make-array (list 3) (list 1 2 3))))
(list))
(apl-test
"enclose ravel length is 1"
(len (rv (apl-enclose (make-array (list 3) (list 1 2 3)))))
1)
(apl-test
"enclose inner ravel"
(rv (first (rv (apl-enclose (make-array (list 3) (list 1 2 3))))))
(list 1 2 3))
(apl-test
"disclose of enclose round-trips ravel"
(rv (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30)))))
(list 10 20 30))
(apl-test
"disclose of enclose round-trips shape"
(sh (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30)))))
(list 3))
(apl-test
"disclose scalar ravel"
(rv (apl-disclose (apl-scalar 42)))
(list 42))
(apl-test
"disclose vector ravel"
(rv (apl-disclose (make-array (list 3) (list 5 6 7))))
(list 5))
(apl-test
"disclose matrix returns first row"
(rv (apl-disclose (make-array (list 2 3) (list 1 2 3 4 5 6))))
(list 1 2 3))
(apl-test
"member basic"
(rv
(apl-member
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 2 3))))
(list 0 1 1))
(apl-test
"member all absent"
(rv
(apl-member
(make-array (list 3) (list 4 5 6))
(make-array (list 3) (list 1 2 3))))
(list 0 0 0))
(apl-test
"member scalar"
(rv (apl-member (apl-scalar 5) (make-array (list 3) (list 1 5 9))))
(list 1))
(apl-test
"member shape preserved"
(sh
(apl-member
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 1 3 5))))
(list 2 3))
(apl-test
"member matrix ravel"
(rv
(apl-member
(make-array (list 2 3) (list 1 2 3 4 5 6))
(make-array (list 3) (list 1 3 5))))
(list 1 0 1 0 1 0))
(apl-test
"index-of basic"
(rv
(apl-index-of
(make-array (list 4) (list 10 20 30 40))
(make-array (list 3) (list 20 40 10))))
(list 2 4 1))
(apl-test
"index-of not-found"
(rv
(apl-index-of
(make-array (list 3) (list 1 2 3))
(make-array (list 2) (list 5 2))))
(list 4 2))
(apl-test
"index-of scalar right"
(rv
(apl-index-of (make-array (list 3) (list 10 20 30)) (apl-scalar 20)))
(list 2))
(apl-test
"without basic"
(rv
(apl-without
(make-array (list 5) (list 1 2 3 4 5))
(make-array (list 2) (list 2 4))))
(list 1 3 5))
(apl-test
"without shape"
(sh
(apl-without
(make-array (list 5) (list 1 2 3 4 5))
(make-array (list 2) (list 2 4))))
(list 3))
(apl-test
"without nothing removed"
(rv
(apl-without
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 4 5 6))))
(list 1 2 3))
(apl-test
"without all removed"
(rv
(apl-without
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 1 2 3))))
(list))

48
lib/apl/tests/system.sx
View File

@@ -1,48 +0,0 @@
; Tests for APL ⎕ system functions.
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
(apl-test "⎕IO returns 1" (mkrv (apl-quad-io)) (list 1))
(apl-test "⎕ML returns 1" (mkrv (apl-quad-ml)) (list 1))
(apl-test "⎕FR returns 1248" (mkrv (apl-quad-fr)) (list 1248))
(apl-test "⎕TS shape is 7" (mksh (apl-quad-ts)) (list 7))
(apl-test "⎕TS year is 1970 default" (first (mkrv (apl-quad-ts))) 1970)
(apl-test "⎕FMT scalar 42" (apl-quad-fmt (apl-scalar 42)) "42")
(apl-test "⎕FMT scalar negative" (apl-quad-fmt (apl-scalar -7)) "-7")
(apl-test
"⎕FMT empty vector"
(apl-quad-fmt (make-array (list 0) (list)))
"")
(apl-test
"⎕FMT singleton vector"
(apl-quad-fmt (make-array (list 1) (list 42)))
"42")
(apl-test
"⎕FMT vector"
(apl-quad-fmt (make-array (list 5) (list 1 2 3 4 5)))
"1 2 3 4 5")
(apl-test
"⎕FMT matrix 2x3"
(apl-quad-fmt (make-array (list 2 3) (list 1 2 3 4 5 6)))
"1 2 3\n4 5 6\n")
(apl-test
"⎕← (print) returns its arg"
(mkrv (apl-quad-print (apl-scalar 99)))
(list 99))
(apl-test
"⎕← preserves shape"
(mksh (apl-quad-print (make-array (list 3) (list 1 2 3))))
(list 3))

156
lib/apl/tests/tradfn.sx
View File

@@ -1,156 +0,0 @@
; Tests for apl-call-tradfn (manual structure construction).
(define mkrv (fn (arr) (get arr :ravel)))
(define mksh (fn (arr) (get arr :shape)))
(define mknum (fn (n) (list :num n)))
(define mknm (fn (s) (list :name s)))
(define mkfg (fn (g) (list :fn-glyph g)))
(define mkmon (fn (g a) (list :monad (mkfg g) a)))
(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
(define mkasg (fn (n e) (list :assign n e)))
(define mkbr (fn (e) (list :branch e)))
(define mkif (fn (c t e) (list :if c t e)))
(define mkwhile (fn (c b) (list :while c b)))
(define mkfor (fn (v i b) (list :for v i b)))
(define mksel (fn (v cs d) (list :select v cs d)))
(define mktrap (fn (codes t c) (list :trap codes t c)))
(define mkthr (fn (code msg) (list :throw code msg)))
(apl-test
"tradfn R←L+W simple add"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 5) (apl-scalar 7)))
(list 12))
(apl-test
"tradfn R←L×W"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7)))
(list 42))
(apl-test
"tradfn monadic R←-W"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9)))
(list -9))
(apl-test
"tradfn →0 exits early"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknm "W")) (mkbr (mknum 0)) (mkasg "R" (mknum 999))) :alpha nil} nil (apl-scalar 7)))
(list 7))
(apl-test
"tradfn branch to line 3 skips line 2"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 3)) (mkasg "R" (mknum 999)) (mkasg "R" (mknum 42))) :alpha nil} nil (apl-scalar 0)))
(list 42))
(apl-test
"tradfn local var t←W+1; R←t×2"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "t" (mkdyd "+" (mknm "W") (mknum 1))) (mkasg "R" (mkdyd "×" (mknm "t") (mknum 2)))) :alpha nil} nil (apl-scalar 5)))
(list 12))
(apl-test
"tradfn vector args"
(mkrv
(apl-call-tradfn
{:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"}
(make-array (list 3) (list 1 2 3))
(make-array (list 3) (list 10 20 30))))
(list 11 22 33))
(apl-test
"tradfn unset result returns nil"
(apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 0))) :alpha nil} nil (apl-scalar 5))
nil)
(apl-test
"tradfn run-off end returns result"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "W") (mknum 3)))) :alpha nil} nil (apl-scalar 7)))
(list 21))
(apl-test
"tradfn loop sum 1+2+...+5 via branch"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1))) (mkbr (mkdyd "×" (mkdyd "≤" (mknm "i") (mknm "W")) (mknum 3)))) :alpha nil} nil (apl-scalar 5)))
(list 15))
(apl-test
"tradfn :If true branch"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
(list 1))
(apl-test
"tradfn :If false branch"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 100)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
(list 0))
(apl-test
"tradfn :While sum 1..N"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkwhile (mkdyd "≤" (mknm "i") (mknm "W")) (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1)))))) :alpha nil} nil (apl-scalar 10)))
(list 55))
(apl-test
"tradfn :For sum elements"
(mkrv
(apl-call-tradfn
{:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil}
nil
(make-array (list 4) (list 10 20 30 40))))
(list 100))
(apl-test
"tradfn :For with empty vector"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 99)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil} nil (make-array (list 0) (list))))
(list 99))
(apl-test
"tradfn :Select dispatch hit"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200))) (list (mknum 3) (mkasg "R" (mknum 300)))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 2)))
(list 200))
(apl-test
"tradfn :Select default block"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200)))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil (apl-scalar 99)))
(list -1))
(apl-test
"tradfn nested :If"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkif (mkdyd ">" (mknm "W") (mknum 10)) (list (mkasg "R" (mknum 2))) (list (mkasg "R" (mknum 1))))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
(list 1))
(apl-test
"tradfn :If assigns persist outside"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 42))) (list)) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 1)))) :alpha nil} nil (apl-scalar 5)))
(list 43))
(apl-test
"tradfn :For factorial 1..5"
(mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 1)) (mkfor "x" (mkmon "⍳" (mknm "W")) (list (mkasg "R" (mkdyd "×" (mknm "R") (mknm "x")))))) :alpha nil} nil (apl-scalar 5)))
(list 120))
(apl-test
"tradfn :Trap normal flow (no error)"
(mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkasg "R" (mknum 99))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil nil))
(list 99))
(apl-test
"tradfn :Trap catches matching code"
(mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 5) (list (mkthr 5 "boom")) (list (mkasg "R" (mknum 42))))) :alpha nil} nil nil))
(list 42))
(apl-test
"tradfn :Trap catch-all (code 0)"
(mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkthr 99 "any")) (list (mkasg "R" (mknum 1))))) :alpha nil} nil nil))
(list 1))
(apl-test
"tradfn :Trap catches one of many codes"
(mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 1 2 3) (list (mkthr 2 "two")) (list (mkasg "R" (mknum 22))))) :alpha nil} nil nil))
(list 22))
(apl-test
"tradfn :Trap continues to next stmt after catch"
(mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 7) (list (mkthr 7 "c")) (list (mkasg "R" (mknum 10)))) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 5)))) :alpha nil} nil nil))
(list 15))

81
lib/apl/tests/valence.sx
View File

@@ -1,81 +0,0 @@
; Tests for valence detection (apl-dfn-valence, apl-tradfn-valence)
; and unified dispatch (apl-call).
(define mkrv (fn (arr) (get arr :ravel)))
(define mknum (fn (n) (list :num n)))
(define mknm (fn (s) (list :name s)))
(define mkfg (fn (g) (list :fn-glyph g)))
(define mkmon (fn (g a) (list :monad (mkfg g) a)))
(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
(define mkasg (fn (n e) (list :assign n e)))
(define mkdfn (fn (stmts) (cons :dfn stmts)))
(apl-test
"dfn-valence niladic body=42"
(apl-dfn-valence (mkdfn (list (mknum 42))))
:niladic)
(apl-test
"dfn-valence monadic body=⍵+1"
(apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1)))))
:monadic)
(apl-test
"dfn-valence dyadic body=⍺+⍵"
(apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵")))))
:dyadic)
(apl-test
"dfn-valence dyadic mentions ⍺ via local"
(apl-dfn-valence (mkdfn (list (mkasg "x" (mknm "⍺")) (mknm "x"))))
:dyadic)
(apl-test
"dfn-valence dyadic deep nest"
(apl-dfn-valence
(mkdfn (list (mkmon "-" (mkdyd "×" (mknm "⍺") (mknm "⍵"))))))
:dyadic)
(apl-test "tradfn-valence niladic" (apl-tradfn-valence {:result "R" :omega nil :stmts (list) :alpha nil}) :niladic)
(apl-test "tradfn-valence monadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha nil}) :monadic)
(apl-test "tradfn-valence dyadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha "L"}) :dyadic)
(apl-test
"apl-call dfn niladic"
(mkrv (apl-call (mkdfn (list (mknum 42))) nil nil))
(list 42))
(apl-test
"apl-call dfn monadic"
(mkrv
(apl-call
(mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1))))
nil
(apl-scalar 5)))
(list 6))
(apl-test
"apl-call dfn dyadic"
(mkrv
(apl-call
(mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵"))))
(apl-scalar 3)
(apl-scalar 4)))
(list 7))
(apl-test
"apl-call tradfn dyadic"
(mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7)))
(list 42))
(apl-test
"apl-call tradfn monadic"
(mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9)))
(list -9))
(apl-test
"apl-call tradfn niladic returns nil result"
(apl-call {:result "R" :omega nil :stmts (list) :alpha nil} nil nil)
nil)

198
lib/apl/tokenizer.sx
View File

@@ -1,198 +0,0 @@
(define apl-glyph-set
(list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
"≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
"∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
"⍺" "⍵" "∇" "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
(define apl-glyph?
(fn (ch)
(some (fn (g) (= g ch)) apl-glyph-set)))
(define apl-digit?
(fn (ch)
(and (string? ch) (>= ch "0") (<= ch "9"))))
(define apl-alpha?
(fn (ch)
(and (string? ch)
(or (and (>= ch "a") (<= ch "z"))
(and (>= ch "A") (<= ch "Z"))
(= ch "_")))))
(define
apl-tokenize
(fn
(source)
(let
((pos 0) (src-len (len source)) (tokens (list)))
(define tok-push! (fn (type value) (append! tokens {:value value :type type})))
(define
cur-sw?
(fn
(ch)
(and (< pos src-len) (starts-with? (slice source pos) ch))))
(define cur-byte (fn () (if (< pos src-len) (nth source pos) nil)))
(define advance! (fn () (set! pos (+ pos 1))))
(define consume! (fn (ch) (set! pos (+ pos (len ch)))))
(define
find-glyph
(fn
()
(let
((rem (slice source pos)))
(let
((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set)))
(if (> (len matches) 0) (first matches) nil)))))
(define
read-digits!
(fn
(acc)
(if
(and (< pos src-len) (apl-digit? (cur-byte)))
(let
((ch (cur-byte)))
(begin (advance!) (read-digits! (str acc ch))))
acc)))
(define
read-ident-cont!
(fn
()
(when
(and
(< pos src-len)
(let
((ch (cur-byte)))
(or (apl-alpha? ch) (apl-digit? ch))))
(begin (advance!) (read-ident-cont!)))))
(define
read-string!
(fn
(acc)
(cond
((>= pos src-len) acc)
((cur-sw? "'")
(if
(and (< (+ pos 1) src-len) (cur-sw? "'"))
(begin (advance!) (advance!) (read-string! (str acc "'")))
(begin (advance!) acc)))
(true
(let
((ch (cur-byte)))
(begin (advance!) (read-string! (str acc ch))))))))
(define
skip-line!
(fn
()
(when
(and (< pos src-len) (not (cur-sw? "\n")))
(begin (advance!) (skip-line!)))))
(define
scan!
(fn
()
(when
(< pos src-len)
(let
((ch (cur-byte)))
(cond
((or (= ch " ") (= ch "\t") (= ch "\r"))
(begin (advance!) (scan!)))
((= ch "\n")
(begin (advance!) (tok-push! :newline nil) (scan!)))
((cur-sw? "⍝") (begin (skip-line!) (scan!)))
((cur-sw? "⋄")
(begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
((= ch "(")
(begin (advance!) (tok-push! :lparen nil) (scan!)))
((= ch ")")
(begin (advance!) (tok-push! :rparen nil) (scan!)))
((= ch "[")
(begin (advance!) (tok-push! :lbracket nil) (scan!)))
((= ch "]")
(begin (advance!) (tok-push! :rbracket nil) (scan!)))
((= ch "{")
(begin (advance!) (tok-push! :lbrace nil) (scan!)))
((= ch "}")
(begin (advance!) (tok-push! :rbrace nil) (scan!)))
((= ch ";")
(begin (advance!) (tok-push! :semi nil) (scan!)))
((cur-sw? "←")
(begin (consume! "←") (tok-push! :assign nil) (scan!)))
((= ch ":")
(let
((start pos))
(begin
(advance!)
(if
(and (< pos src-len) (apl-alpha? (cur-byte)))
(begin
(read-ident-cont!)
(tok-push! :keyword (slice source start pos)))
(tok-push! :colon nil))
(scan!))))
((and (cur-sw? "¯") (< (+ pos (len "¯")) src-len) (apl-digit? (nth source (+ pos (len "¯")))))
(begin
(consume! "¯")
(let
((digits (read-digits! "")))
(if
(and
(< pos src-len)
(= (cur-byte) ".")
(< (+ pos 1) src-len)
(apl-digit? (nth source (+ pos 1))))
(begin
(advance!)
(let
((frac (read-digits! "")))
(tok-push!
:num (- 0 (string->number (str digits "." frac))))))
(tok-push! :num (- 0 (parse-int digits 0)))))
(scan!)))
((apl-digit? ch)
(begin
(let
((digits (read-digits! "")))
(if
(and
(< pos src-len)
(= (cur-byte) ".")
(< (+ pos 1) src-len)
(apl-digit? (nth source (+ pos 1))))
(begin
(advance!)
(let
((frac (read-digits! "")))
(tok-push!
:num (string->number (str digits "." frac)))))
(tok-push! :num (parse-int digits 0))))
(scan!)))
((= ch "'")
(begin
(advance!)
(let ((s (read-string! ""))) (tok-push! :str s))
(scan!)))
((or (apl-alpha? ch) (cur-sw? "⎕"))
(let
((start pos))
(begin
(if
(cur-sw? "⎕")
(begin
(consume! "⎕")
(if
(and (< pos src-len) (cur-sw? "←"))
(consume! "←")
(read-ident-cont!)))
(begin (advance!) (read-ident-cont!)))
(tok-push! :name (slice source start pos))
(scan!))))
(true
(let
((g (find-glyph)))
(if
g
(begin (consume! g) (tok-push! :glyph g) (scan!))
(begin (advance!) (scan!))))))))))
(scan!)
tokens)))

592
lib/apl/transpile.sx
View File

@@ -1,592 +0,0 @@
; APL transpile / AST evaluator
;
; Walks parsed AST nodes and evaluates against the runtime.
; Entry points:
; apl-eval-ast : node × env → value
; apl-eval-stmts : stmt-list × env → value (handles guards, locals, ⍺← default)
; apl-call-dfn : dfn-ast × ⍺ × ⍵ → value (dyadic)
; apl-call-dfn-m : dfn-ast × ⍵ → value (monadic)
;
; Env is a dict; ⍺ stored under "alpha", ⍵ under "omega",
; the dfn-ast itself under "nabla" (for ∇ recursion),
; user names under their literal name.
(define
apl-monadic-fn
(fn
(g)
(cond
((= g "+") apl-plus-m)
((= g "-") apl-neg-m)
((= g "×") apl-signum)
((= g "÷") apl-recip)
((= g "⌈") apl-ceil)
((= g "⌊") apl-floor)
((= g "⍳") apl-iota)
((= g "|") apl-abs)
((= g "*") apl-exp)
((= g "⍟") apl-ln)
((= g "!") apl-fact)
((= g "○") apl-pi-times)
((= g "~") apl-not)
((= g "≢") apl-tally)
((= g "⍴") apl-shape)
((= g "≡") apl-depth)
((= g "⊂") apl-enclose)
((= g "⊃") apl-disclose)
((= g ",") apl-ravel)
((= g "⌽") apl-reverse)
((= g "⊖") apl-reverse-first)
((= g "⍋") apl-grade-up)
((= g "⍒") apl-grade-down)
((= g "?") apl-roll)
((= g "⍉") apl-transpose)
((= g "⊢") (fn (a) a))
((= g "⊣") (fn (a) a))
((= g "⍕") apl-quad-fmt)
((= g "⎕FMT") apl-quad-fmt)
((= g "⎕←") apl-quad-print)
((= g "⍸") apl-where)
((= g "∪") apl-unique)
((= g "⍎") apl-execute)
(else (error "no monadic fn for glyph")))))
(define
apl-dyadic-fn
(fn
(g)
(cond
((= g "+") apl-add)
((= g "-") apl-sub)
((= g "×") apl-mul)
((= g "÷") apl-div)
((= g "⌈") apl-max)
((= g "⌊") apl-min)
((= g "*") apl-pow)
((= g "⍟") apl-log)
((= g "|") apl-mod)
((= g "!") apl-binomial)
((= g "○") apl-trig)
((= g "<") apl-lt)
((= g "≤") apl-le)
((= g "=") apl-eq)
((= g "≥") apl-ge)
((= g ">") apl-gt)
((= g "≠") apl-ne)
((= g "∧") apl-and)
((= g "∨") apl-or)
((= g "⍱") apl-nor)
((= g "⍲") apl-nand)
((= g ",") apl-catenate)
((= g "⍪") apl-catenate-first)
((= g "⍴") apl-reshape)
((= g "↑") apl-take)
((= g "↓") apl-drop)
((= g "⌷") apl-squad)
((= g "⌽") apl-rotate)
((= g "⊖") apl-rotate-first)
((= g "∊") apl-member)
((= g "⍳") apl-index-of)
((= g "~") apl-without)
((= g "/") apl-compress)
((= g "⌿") apl-compress-first)
((= g "⍉") apl-transpose-dyadic)
((= g "⊢") (fn (a b) b))
((= g "⊣") (fn (a b) a))
((= g "⍸") apl-interval-index)
((= g "∪") apl-union)
((= g "∩") apl-intersect)
((= g "⊥") apl-decode)
((= g "⊤") apl-encode)
((= g "⊆") apl-partition)
(else (error "no dyadic fn for glyph")))))
(define
apl-truthy?
(fn
(v)
(let
((rv (get v :ravel)))
(if (and (= (len rv) 1) (= (first rv) 0)) false true))))
(define
apl-eval-ast
(fn
(node env)
(let
((tag (first node)))
(cond
((= tag :num) (apl-scalar (nth node 1)))
((= tag :str)
(let
((s (nth node 1)))
(if
(= (len s) 1)
(apl-scalar s)
(make-array
(list (len s))
(map (fn (i) (slice s i (+ i 1))) (range 0 (len s)))))))
((= tag :vec)
(let
((items (rest node)))
(let
((vals (map (fn (n) (apl-eval-ast n env)) items)))
(make-array
(list (len vals))
(map
(fn
(v)
(if
(= (len (get v :shape)) 0)
(first (get v :ravel))
v))
vals)))))
((= tag :name)
(let
((nm (nth node 1)))
(cond
((= nm "⍺")
(let
((v (get env "⍺")))
(if (= v nil) (get env "alpha") v)))
((= nm "⍵")
(let
((v (get env "⍵")))
(if (= v nil) (get env "omega") v)))
((= nm "⎕IO") (apl-quad-io))
((= nm "⎕ML") (apl-quad-ml))
((= nm "⎕FR") (apl-quad-fr))
((= nm "⎕TS") (apl-quad-ts))
(else (get env nm)))))
((= tag :monad)
(let
((fn-node (nth node 1)) (arg (nth node 2)))
(if
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
(let
((arg-val (apl-eval-ast arg env)))
(let
((new-env (if (and (list? arg) (> (len arg) 0) (= (first arg) :assign-expr)) (assoc env (nth arg 1) arg-val) env)))
((apl-resolve-monadic fn-node new-env) arg-val))))))
((= tag :dyad)
(let
((fn-node (nth node 1))
(lhs (nth node 2))
(rhs (nth node 3)))
(if
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
(apl-call-dfn
(get env "nabla")
(apl-eval-ast lhs env)
(apl-eval-ast rhs env))
(let
((rhs-val (apl-eval-ast rhs env)))
(let
((new-env (if (and (list? rhs) (> (len rhs) 0) (= (first rhs) :assign-expr)) (assoc env (nth rhs 1) rhs-val) env)))
((apl-resolve-dyadic fn-node new-env)
(apl-eval-ast lhs new-env)
rhs-val))))))
((= tag :program) (apl-eval-stmts (rest node) env))
((= tag :dfn) node)
((= tag :bracket)
(let
((arr-expr (nth node 1)) (axis-exprs (rest (rest node))))
(let
((arr (apl-eval-ast arr-expr env))
(axes
(map
(fn (a) (if (= a :all) nil (apl-eval-ast a env)))
axis-exprs)))
(apl-bracket-multi axes arr))))
((= tag :assign-expr) (apl-eval-ast (nth node 2) env))
((= tag :assign) (apl-eval-ast (nth node 2) env))
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
(define
apl-eval-stmts
(fn
(stmts env)
(if
(= (len stmts) 0)
nil
(let
((stmt (first stmts)) (more (rest stmts)))
(let
((tag (first stmt)))
(cond
((= tag :guard)
(let
((cond-val (apl-eval-ast (nth stmt 1) env)))
(if
(apl-truthy? cond-val)
(apl-eval-ast (nth stmt 2) env)
(apl-eval-stmts more env))))
((and (= tag :assign) (= (nth stmt 1) "⍺"))
(if
(get env "alpha")
(apl-eval-stmts more env)
(let
((v (apl-eval-ast (nth stmt 2) env)))
(apl-eval-stmts more (assoc env "alpha" v)))))
((= tag :assign)
(let
((v (apl-eval-ast (nth stmt 2) env)))
(apl-eval-stmts more (assoc env (nth stmt 1) v))))
((= (len more) 0) (apl-eval-ast stmt env))
(else (begin (apl-eval-ast stmt env) (apl-eval-stmts more env)))))))))
(define
apl-call-dfn
(fn
(dfn-ast alpha omega)
(let
((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha alpha}))
(apl-eval-stmts stmts env))))
(define
apl-call-dfn-m
(fn
(dfn-ast omega)
(let
((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil}))
(apl-eval-stmts stmts env))))
(define
apl-tradfn-eval-block
(fn
(stmts env)
(if
(= (len stmts) 0)
env
(let
((stmt (first stmts)))
(apl-tradfn-eval-block (rest stmts) (apl-tradfn-eval-stmt stmt env))))))
(define
apl-tradfn-eval-while
(fn
(cond-expr body env)
(let
((cond-val (apl-eval-ast cond-expr env)))
(if
(apl-truthy? cond-val)
(apl-tradfn-eval-while
cond-expr
body
(apl-tradfn-eval-block body env))
env))))
(define
apl-tradfn-eval-for
(fn
(var-name items body env)
(if
(= (len items) 0)
env
(let
((env-with-var (assoc env var-name (apl-scalar (first items)))))
(apl-tradfn-eval-for
var-name
(rest items)
body
(apl-tradfn-eval-block body env-with-var))))))
(define
apl-tradfn-eval-select
(fn
(val cases default-block env)
(if
(= (len cases) 0)
(apl-tradfn-eval-block default-block env)
(let
((c (first cases)))
(let
((case-val (apl-eval-ast (first c) env)))
(if
(= (first (get val :ravel)) (first (get case-val :ravel)))
(apl-tradfn-eval-block (rest c) env)
(apl-tradfn-eval-select val (rest cases) default-block env)))))))
(define
apl-tradfn-eval-stmt
(fn
(stmt env)
(let
((tag (first stmt)))
(cond
((= tag :assign)
(assoc env (nth stmt 1) (apl-eval-ast (nth stmt 2) env)))
((= tag :if)
(let
((cond-val (apl-eval-ast (nth stmt 1) env)))
(if
(apl-truthy? cond-val)
(apl-tradfn-eval-block (nth stmt 2) env)
(apl-tradfn-eval-block (nth stmt 3) env))))
((= tag :while)
(apl-tradfn-eval-while (nth stmt 1) (nth stmt 2) env))
((= tag :for)
(let
((iter-val (apl-eval-ast (nth stmt 2) env)))
(apl-tradfn-eval-for
(nth stmt 1)
(get iter-val :ravel)
(nth stmt 3)
env)))
((= tag :select)
(let
((val (apl-eval-ast (nth stmt 1) env)))
(apl-tradfn-eval-select val (nth stmt 2) (nth stmt 3) env)))
((= tag :trap)
(let
((codes (nth stmt 1))
(try-block (nth stmt 2))
(catch-block (nth stmt 3)))
(guard
(e
((apl-trap-matches? codes e)
(apl-tradfn-eval-block catch-block env)))
(apl-tradfn-eval-block try-block env))))
((= tag :throw) (apl-throw (nth stmt 1) (nth stmt 2)))
(else (begin (apl-eval-ast stmt env) env))))))
(define
apl-tradfn-loop
(fn
(stmts line env result-name)
(cond
((= line 0) (get env result-name))
((> line (len stmts)) (get env result-name))
(else
(let
((stmt (nth stmts (- line 1))))
(let
((tag (first stmt)))
(cond
((= tag :branch)
(let
((target (apl-eval-ast (nth stmt 1) env)))
(let
((target-num (first (get target :ravel))))
(apl-tradfn-loop stmts target-num env result-name))))
(else
(apl-tradfn-loop
stmts
(+ line 1)
(apl-tradfn-eval-stmt stmt env)
result-name)))))))))
(define
apl-call-tradfn
(fn
(tradfn alpha omega)
(let
((stmts (get tradfn :stmts))
(result-name (get tradfn :result))
(alpha-name (get tradfn :alpha))
(omega-name (get tradfn :omega)))
(let
((env-a (if alpha-name (assoc {} alpha-name alpha) {})))
(let
((env-ao (if omega-name (assoc env-a omega-name omega) env-a)))
(apl-tradfn-loop stmts 1 env-ao result-name))))))
(define
apl-ast-mentions-list?
(fn
(lst target)
(if
(= (len lst) 0)
false
(if
(apl-ast-mentions? (first lst) target)
true
(apl-ast-mentions-list? (rest lst) target)))))
(define
apl-ast-mentions?
(fn
(node target)
(cond
((not (list? node)) false)
((= (len node) 0) false)
((and (= (first node) :name) (= (nth node 1) target)) true)
(else (apl-ast-mentions-list? (rest node) target)))))
(define
apl-dfn-valence
(fn
(dfn-ast)
(let
((body (rest dfn-ast)))
(cond
((apl-ast-mentions-list? body "⍺") :dyadic)
((apl-ast-mentions-list? body "⍵") :monadic)
(else :niladic)))))
(define
apl-tradfn-valence
(fn
(tradfn)
(cond
((get tradfn :alpha) :dyadic)
((get tradfn :omega) :monadic)
(else :niladic))))
(define
apl-call
(fn
(f alpha omega)
(cond
((and (list? f) (> (len f) 0) (= (first f) :dfn))
(if alpha (apl-call-dfn f alpha omega) (apl-call-dfn-m f omega)))
((dict? f) (apl-call-tradfn f alpha omega))
(else (error "apl-call: not a function")))))
(define
apl-resolve-monadic
(fn
(fn-node env)
(let
((tag (first fn-node)))
(cond
((= tag :fn-glyph) (apl-monadic-fn (nth fn-node 1)))
((= tag :derived-fn)
(let
((op (nth fn-node 1)) (inner (nth fn-node 2)))
(cond
((= op "/")
(let
((f (apl-resolve-dyadic inner env)))
(fn (arr) (apl-reduce f arr))))
((= op "⌿")
(let
((f (apl-resolve-dyadic inner env)))
(fn (arr) (apl-reduce-first f arr))))
((= op "\\")
(let
((f (apl-resolve-dyadic inner env)))
(fn (arr) (apl-scan f arr))))
((= op "⍀")
(let
((f (apl-resolve-dyadic inner env)))
(fn (arr) (apl-scan-first f arr))))
((= op "¨")
(let
((f (apl-resolve-monadic inner env)))
(fn (arr) (apl-each f arr))))
((= op "⍨")
(let
((f (apl-resolve-dyadic inner env)))
(fn (arr) (apl-commute f arr))))
(else (error "apl-resolve-monadic: unsupported op")))))
((= tag :fn-name)
(let
((nm (nth fn-node 1)))
(let
((bound (get env nm)))
(if
(and
(list? bound)
(> (len bound) 0)
(= (first bound) :dfn))
(fn (arg) (apl-call-dfn-m bound arg))
(error "apl-resolve-monadic: name not bound to dfn")))))
((= tag :train)
(let
((fns (rest fn-node)))
(let
((n (len fns)))
(cond
((= n 2)
(let
((g (apl-resolve-monadic (nth fns 0) env))
(h (apl-resolve-monadic (nth fns 1) env)))
(fn (arg) (g (h arg)))))
((= n 3)
(let
((f (apl-resolve-monadic (nth fns 0) env))
(g (apl-resolve-dyadic (nth fns 1) env))
(h (apl-resolve-monadic (nth fns 2) env)))
(fn (arg) (g (f arg) (h arg)))))
(else (error "monadic train arity not 2 or 3"))))))
(else (error "apl-resolve-monadic: unknown fn-node tag"))))))
(define
apl-resolve-dyadic
(fn
(fn-node env)
(let
((tag (first fn-node)))
(cond
((= tag :fn-glyph) (apl-dyadic-fn (nth fn-node 1)))
((= tag :derived-fn)
(let
((op (nth fn-node 1)) (inner (nth fn-node 2)))
(cond
((= op "¨")
(let
((f (apl-resolve-dyadic inner env)))
(fn (a b) (apl-each-dyadic f a b))))
((= op "⍨")
(let
((f (apl-resolve-dyadic inner env)))
(fn (a b) (apl-commute-dyadic f a b))))
(else (error "apl-resolve-dyadic: unsupported op")))))
((= tag :fn-name)
(let
((nm (nth fn-node 1)))
(let
((bound (get env nm)))
(if
(and
(list? bound)
(> (len bound) 0)
(= (first bound) :dfn))
(fn (a b) (apl-call-dfn bound a b))
(error "apl-resolve-dyadic: name not bound to dfn")))))
((= tag :outer)
(let
((inner (nth fn-node 2)))
(let
((f (apl-resolve-dyadic inner env)))
(fn (a b) (apl-outer f a b)))))
((= tag :derived-fn2)
(let
((f-node (nth fn-node 2)) (g-node (nth fn-node 3)))
(let
((f (apl-resolve-dyadic f-node env))
(g (apl-resolve-dyadic g-node env)))
(fn (a b) (apl-inner f g a b)))))
((= tag :train)
(let
((fns (rest fn-node)))
(let
((n (len fns)))
(cond
((= n 2)
(let
((g (apl-resolve-monadic (nth fns 0) env))
(h (apl-resolve-dyadic (nth fns 1) env)))
(fn (a b) (g (h a b)))))
((= n 3)
(let
((f (apl-resolve-dyadic (nth fns 0) env))
(g (apl-resolve-dyadic (nth fns 1) env))
(h (apl-resolve-dyadic (nth fns 2) env)))
(fn (a b) (g (f a b) (h a b)))))
(else (error "dyadic train arity not 2 or 3"))))))
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
(define apl-run-file (fn (path) (apl-run (file-read path))))
(define
apl-execute
(fn
(arr)
(let
((src (cond ((string? arr) arr) ((scalar? arr) (disclose arr)) (else (reduce str "" (get arr :ravel))))))
(apl-run src))))

485
lib/common-lisp/clos.sx
View File

@@ -1,485 +0,0 @@
;; lib/common-lisp/clos.sx — CLOS: classes, instances, generic functions
;;
;; Class records: {:clos-type "class" :name "NAME" :slots {...} :parents [...] :methods [...]}
;; Instance: {:clos-type "instance" :class "NAME" :slots {slot: val ...}}
;; Method: {:qualifiers [...] :specializers [...] :fn (fn (args next-fn) ...)}
;;
;; SX primitive notes:
;; dict->list: use (map (fn (k) (list k (get d k))) (keys d))
;; dict-set (pure): use assoc
;; fn?/callable?: use callable?
;; ── dict helpers ───────────────────────────────────────────────────────────
(define
clos-dict->list
(fn (d) (map (fn (k) (list k (get d k))) (keys d))))
;; ── class registry ─────────────────────────────────────────────────────────
(define
clos-class-registry
(dict
"t"
{:parents (list) :clos-type "class" :slots (dict) :methods (list) :name "t"}
"null"
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "null"}
"integer"
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "integer"}
"float"
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "float"}
"string"
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "string"}
"symbol"
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "symbol"}
"cons"
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "cons"}
"list"
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "list"}))
;; ── clos-generic-registry ─────────────────────────────────────────────────
(define clos-generic-registry (dict))
;; ── class-of ──────────────────────────────────────────────────────────────
(define
clos-class-of
(fn
(x)
(cond
((nil? x) "null")
((integer? x) "integer")
((float? x) "float")
((string? x) "string")
((symbol? x) "symbol")
((and (list? x) (> (len x) 0)) "cons")
((and (list? x) (= (len x) 0)) "null")
((and (dict? x) (= (get x "clos-type") "instance")) (get x "class"))
(:else "t"))))
;; ── subclass-of? ──────────────────────────────────────────────────────────
;;
;; Captures clos-class-registry at define time to avoid free-variable issues.
(define
clos-subclass-of?
(let
((registry clos-class-registry))
(fn
(class-name super-name)
(if
(= class-name super-name)
true
(let
((rec (get registry class-name)))
(if
(nil? rec)
false
(some
(fn (p) (clos-subclass-of? p super-name))
(get rec "parents"))))))))
;; ── instance-of? ──────────────────────────────────────────────────────────
(define
clos-instance-of?
(fn (obj class-name) (clos-subclass-of? (clos-class-of obj) class-name)))
;; ── defclass ──────────────────────────────────────────────────────────────
;;
;; slot-specs: list of dicts with keys: name initarg initform accessor reader writer
;; Each missing key defaults to nil.
(define clos-slot-spec (fn (spec) (if (string? spec) {:initform nil :initarg nil :reader nil :writer nil :accessor nil :name spec} spec)))
(define
clos-defclass
(fn
(name parents slot-specs)
(let
((slots (dict)))
(for-each
(fn
(pname)
(let
((prec (get clos-class-registry pname)))
(when
(not (nil? prec))
(for-each
(fn
(k)
(when
(nil? (get slots k))
(dict-set! slots k (get (get prec "slots") k))))
(keys (get prec "slots"))))))
parents)
(for-each
(fn
(s)
(let
((spec (clos-slot-spec s)))
(dict-set! slots (get spec "name") spec)))
slot-specs)
(let
((class-rec {:parents parents :clos-type "class" :slots slots :methods (list) :name name}))
(dict-set! clos-class-registry name class-rec)
(clos-install-accessors-for name slots)
name))))
;; ── accessor installation (forward-declared, defined after defmethod) ──────
(define
clos-install-accessors-for
(fn
(class-name slots)
(for-each
(fn
(k)
(let
((spec (get slots k)))
(let
((reader (get spec "reader")))
(when
(not (nil? reader))
(clos-add-reader-method reader class-name k)))
(let
((accessor (get spec "accessor")))
(when
(not (nil? accessor))
(clos-add-reader-method accessor class-name k)))))
(keys slots))))
;; placeholder — real impl filled in after defmethod is defined
(define clos-add-reader-method (fn (method-name class-name slot-name) nil))
;; ── make-instance ─────────────────────────────────────────────────────────
(define
clos-make-instance
(fn
(class-name &rest initargs)
(let
((class-rec (get clos-class-registry class-name)))
(if
(nil? class-rec)
(error (str "No class named: " class-name))
(let
((slots (dict)))
(for-each
(fn
(k)
(let
((spec (get (get class-rec "slots") k)))
(let
((initform (get spec "initform")))
(when
(not (nil? initform))
(dict-set!
slots
k
(if (callable? initform) (initform) initform))))))
(keys (get class-rec "slots")))
(define
apply-args
(fn
(args)
(when
(>= (len args) 2)
(let
((key (str (first args))) (val (first (rest args))))
(let
((skey (if (= (slice key 0 1) ":") (slice key 1 (len key)) key)))
(let
((matched false))
(for-each
(fn
(sk)
(let
((spec (get (get class-rec "slots") sk)))
(let
((ia (get spec "initarg")))
(when
(or
(= ia key)
(= ia (str ":" skey))
(= sk skey))
(dict-set! slots sk val)
(set! matched true)))))
(keys (get class-rec "slots")))))
(apply-args (rest (rest args)))))))
(apply-args initargs)
{:clos-type "instance" :slots slots :class class-name})))))
;; ── slot-value ────────────────────────────────────────────────────────────
(define
clos-slot-value
(fn
(instance slot-name)
(if
(and (dict? instance) (= (get instance "clos-type") "instance"))
(get (get instance "slots") slot-name)
(error (str "Not a CLOS instance: " (inspect instance))))))
(define
clos-set-slot-value!
(fn
(instance slot-name value)
(if
(and (dict? instance) (= (get instance "clos-type") "instance"))
(dict-set! (get instance "slots") slot-name value)
(error (str "Not a CLOS instance: " (inspect instance))))))
(define
clos-slot-boundp
(fn
(instance slot-name)
(and
(dict? instance)
(= (get instance "clos-type") "instance")
(not (nil? (get (get instance "slots") slot-name))))))
;; ── find-class / change-class ─────────────────────────────────────────────
(define clos-find-class (fn (name) (get clos-class-registry name)))
(define
clos-change-class!
(fn
(instance new-class-name)
(if
(and (dict? instance) (= (get instance "clos-type") "instance"))
(dict-set! instance "class" new-class-name)
(error (str "Not a CLOS instance: " (inspect instance))))))
;; ── defgeneric ────────────────────────────────────────────────────────────
(define
clos-defgeneric
(fn
(name options)
(let
((combination (or (get options "method-combination") "standard")))
(when
(nil? (get clos-generic-registry name))
(dict-set! clos-generic-registry name {:methods (list) :combination combination :name name}))
name)))
;; ── defmethod ─────────────────────────────────────────────────────────────
;;
;; method-fn: (fn (args next-fn) body)
;; args = list of all call arguments
;; next-fn = (fn () next-method-result) or nil
(define
clos-defmethod
(fn
(generic-name qualifiers specializers method-fn)
(when
(nil? (get clos-generic-registry generic-name))
(clos-defgeneric generic-name {}))
(let
((grec (get clos-generic-registry generic-name))
(new-method {:fn method-fn :qualifiers qualifiers :specializers specializers}))
(let
((kept (filter (fn (m) (not (and (= (get m "qualifiers") qualifiers) (= (get m "specializers") specializers)))) (get grec "methods"))))
(dict-set!
clos-generic-registry
generic-name
(assoc grec "methods" (append kept (list new-method))))
generic-name))))
;; Now install the real accessor-method installer
(set!
clos-add-reader-method
(fn
(method-name class-name slot-name)
(clos-defmethod
method-name
(list)
(list class-name)
(fn (args next-fn) (clos-slot-value (first args) slot-name)))))
;; ── method specificity ─────────────────────────────────────────────────────
(define
clos-method-matches?
(fn
(method args)
(let
((specs (get method "specializers")))
(if
(> (len specs) (len args))
false
(define
check-all
(fn
(i)
(if
(>= i (len specs))
true
(let
((spec (nth specs i)) (arg (nth args i)))
(if
(= spec "t")
(check-all (+ i 1))
(if
(clos-instance-of? arg spec)
(check-all (+ i 1))
false))))))
(check-all 0)))))
;; CLOS-side adapter for lib/guest/reflective/class-chain.sx. Classes
;; live in clos-class-registry; :parents is a list of parent class
;; names (CLOS supports multiple inheritance).
(define clos-class-cfg
{:parents-of (fn (cn)
(let ((rec (clos-find-class cn)))
(cond ((nil? rec) (list))
(:else (or (get rec "parents") (list))))))
:class? (fn (n) (not (nil? (clos-find-class n))))})
;; Precedence distance: how far class-name is from spec-name up the
;; hierarchy. Delegates to refl-class-chain-depth-with which handles
;; the multi-parent DFS with min-depth selection.
(define clos-specificity
(fn (class-name spec-name)
(refl-class-chain-depth-with clos-class-cfg class-name spec-name)))
(define
clos-method-more-specific?
(fn
(m1 m2 args)
(let
((s1 (get m1 "specializers")) (s2 (get m2 "specializers")))
(define
cmp
(fn
(i)
(if
(>= i (len s1))
false
(let
((c1 (clos-specificity (clos-class-of (nth args i)) (nth s1 i)))
(c2
(clos-specificity (clos-class-of (nth args i)) (nth s2 i))))
(cond
((and (nil? c1) (nil? c2)) (cmp (+ i 1)))
((nil? c1) false)
((nil? c2) true)
((< c1 c2) true)
((> c1 c2) false)
(:else (cmp (+ i 1))))))))
(cmp 0))))
(define
clos-sort-methods
(fn
(methods args)
(define
insert
(fn
(m sorted)
(if
(empty? sorted)
(list m)
(if
(clos-method-more-specific? m (first sorted) args)
(cons m sorted)
(cons (first sorted) (insert m (rest sorted)))))))
(reduce (fn (acc m) (insert m acc)) (list) methods)))
;; ── call-generic (standard method combination) ─────────────────────────────
(define
clos-call-generic
(fn
(generic-name args)
(let
((grec (get clos-generic-registry generic-name)))
(if
(nil? grec)
(error (str "No generic function: " generic-name))
(let
((applicable (filter (fn (m) (clos-method-matches? m args)) (get grec "methods"))))
(if
(empty? applicable)
(error
(str
"No applicable method for "
generic-name
" with classes "
(inspect (map clos-class-of args))))
(let
((primary (filter (fn (m) (empty? (get m "qualifiers"))) applicable))
(before
(filter
(fn (m) (= (get m "qualifiers") (list "before")))
applicable))
(after
(filter
(fn (m) (= (get m "qualifiers") (list "after")))
applicable))
(around
(filter
(fn (m) (= (get m "qualifiers") (list "around")))
applicable)))
(let
((sp (clos-sort-methods primary args))
(sb (clos-sort-methods before args))
(sa (clos-sort-methods after args))
(sw (clos-sort-methods around args)))
(define
make-primary-chain
(fn
(methods)
(if
(empty? methods)
(fn
()
(error (str "No next primary method: " generic-name)))
(fn
()
((get (first methods) "fn")
args
(make-primary-chain (rest methods)))))))
(define
make-around-chain
(fn
(around-methods inner-thunk)
(if
(empty? around-methods)
inner-thunk
(fn
()
((get (first around-methods) "fn")
args
(make-around-chain
(rest around-methods)
inner-thunk))))))
(for-each (fn (m) ((get m "fn") args (fn () nil))) sb)
(let
((primary-thunk (make-primary-chain sp)))
(let
((result (if (empty? sw) (primary-thunk) ((make-around-chain sw primary-thunk)))))
(for-each
(fn (m) ((get m "fn") args (fn () nil)))
(reverse sa))
result))))))))))
;; ── call-next-method / next-method-p ──────────────────────────────────────
(define clos-call-next-method (fn (next-fn) (next-fn)))
(define clos-next-method-p (fn (next-fn) (not (nil? next-fn))))
;; ── with-slots ────────────────────────────────────────────────────────────
(define
clos-with-slots
(fn
(instance slot-names body-fn)
(let
((vals (map (fn (s) (clos-slot-value instance s)) slot-names)))
(apply body-fn vals))))

161
lib/common-lisp/conformance.sh
View File

@@ -1,161 +0,0 @@
#!/usr/bin/env bash
# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner
#
# Runs all Common Lisp test suites and writes scoreboard.json + scoreboard.md.
#
# Usage:
# bash lib/common-lisp/conformance.sh
# bash lib/common-lisp/conformance.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."
exit 1
fi
VERBOSE="${1:-}"
TOTAL_PASS=0; TOTAL_FAIL=0
SUITE_NAMES=()
SUITE_PASS=()
SUITE_FAIL=()
# run_suite NAME "file1 file2 ..." PASS_VAR FAIL_VAR FAILURES_VAR
run_suite() {
local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
local TMP; TMP=$(mktemp)
{
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(load "lib/guest/prefix.sx")\n'
local i=2
for f in $load_files; do
printf '(epoch %d)\n(load "%s")\n' "$i" "$f"
i=$((i+1))
done
printf '(epoch 100)\n(eval "%s")\n' "$pass_var"
printf '(epoch 101)\n(eval "%s")\n' "$fail_var"
} > "$TMP"
local OUT; OUT=$(timeout 30 "$SX_SERVER" < "$TMP" 2>/dev/null)
rm -f "$TMP"
local P F
P=$(echo "$OUT" | grep -A1 "^(ok-len 100 " | tail -1 | tr -d ' ()' || true)
F=$(echo "$OUT" | grep -A1 "^(ok-len 101 " | tail -1 | tr -d ' ()' || true)
# Also try plain (ok 100 N) format
[ -z "$P" ] && P=$(echo "$OUT" | grep "^(ok 100 " | awk '{print $3}' | tr -d ')' || true)
[ -z "$F" ] && F=$(echo "$OUT" | grep "^(ok 101 " | awk '{print $3}' | tr -d ')' || true)
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
SUITE_NAMES+=("$name")
SUITE_PASS+=("$P")
SUITE_FAIL+=("$F")
TOTAL_PASS=$((TOTAL_PASS + P))
TOTAL_FAIL=$((TOTAL_FAIL + F))
if [ "$F" = "0" ] && [ "${P:-0}" -gt 0 ] 2>/dev/null; then
echo " PASS $name ($P tests)"
else
echo " FAIL $name ($P passed, $F failed)"
fi
}
echo "=== Common Lisp on SX — Conformance Run ==="
echo ""
run_suite "Phase 1: tokenizer/reader" \
"lib/common-lisp/reader.sx lib/common-lisp/tests/read.sx" \
"cl-test-pass" "cl-test-fail" "cl-test-fails"
run_suite "Phase 1: parser/lambda-lists" \
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/tests/lambda.sx" \
"cl-test-pass" "cl-test-fail" "cl-test-fails"
run_suite "Phase 2: evaluator" \
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/eval.sx" \
"cl-test-pass" "cl-test-fail" "cl-test-fails"
run_suite "Phase 3: condition system" \
"lib/common-lisp/runtime.sx lib/common-lisp/tests/conditions.sx" \
"passed" "failed" "failures"
run_suite "Phase 3: restart-demo" \
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/restart-demo.sx" \
"demo-passed" "demo-failed" "demo-failures"
run_suite "Phase 3: parse-recover" \
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/parse-recover.sx" \
"parse-passed" "parse-failed" "parse-failures"
run_suite "Phase 3: interactive-debugger" \
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \
"debugger-passed" "debugger-failed" "debugger-failures"
run_suite "Phase 4: CLOS" \
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \
"passed" "failed" "failures"
run_suite "Phase 4: geometry" \
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \
"geo-passed" "geo-failed" "geo-failures"
run_suite "Phase 4: mop-trace" \
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \
"mop-passed" "mop-failed" "mop-failures"
run_suite "Phase 5: macros+LOOP" \
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx lib/common-lisp/tests/macros.sx" \
"macro-passed" "macro-failed" "macro-failures"
run_suite "Phase 6: stdlib" \
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/stdlib.sx" \
"stdlib-passed" "stdlib-failed" "stdlib-failures"
echo ""
echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ==="
# ── write scoreboard.json ─────────────────────────────────────────────────
SCORE_DIR="lib/common-lisp"
JSON="$SCORE_DIR/scoreboard.json"
{
printf '{\n'
printf ' "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
printf ' "suites": [\n'
first=true
for i in "${!SUITE_NAMES[@]}"; do
if [ "$first" = "true" ]; then first=false; else printf ',\n'; fi
printf ' {"name": "%s", "pass": %d, "fail": %d}' \
"${SUITE_NAMES[$i]}" "${SUITE_PASS[$i]}" "${SUITE_FAIL[$i]}"
done
printf '\n ]\n'
printf '}\n'
} > "$JSON"
# ── write scoreboard.md ───────────────────────────────────────────────────
MD="$SCORE_DIR/scoreboard.md"
{
printf '# Common Lisp on SX — Scoreboard\n\n'
printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
printf '| Suite | Pass | Fail | Status |\n'
printf '|-------|------|------|--------|\n'
for i in "${!SUITE_NAMES[@]}"; do
p="${SUITE_PASS[$i]}" f="${SUITE_FAIL[$i]}"
status=""
if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then
status="pass"
else
status="FAIL"
fi
printf '| %s | %s | %s | %s |\n' "${SUITE_NAMES[$i]}" "$p" "$f" "$status"
done
printf '\n**Total: %d passed, %d failed**\n' "$TOTAL_PASS" "$TOTAL_FAIL"
} > "$MD"
echo ""
echo "Scoreboard written to $JSON and $MD"
[ "$TOTAL_FAIL" -eq 0 ]

1391
lib/common-lisp/eval.sx
View File

File diff suppressed because it is too large Load Diff

623
lib/common-lisp/loop.sx
View File

@@ -1,623 +0,0 @@
;; lib/common-lisp/loop.sx — The LOOP macro for CL-on-SX
;;
;; Supported clauses:
;; for VAR in LIST — iterate over list
;; for VAR across VECTOR — alias for 'in'
;; for VAR from N — numeric iteration (to/upto/below/downto/above/by)
;; for VAR = EXPR [then EXPR] — general iteration
;; while COND — stop when false
;; until COND — stop when true
;; repeat N — repeat N times
;; collect EXPR [into VAR]
;; append EXPR [into VAR]
;; nconc EXPR [into VAR]
;; sum EXPR [into VAR]
;; count EXPR [into VAR]
;; maximize EXPR [into VAR]
;; minimize EXPR [into VAR]
;; do FORM...
;; when/if COND clause...
;; unless COND clause...
;; finally FORM...
;; always COND
;; never COND
;; thereis COND
;; named BLOCK-NAME
;;
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/eval.sx already loaded.
;; Uses defmacro in the CL evaluator.
;; ── LOOP expansion driver ─────────────────────────────────────────────────
;; cl-loop-parse: analyse the flat LOOP clause list and build a Lisp form.
;; Returns a (block NAME (let (...) (tagbody ...))) form.
(define
cl-loop-parse
(fn
(clauses)
(define block-name nil)
(define with-bindings (list))
(define for-bindings (list))
(define test-forms (list))
(define repeat-var nil)
(define repeat-count nil)
(define body-forms (list))
(define accum-vars (dict))
(define accum-clauses (dict))
(define result-var nil)
(define finally-forms (list))
(define return-expr nil)
(define termination nil)
(define idx 0)
(define (lp-peek) (if (< idx (len clauses)) (nth clauses idx) nil))
(define
(next!)
(let ((v (lp-peek))) (do (set! idx (+ idx 1)) v)))
(define
(skip-if pred)
(if (and (not (nil? (lp-peek))) (pred (lp-peek))) (next!) nil))
(define (upcase-str s) (if (string? s) (upcase s) s))
(define (kw? s k) (= (upcase-str s) k))
(define
(make-accum-var!)
(if
(nil? result-var)
(do (set! result-var "#LOOP-RESULT") result-var)
result-var))
(define
(add-accum! type expr into-var)
(let
((v (if (nil? into-var) (make-accum-var!) into-var)))
(if
(not (has-key? accum-vars v))
(do
(set!
accum-vars
(assoc
accum-vars
v
(cond
((= type ":sum") 0)
((= type ":count") 0)
((= type ":maximize") nil)
((= type ":minimize") nil)
(:else (list)))))
(set! accum-clauses (assoc accum-clauses v type))))
(let
((update (cond ((= type ":collect") (list "SETQ" v (list "APPEND" v (list "LIST" expr)))) ((= type ":append") (list "SETQ" v (list "APPEND" v expr))) ((= type ":nconc") (list "SETQ" v (list "NCONC" v expr))) ((= type ":sum") (list "SETQ" v (list "+" v expr))) ((= type ":count") (list "SETQ" v (list "+" v (list "IF" expr 1 0)))) ((= type ":maximize") (list "SETQ" v (list "IF" (list "OR" (list "NULL" v) (list ">" expr v)) expr v))) ((= type ":minimize") (list "SETQ" v (list "IF" (list "OR" (list "NULL" v) (list "<" expr v)) expr v))) (:else (list "SETQ" v (list "APPEND" v (list "LIST" expr)))))))
(set! body-forms (append body-forms (list update))))))
(define
(parse-clause!)
(let
((tok (lp-peek)))
(if
(nil? tok)
nil
(do
(let
((u (upcase-str tok)))
(cond
((= u "NAMED")
(do (next!) (set! block-name (next!)) (parse-clause!)))
((= u "WITH")
(do
(next!)
(let
((var (next!)))
(skip-if (fn (s) (kw? s "=")))
(let
((init (next!)))
(set!
with-bindings
(append with-bindings (list (list var init))))
(parse-clause!)))))
((= u "FOR")
(do
(next!)
(let
((var (next!)))
(let
((kw2 (upcase-str (lp-peek))))
(cond
((or (= kw2 "IN") (= kw2 "ACROSS"))
(do
(next!)
(let
((lst-expr (next!))
(tail-var (str "#TAIL-" var)))
(set!
for-bindings
(append for-bindings (list {:list lst-expr :tail tail-var :type ":list" :var var})))
(parse-clause!))))
((= kw2 "=")
(do
(next!)
(let
((init-expr (next!)))
(let
((then-expr (if (kw? (lp-peek) "THEN") (do (next!) (next!)) init-expr)))
(set!
for-bindings
(append for-bindings (list {:type ":general" :then then-expr :init init-expr :var var})))
(parse-clause!)))))
((or (= kw2 "FROM") (= kw2 "DOWNFROM") (= kw2 "UPFROM"))
(do
(next!)
(let
((from-expr (next!))
(dir (if (= kw2 "DOWNFROM") ":down" ":up"))
(limit-expr nil)
(limit-type nil)
(step-expr 1))
(let
((lkw (upcase-str (lp-peek))))
(when
(or
(= lkw "TO")
(= lkw "UPTO")
(= lkw "BELOW")
(= lkw "DOWNTO")
(= lkw "ABOVE"))
(do
(next!)
(set! limit-type lkw)
(set! limit-expr (next!)))))
(when
(kw? (lp-peek) "BY")
(do (next!) (set! step-expr (next!))))
(set!
for-bindings
(append for-bindings (list {:dir dir :step step-expr :from from-expr :type ":numeric" :limit-type limit-type :var var :limit limit-expr})))
(parse-clause!))))
((or (= kw2 "TO") (= kw2 "UPTO") (= kw2 "BELOW"))
(do
(next!)
(let
((limit-expr (next!))
(step-expr 1))
(when
(kw? (lp-peek) "BY")
(do (next!) (set! step-expr (next!))))
(set!
for-bindings
(append for-bindings (list {:dir ":up" :step step-expr :from 0 :type ":numeric" :limit-type kw2 :var var :limit limit-expr})))
(parse-clause!))))
(:else (do (parse-clause!))))))))
((= u "WHILE")
(do
(next!)
(set! test-forms (append test-forms (list {:expr (next!) :type ":while"})))
(parse-clause!)))
((= u "UNTIL")
(do
(next!)
(set! test-forms (append test-forms (list {:expr (next!) :type ":until"})))
(parse-clause!)))
((= u "REPEAT")
(do
(next!)
(set! repeat-count (next!))
(set! repeat-var "#REPEAT-COUNT")
(parse-clause!)))
((or (= u "COLLECT") (= u "COLLECTING"))
(do
(next!)
(let
((expr (next!)) (into-var nil))
(when
(kw? (lp-peek) "INTO")
(do (next!) (set! into-var (next!))))
(add-accum! ":collect" expr into-var)
(parse-clause!))))
((or (= u "APPEND") (= u "APPENDING"))
(do
(next!)
(let
((expr (next!)) (into-var nil))
(when
(kw? (lp-peek) "INTO")
(do (next!) (set! into-var (next!))))
(add-accum! ":append" expr into-var)
(parse-clause!))))
((or (= u "NCONC") (= u "NCONCING"))
(do
(next!)
(let
((expr (next!)) (into-var nil))
(when
(kw? (lp-peek) "INTO")
(do (next!) (set! into-var (next!))))
(add-accum! ":nconc" expr into-var)
(parse-clause!))))
((or (= u "SUM") (= u "SUMMING"))
(do
(next!)
(let
((expr (next!)) (into-var nil))
(when
(kw? (lp-peek) "INTO")
(do (next!) (set! into-var (next!))))
(add-accum! ":sum" expr into-var)
(parse-clause!))))
((or (= u "COUNT") (= u "COUNTING"))
(do
(next!)
(let
((expr (next!)) (into-var nil))
(when
(kw? (lp-peek) "INTO")
(do (next!) (set! into-var (next!))))
(add-accum! ":count" expr into-var)
(parse-clause!))))
((or (= u "MAXIMIZE") (= u "MAXIMIZING"))
(do
(next!)
(let
((expr (next!)) (into-var nil))
(when
(kw? (lp-peek) "INTO")
(do (next!) (set! into-var (next!))))
(add-accum! ":maximize" expr into-var)
(parse-clause!))))
((or (= u "MINIMIZE") (= u "MINIMIZING"))
(do
(next!)
(let
((expr (next!)) (into-var nil))
(when
(kw? (lp-peek) "INTO")
(do (next!) (set! into-var (next!))))
(add-accum! ":minimize" expr into-var)
(parse-clause!))))
((= u "DO")
(do
(next!)
(define
(loop-kw? s)
(let
((us (upcase-str s)))
(some
(fn (k) (= us k))
(list
"FOR"
"WITH"
"WHILE"
"UNTIL"
"REPEAT"
"COLLECT"
"COLLECTING"
"APPEND"
"APPENDING"
"NCONC"
"NCONCING"
"SUM"
"SUMMING"
"COUNT"
"COUNTING"
"MAXIMIZE"
"MAXIMIZING"
"MINIMIZE"
"MINIMIZING"
"DO"
"WHEN"
"IF"
"UNLESS"
"FINALLY"
"ALWAYS"
"NEVER"
"THEREIS"
"RETURN"
"NAMED"))))
(define
(collect-do-forms!)
(if
(or (nil? (lp-peek)) (loop-kw? (lp-peek)))
nil
(do
(set!
body-forms
(append body-forms (list (next!))))
(collect-do-forms!))))
(collect-do-forms!)
(parse-clause!)))
((or (= u "WHEN") (= u "IF"))
(do
(next!)
(let
((cond-expr (next!))
(body-start (len body-forms)))
(parse-clause!)
;; wrap forms added since body-start in (WHEN cond ...)
(when (> (len body-forms) body-start)
(let ((added (list (nth body-forms body-start))))
(set! body-forms
(append
(if (> body-start 0)
(list (nth body-forms (- body-start 1)))
(list))
(list (list "WHEN" cond-expr (first added)))))
nil)))))
((= u "UNLESS")
(do
(next!)
(let
((cond-expr (next!))
(body-start (len body-forms)))
(parse-clause!)
(when (> (len body-forms) body-start)
(let ((added (list (nth body-forms body-start))))
(set! body-forms
(append
(if (> body-start 0)
(list (nth body-forms (- body-start 1)))
(list))
(list (list "UNLESS" cond-expr (first added)))))
nil)))))
((= u "ALWAYS")
(do (next!) (set! termination {:expr (next!) :type ":always"}) (parse-clause!)))
((= u "NEVER")
(do (next!) (set! termination {:expr (next!) :type ":never"}) (parse-clause!)))
((= u "THEREIS")
(do (next!) (set! termination {:expr (next!) :type ":thereis"}) (parse-clause!)))
((= u "RETURN")
(do (next!) (set! return-expr (next!)) (parse-clause!)))
((= u "FINALLY")
(do
(next!)
(define
(collect-finally!)
(if
(nil? (lp-peek))
nil
(do
(set!
finally-forms
(append finally-forms (list (next!))))
(collect-finally!))))
(collect-finally!)
(parse-clause!)))
(:else
(do
(set! body-forms (append body-forms (list (next!))))
(parse-clause!)))))))))
(parse-clause!)
(define let-bindings (list))
(for-each
(fn (wb) (set! let-bindings (append let-bindings (list wb))))
with-bindings)
(for-each
(fn
(v)
(set!
let-bindings
(append let-bindings (list (list v (get accum-vars v))))))
(keys accum-vars))
(when
(not (nil? repeat-var))
(set!
let-bindings
(append let-bindings (list (list repeat-var repeat-count)))))
(for-each
(fn
(fb)
(let
((type (get fb "type")))
(cond
((= type ":list")
(do
(set!
let-bindings
(append
let-bindings
(list (list (get fb "tail") (get fb "list")))
(list
(list
(get fb "var")
(list
"IF"
(list "CONSP" (get fb "tail"))
(list "CAR" (get fb "tail"))
nil)))))
nil))
((= type ":numeric")
(set!
let-bindings
(append
let-bindings
(list (list (get fb "var") (get fb "from"))))))
((= type ":general")
(set!
let-bindings
(append
let-bindings
(list (list (get fb "var") (get fb "init"))))))
(:else nil))))
for-bindings)
(define all-tests (list))
(when
(not (nil? repeat-var))
(set!
all-tests
(append
all-tests
(list
(list
"WHEN"
(list "<=" repeat-var 0)
(list "RETURN-FROM" block-name (if (nil? result-var) nil result-var))))))
(set!
body-forms
(append
(list (list "SETQ" repeat-var (list "-" repeat-var 1)))
body-forms)))
(for-each
(fn
(fb)
(when
(= (get fb "type") ":list")
(let
((tvar (get fb "tail")) (var (get fb "var")))
(set!
all-tests
(append
all-tests
(list
(list
"WHEN"
(list "NULL" tvar)
(list
"RETURN-FROM"
block-name
(if (nil? result-var) nil result-var))))))
(set!
body-forms
(append
body-forms
(list
(list "SETQ" tvar (list "CDR" tvar))
(list
"SETQ"
var
(list "IF" (list "CONSP" tvar) (list "CAR" tvar) nil))))))))
for-bindings)
(for-each
(fn
(fb)
(when
(= (get fb "type") ":numeric")
(let
((var (get fb "var"))
(dir (get fb "dir"))
(lim (get fb "limit"))
(ltype (get fb "limit-type"))
(step (get fb "step")))
(when
(not (nil? lim))
(let
((test-op (cond ((or (= ltype "BELOW") (= ltype "ABOVE")) (if (= dir ":up") ">=" "<=")) ((or (= ltype "TO") (= ltype "UPTO")) ">") ((= ltype "DOWNTO") "<") (:else (if (= dir ":up") ">" "<")))))
(set!
all-tests
(append
all-tests
(list
(list
"WHEN"
(list test-op var lim)
(list
"RETURN-FROM"
block-name
(if (nil? result-var) nil result-var))))))))
(let
((step-op (if (or (= dir ":down") (= ltype "DOWNTO") (= ltype "ABOVE")) "-" "+")))
(set!
body-forms
(append
body-forms
(list (list "SETQ" var (list step-op var step)))))))))
for-bindings)
(for-each
(fn
(fb)
(when
(= (get fb "type") ":general")
(set!
body-forms
(append
body-forms
(list (list "SETQ" (get fb "var") (get fb "then")))))))
for-bindings)
(for-each
(fn
(t)
(let
((type (get t "type")) (expr (get t "expr")))
(if
(= type ":while")
(set!
all-tests
(append
all-tests
(list
(list
"WHEN"
(list "NOT" expr)
(list
"RETURN-FROM"
block-name
(if (nil? result-var) nil result-var))))))
(set!
all-tests
(append
all-tests
(list
(list
"WHEN"
expr
(list
"RETURN-FROM"
block-name
(if (nil? result-var) nil result-var)))))))))
test-forms)
(when
(not (nil? termination))
(let
((type (get termination "type")) (expr (get termination "expr")))
(cond
((= type ":always")
(set!
body-forms
(append
body-forms
(list
(list "UNLESS" expr (list "RETURN-FROM" block-name false)))))
(set! return-expr true))
((= type ":never")
(set!
body-forms
(append
body-forms
(list
(list "WHEN" expr (list "RETURN-FROM" block-name false)))))
(set! return-expr true))
((= type ":thereis")
(set!
body-forms
(append
body-forms
(list
(list "WHEN" expr (list "RETURN-FROM" block-name expr)))))))))
(define tag "#LOOP-START")
(define
inner-body
(append (list tag) all-tests body-forms (list (list "GO" tag))))
(define
result-form
(cond
((not (nil? return-expr)) return-expr)
((not (nil? result-var)) result-var)
(:else nil)))
(define
full-body
(if
(= (len let-bindings) 0)
(append
(list "PROGN")
(list (append (list "TAGBODY") inner-body))
finally-forms
(list result-form))
(list
"LET*"
let-bindings
(append (list "TAGBODY") inner-body)
(append (list "PROGN") finally-forms (list result-form)))))
(list "BLOCK" block-name full-body)))
;; ── Install LOOP as a CL macro ────────────────────────────────────────────
;;
;; (loop ...) — the form arrives with head "LOOP" and rest = clauses.
;; The macro fn receives the full form.
(dict-set!
cl-macro-registry
"LOOP"
(fn (form env) (cl-loop-parse (rest form))))

377
lib/common-lisp/parser.sx
View File

@@ -1,377 +0,0 @@
;; Common Lisp reader — converts token stream to CL AST forms.
;;
;; Depends on: lib/common-lisp/reader.sx (cl-tokenize)
;;
;; AST representation:
;; integer/float → SX number (or {:cl-type "float"/:ratio ...})
;; string "hello" → {:cl-type "string" :value "hello"}
;; symbol FOO → SX string "FOO" (upcase)
;; symbol NIL → nil
;; symbol T → true
;; :keyword → {:cl-type "keyword" :name "FOO"}
;; #\char → {:cl-type "char" :value "a"}
;; #:uninterned → {:cl-type "uninterned" :name "FOO"}
;; ratio 1/3 → {:cl-type "ratio" :value "1/3"}
;; float 3.14 → {:cl-type "float" :value "3.14"}
;; proper list (a b c) → SX list (a b c)
;; dotted pair (a . b) → {:cl-type "cons" :car a :cdr b}
;; vector #(a b) → {:cl-type "vector" :elements (list a b)}
;; 'x → ("QUOTE" x)
;; `x → ("QUASIQUOTE" x)
;; ,x → ("UNQUOTE" x)
;; ,@x → ("UNQUOTE-SPLICING" x)
;; #'x → ("FUNCTION" x)
;;
;; Public API:
;; (cl-read src) — parse first form from string, return form
;; (cl-read-all src) — parse all top-level forms, return list
;; ── number conversion ─────────────────────────────────────────────
(define
cl-hex-val
(fn
(c)
(let
((o (cl-ord c)))
(cond
((and (>= o 48) (<= o 57)) (- o 48))
((and (>= o 65) (<= o 70)) (+ 10 (- o 65)))
((and (>= o 97) (<= o 102)) (+ 10 (- o 97)))
(:else 0)))))
(define
cl-parse-radix-str
(fn
(s radix start)
(let
((n (string-length s)) (i start) (acc 0))
(define
loop
(fn
()
(when
(< i n)
(do
(set! acc (+ (* acc radix) (cl-hex-val (substring s i (+ i 1)))))
(set! i (+ i 1))
(loop)))))
(loop)
acc)))
(define
cl-convert-integer
(fn
(s)
(let
((n (string-length s)) (neg false))
(cond
((and (> n 2) (= (substring s 0 1) "#"))
(let
((letter (downcase (substring s 1 2))))
(cond
((= letter "x") (cl-parse-radix-str s 16 2))
((= letter "b") (cl-parse-radix-str s 2 2))
((= letter "o") (cl-parse-radix-str s 8 2))
(:else (parse-int s 0)))))
(:else (parse-int s 0))))))
;; ── reader ────────────────────────────────────────────────────────
;; Read one form from token list.
;; Returns {:form F :rest remaining-toks} or {:form nil :rest toks :eof true}
(define
cl-read-form
(fn
(toks)
(if
(not toks)
{:form nil :rest toks :eof true}
(let
((tok (nth toks 0)) (nxt (rest toks)))
(let
((type (get tok "type")) (val (get tok "value")))
(cond
((= type "eof") {:form nil :rest toks :eof true})
((= type "integer") {:form (cl-convert-integer val) :rest nxt})
((= type "float") {:form {:cl-type "float" :value val} :rest nxt})
((= type "ratio") {:form {:cl-type "ratio" :value val} :rest nxt})
((= type "string") {:form {:cl-type "string" :value val} :rest nxt})
((= type "char") {:form {:cl-type "char" :value val} :rest nxt})
((= type "keyword") {:form {:cl-type "keyword" :name val} :rest nxt})
((= type "uninterned") {:form {:cl-type "uninterned" :name val} :rest nxt})
((= type "symbol")
(cond
((= val "NIL") {:form nil :rest nxt})
((= val "T") {:form true :rest nxt})
(:else {:form val :rest nxt})))
;; list forms
((= type "lparen") (cl-read-list nxt))
((= type "hash-paren") (cl-read-vector nxt))
;; reader macros that wrap the next form
((= type "quote") (cl-read-wrap "QUOTE" nxt))
((= type "backquote") (cl-read-wrap "QUASIQUOTE" nxt))
((= type "comma") (cl-read-wrap "UNQUOTE" nxt))
((= type "comma-at") (cl-read-wrap "UNQUOTE-SPLICING" nxt))
((= type "hash-quote") (cl-read-wrap "FUNCTION" nxt))
;; skip unrecognised tokens
(:else (cl-read-form nxt))))))))
;; Wrap next form in a list: (name form)
(define
cl-read-wrap
(fn
(name toks)
(let
((inner (cl-read-form toks)))
{:form (list name (get inner "form")) :rest (get inner "rest")})))
;; Read list forms until ')'; handles dotted pair (a . b)
;; Called after consuming '('
(define
cl-read-list
(fn
(toks)
(let
((result (cl-read-list-items toks (list))))
{:form (get result "items") :rest (get result "rest")})))
(define
cl-read-list-items
(fn
(toks acc)
(if
(not toks)
{:items acc :rest toks}
(let
((tok (nth toks 0)))
(let
((type (get tok "type")))
(cond
((= type "eof") {:items acc :rest toks})
((= type "rparen") {:items acc :rest (rest toks)})
;; dotted pair: read one more form then expect ')'
((= type "dot")
(let
((cdr-result (cl-read-form (rest toks))))
(let
((cdr-form (get cdr-result "form"))
(after-cdr (get cdr-result "rest")))
;; skip the closing ')'
(let
((close (if after-cdr (nth after-cdr 0) nil)))
(let
((remaining
(if
(and close (= (get close "type") "rparen"))
(rest after-cdr)
after-cdr)))
;; build dotted structure
(let
((dotted (cl-build-dotted acc cdr-form)))
{:items dotted :rest remaining}))))))
(:else
(let
((item (cl-read-form toks)))
(cl-read-list-items
(get item "rest")
(concat acc (list (get item "form"))))))))))))
;; Build dotted form: (a b . c) → ((DOTTED a b) . c) style
;; In CL (a b c . d) means a proper dotted structure.
;; We represent it as {:cl-type "cons" :car a :cdr (list->dotted b c d)}
(define
cl-build-dotted
(fn
(head-items tail)
(if
(= (len head-items) 0)
tail
(if
(= (len head-items) 1)
{:cl-type "cons" :car (nth head-items 0) :cdr tail}
(let
((last-item (nth head-items (- (len head-items) 1)))
(but-last (slice head-items 0 (- (len head-items) 1))))
{:cl-type "cons"
:car (cl-build-dotted but-last (list last-item))
:cdr tail})))))
;; Read vector #(…) elements until ')'
(define
cl-read-vector
(fn
(toks)
(let
((result (cl-read-vector-items toks (list))))
{:form {:cl-type "vector" :elements (get result "items")} :rest (get result "rest")})))
(define
cl-read-vector-items
(fn
(toks acc)
(if
(not toks)
{:items acc :rest toks}
(let
((tok (nth toks 0)))
(let
((type (get tok "type")))
(cond
((= type "eof") {:items acc :rest toks})
((= type "rparen") {:items acc :rest (rest toks)})
(:else
(let
((item (cl-read-form toks)))
(cl-read-vector-items
(get item "rest")
(concat acc (list (get item "form"))))))))))))
;; ── lambda-list parser ───────────────────────────────────────────
;;
;; (cl-parse-lambda-list forms) — parse a list of CL forms (already read)
;; into a structured dict:
;; {:required (list sym ...)
;; :optional (list {:name N :default D :supplied S} ...)
;; :rest nil | "SYM"
;; :key (list {:name N :keyword K :default D :supplied S} ...)
;; :allow-other-keys false | true
;; :aux (list {:name N :init I} ...)}
;;
;; Symbols arrive as SX strings (upcase). &-markers are strings like "&OPTIONAL".
;; Key params: keyword is the upcase name string; caller uses it as :keyword.
;; Supplied-p: nil when absent.
(define
cl-parse-opt-spec
(fn
(spec)
(if
(list? spec)
{:name (nth spec 0)
:default (if (> (len spec) 1) (nth spec 1) nil)
:supplied (if (> (len spec) 2) (nth spec 2) nil)}
{:name spec :default nil :supplied nil})))
(define
cl-parse-key-spec
(fn
(spec)
(if
(list? spec)
(let
((first (nth spec 0)))
(if
(list? first)
;; ((:keyword var) default supplied-p)
{:name (nth first 1)
:keyword (get first "name")
:default (if (> (len spec) 1) (nth spec 1) nil)
:supplied (if (> (len spec) 2) (nth spec 2) nil)}
;; (var default supplied-p)
{:name first
:keyword first
:default (if (> (len spec) 1) (nth spec 1) nil)
:supplied (if (> (len spec) 2) (nth spec 2) nil)}))
{:name spec :keyword spec :default nil :supplied nil})))
(define
cl-parse-aux-spec
(fn
(spec)
(if
(list? spec)
{:name (nth spec 0) :init (if (> (len spec) 1) (nth spec 1) nil)}
{:name spec :init nil})))
(define
cl-parse-lambda-list
(fn
(forms)
(let
((state "required")
(required (list))
(optional (list))
(rest-name nil)
(key (list))
(allow-other-keys false)
(aux (list)))
(define
scan
(fn
(items)
(when
(> (len items) 0)
(let
((item (nth items 0)) (tail (rest items)))
(cond
((= item "&OPTIONAL")
(do (set! state "optional") (scan tail)))
((= item "&REST")
(do (set! state "rest") (scan tail)))
((= item "&BODY")
(do (set! state "rest") (scan tail)))
((= item "&KEY")
(do (set! state "key") (scan tail)))
((= item "&AUX")
(do (set! state "aux") (scan tail)))
((= item "&ALLOW-OTHER-KEYS")
(do (set! allow-other-keys true) (scan tail)))
((= state "required")
(do (append! required item) (scan tail)))
((= state "optional")
(do (append! optional (cl-parse-opt-spec item)) (scan tail)))
((= state "rest")
(do (set! rest-name item) (set! state "done") (scan tail)))
((= state "key")
(do (append! key (cl-parse-key-spec item)) (scan tail)))
((= state "aux")
(do (append! aux (cl-parse-aux-spec item)) (scan tail)))
(:else (scan tail)))))))
(scan forms)
{:required required
:optional optional
:rest rest-name
:key key
:allow-other-keys allow-other-keys
:aux aux})))
;; Convenience: parse lambda list from a CL source string
(define
cl-parse-lambda-list-str
(fn
(src)
(cl-parse-lambda-list (cl-read src))))
;; ── public API ────────────────────────────────────────────────────
(define
cl-read
(fn
(src)
(let
((toks (cl-tokenize src)))
(get (cl-read-form toks) "form"))))
(define
cl-read-all
(fn
(src)
(let
((toks (cl-tokenize src)))
(define
loop
(fn
(toks acc)
(if
(or (not toks) (= (get (nth toks 0) "type") "eof"))
acc
(let
((result (cl-read-form toks)))
(if
(get result "eof")
acc
(loop (get result "rest") (concat acc (list (get result "form")))))))))
(loop toks (list)))))

381
lib/common-lisp/reader.sx
View File

@@ -1,381 +0,0 @@
;; Common Lisp tokenizer
;;
;; Tokens: {:type T :value V :pos P}
;;
;; Types:
;; "symbol" — FOO, PKG:SYM, PKG::SYM, T, NIL (upcase)
;; "keyword" — :foo (value is upcase name without colon)
;; "integer" — 42, -5, #xFF, #b1010, #o17 (string)
;; "float" — 3.14, 1.0e10 (string)
;; "ratio" — 1/3 (string "N/D")
;; "string" — unescaped content
;; "char" — single-character string
;; "lparen" "rparen" "quote" "backquote" "comma" "comma-at"
;; "hash-quote" — #'
;; "hash-paren" — #(
;; "uninterned" — #:foo (upcase name)
;; "dot" — standalone . (dotted pair separator)
;; "eof"
(define cl-make-tok (fn (type value pos) {:type type :value value :pos pos}))
;; ── char ordinal table ────────────────────────────────────────────
(define
cl-ord-table
(let
((t (dict)) (i 0))
(define
cl-fill
(fn
()
(when
(< i 128)
(do
(dict-set! t (char-from-code i) i)
(set! i (+ i 1))
(cl-fill)))))
(cl-fill)
t))
(define cl-ord (fn (c) (or (get cl-ord-table c) 0)))
;; ── character predicates ──────────────────────────────────────────
(define cl-digit? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 57))))
(define
cl-hex?
(fn
(c)
(or
(cl-digit? c)
(and (>= (cl-ord c) 65) (<= (cl-ord c) 70))
(and (>= (cl-ord c) 97) (<= (cl-ord c) 102)))))
(define cl-octal? (fn (c) (and (>= (cl-ord c) 48) (<= (cl-ord c) 55))))
(define cl-binary? (fn (c) (or (= c "0") (= c "1"))))
(define cl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
(define
cl-alpha?
(fn
(c)
(or
(and (>= (cl-ord c) 65) (<= (cl-ord c) 90))
(and (>= (cl-ord c) 97) (<= (cl-ord c) 122)))))
;; Characters that end a token (whitespace + terminating macro chars)
(define
cl-terminating?
(fn
(c)
(or
(cl-ws? c)
(= c "(")
(= c ")")
(= c "\"")
(= c ";")
(= c "`")
(= c ","))))
;; Symbol constituent: not terminating, not reader-special
(define
cl-sym-char?
(fn
(c)
(not
(or
(cl-terminating? c)
(= c "#")
(= c "|")
(= c "\\")
(= c "'")))))
;; ── named character table ─────────────────────────────────────────
(define
cl-named-chars
{:space " "
:newline "\n"
:tab "\t"
:return "\r"
:backspace (char-from-code 8)
:rubout (char-from-code 127)
:delete (char-from-code 127)
:escape (char-from-code 27)
:altmode (char-from-code 27)
:null (char-from-code 0)
:nul (char-from-code 0)
:page (char-from-code 12)
:formfeed (char-from-code 12)})
;; ── main tokenizer ────────────────────────────────────────────────
(define
cl-tokenize
(fn
(src)
(let
((pos 0) (n (string-length src)) (toks (list)))
(define at (fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
(define peek1 (fn () (if (< (+ pos 1) n) (substring src (+ pos 1) (+ pos 2)) nil)))
(define adv (fn () (set! pos (+ pos 1))))
;; Advance while predicate holds; return substring from start to end
(define
read-while
(fn
(pred)
(let
((start pos))
(define
rw-loop
(fn
()
(when
(and (at) (pred (at)))
(do (adv) (rw-loop)))))
(rw-loop)
(substring src start pos))))
(define
skip-line
(fn
()
(when
(and (at) (not (= (at) "\n")))
(do (adv) (skip-line)))))
(define
skip-block
(fn
(depth)
(when
(at)
(cond
((and (= (at) "#") (= (peek1) "|"))
(do (adv) (adv) (skip-block (+ depth 1))))
((and (= (at) "|") (= (peek1) "#"))
(do
(adv)
(adv)
(when (> depth 1) (skip-block (- depth 1)))))
(:else (do (adv) (skip-block depth)))))))
;; Read string literal — called with pos just past opening "
(define
read-str
(fn
(acc)
(if
(not (at))
acc
(cond
((= (at) "\"") (do (adv) acc))
((= (at) "\\")
(do
(adv)
(let
((e (at)))
(adv)
(read-str
(str
acc
(cond
((= e "n") "\n")
((= e "t") "\t")
((= e "r") "\r")
((= e "\"") "\"")
((= e "\\") "\\")
(:else e)))))))
(:else
(let
((c (at)))
(adv)
(read-str (str acc c))))))))
;; Read #\ char literal — called with pos just past the backslash
(define
read-char-lit
(fn
()
(let
((first (at)))
(adv)
(let
((rest (if (and (at) (cl-alpha? (at))) (read-while cl-alpha?) "")))
(if
(= rest "")
first
(let
((name (downcase (str first rest))))
(or (get cl-named-chars name) first)))))))
;; Number scanner — called with pos just past first digit(s).
;; acc holds what was already consumed (first digit or sign+digit).
(define
scan-num
(fn
(p acc)
(let
((more (read-while cl-digit?)))
(set! acc (str acc more))
(cond
;; ratio N/D
((and (at) (= (at) "/") (peek1) (cl-digit? (peek1)))
(do
(adv)
(let
((denom (read-while cl-digit?)))
{:type "ratio" :value (str acc "/" denom) :pos p})))
;; float: decimal point N.M[eE]
((and (at) (= (at) ".") (peek1) (cl-digit? (peek1)))
(do
(adv)
(let
((frac (read-while cl-digit?)))
(set! acc (str acc "." frac))
(when
(and (at) (or (= (at) "e") (= (at) "E")))
(do
(set! acc (str acc (at)))
(adv)
(when
(and (at) (or (= (at) "+") (= (at) "-")))
(do (set! acc (str acc (at))) (adv)))
(set! acc (str acc (read-while cl-digit?)))))
{:type "float" :value acc :pos p})))
;; float: exponent only NeE
((and (at) (or (= (at) "e") (= (at) "E")))
(do
(set! acc (str acc (at)))
(adv)
(when
(and (at) (or (= (at) "+") (= (at) "-")))
(do (set! acc (str acc (at))) (adv)))
(set! acc (str acc (read-while cl-digit?)))
{:type "float" :value acc :pos p}))
(:else {:type "integer" :value acc :pos p})))))
(define
read-radix
(fn
(letter p)
(let
((pred
(cond
((or (= letter "x") (= letter "X")) cl-hex?)
((or (= letter "b") (= letter "B")) cl-binary?)
((or (= letter "o") (= letter "O")) cl-octal?)
(:else cl-digit?))))
{:type "integer"
:value (str "#" letter (read-while pred))
:pos p})))
(define emit (fn (tok) (append! toks tok)))
(define
scan
(fn
()
(when
(< pos n)
(let
((c (at)) (p pos))
(cond
((cl-ws? c) (do (adv) (scan)))
((= c ";") (do (adv) (skip-line) (scan)))
((= c "(") (do (adv) (emit (cl-make-tok "lparen" "(" p)) (scan)))
((= c ")") (do (adv) (emit (cl-make-tok "rparen" ")" p)) (scan)))
((= c "'") (do (adv) (emit (cl-make-tok "quote" "'" p)) (scan)))
((= c "`") (do (adv) (emit (cl-make-tok "backquote" "`" p)) (scan)))
((= c ",")
(do
(adv)
(if
(= (at) "@")
(do (adv) (emit (cl-make-tok "comma-at" ",@" p)))
(emit (cl-make-tok "comma" "," p)))
(scan)))
((= c "\"")
(do
(adv)
(emit (cl-make-tok "string" (read-str "") p))
(scan)))
;; :keyword
((= c ":")
(do
(adv)
(emit (cl-make-tok "keyword" (upcase (read-while cl-sym-char?)) p))
(scan)))
;; dispatch macro #
((= c "#")
(do
(adv)
(let
((d (at)))
(cond
((= d "'") (do (adv) (emit (cl-make-tok "hash-quote" "#'" p)) (scan)))
((= d "(") (do (adv) (emit (cl-make-tok "hash-paren" "#(" p)) (scan)))
((= d ":")
(do
(adv)
(emit
(cl-make-tok "uninterned" (upcase (read-while cl-sym-char?)) p))
(scan)))
((= d "|") (do (adv) (skip-block 1) (scan)))
((= d "\\")
(do (adv) (emit (cl-make-tok "char" (read-char-lit) p)) (scan)))
((or (= d "x") (= d "X"))
(do (adv) (emit (read-radix d p)) (scan)))
((or (= d "b") (= d "B"))
(do (adv) (emit (read-radix d p)) (scan)))
((or (= d "o") (= d "O"))
(do (adv) (emit (read-radix d p)) (scan)))
(:else (scan))))))
;; standalone dot, float .5, or symbol starting with dots
((= c ".")
(do
(adv)
(cond
((or (not (at)) (cl-terminating? (at)))
(do (emit (cl-make-tok "dot" "." p)) (scan)))
((cl-digit? (at))
(do
(emit
(cl-make-tok "float" (str "0." (read-while cl-digit?)) p))
(scan)))
(:else
(do
(emit
(cl-make-tok "symbol" (upcase (str "." (read-while cl-sym-char?))) p))
(scan))))))
;; sign followed by digit → number
((and (or (= c "+") (= c "-")) (peek1) (cl-digit? (peek1)))
(do
(adv)
(let
((first-d (at)))
(adv)
(emit (scan-num p (str c first-d))))
(scan)))
;; decimal digit → number
((cl-digit? c)
(do
(adv)
(emit (scan-num p c))
(scan)))
;; symbol constituent (includes bare +, -, etc.)
((cl-sym-char? c)
(do
(emit (cl-make-tok "symbol" (upcase (read-while cl-sym-char?)) p))
(scan)))
(:else (do (adv) (scan))))))))
(scan)
(append! toks (cl-make-tok "eof" nil n))
toks)))

760
lib/common-lisp/runtime.sx
View File

@@ -1,760 +0,0 @@
;; lib/common-lisp/runtime.sx — CL built-ins + condition system on SX
;;
;; Section 1-9: Type predicates, arithmetic, characters, strings, gensym,
;; multiple values, sets, radix formatting, list utilities.
;; Section 10: Condition system (define-condition, signal/error/warn,
;; handler-bind, handler-case, restart-case, invoke-restart).
;;
;; Primitives used from spec:
;; char/char->integer/integer->char/char-upcase/char-downcase
;; format gensym rational/rational? make-set/set-member?/etc
;; modulo/remainder/quotient/gcd/lcm/expt number->string
;; ---------------------------------------------------------------------------
;; 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"))))
(prefix-rename "cl-"
'(
(integerp? integer?)
(floatp? float?)
(rationalp? rational?)
))
(define (cl-realp? x) (or (integer? x) (float? x) (rational? x)))
(prefix-rename "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"))))
(prefix-rename "cl-"
'(
(vectorp? vector?)
(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
;; ---------------------------------------------------------------------------
(prefix-rename "cl-"
'(
(mod modulo)
(rem remainder)
gcd
lcm
expt
floor
(ceiling ceil)
truncate
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)))
(prefix-rename "cl-"
'(
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
;; ---------------------------------------------------------------------------
(prefix-rename "cl-"
'(
char->integer
integer->char
char-upcase
char-downcase
(char-code char->integer)
(code-char integer->char)
))
(prefix-rename "cl-"
'(
char=?
char<?
char>?
char<=?
char>=?
char-ci=?
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)))
(prefix-rename "cl-"
'(
write-to-string
(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)
(prefix-rename "cl-"
'(
(make-string-output-stream open-output-string)
(get-output-stream-string get-output-string)
))
;; String stream (input)
(prefix-rename "cl-"
'(
(make-string-input-stream open-input-string)
))
;; ---------------------------------------------------------------------------
;; 5. Gensym
;; ---------------------------------------------------------------------------
(prefix-rename "cl-"
'(
gensym
(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)
;; ---------------------------------------------------------------------------
(prefix-rename "cl-"
'(
make-set
set?
(set-add set-add!)
(set-memberp set-member?)
(set-remove set-remove!)
set-union
(set-intersect set-intersection)
set-difference
list->set
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))))
;; ---------------------------------------------------------------------------
;; 10. Condition system (Phase 3)
;;
;; Condition objects:
;; {:cl-type "cl-condition" :class "NAME" :slots {slot-name val ...}}
;;
;; The built-in handler-bind / restart-case expect LITERAL handler specs in
;; source (they operate on the raw AST), so we implement our own handler and
;; restart stacks as mutable SX globals.
;; ---------------------------------------------------------------------------
;; ── condition class registry ───────────────────────────────────────────────
;;
;; Populated at load time with all ANSI standard condition types.
;; Also mutated by cl-define-condition.
(define
cl-condition-classes
(dict
"condition"
{:parents (list) :slots (list) :name "condition"}
"serious-condition"
{:parents (list "condition") :slots (list) :name "serious-condition"}
"error"
{:parents (list "serious-condition") :slots (list) :name "error"}
"warning"
{:parents (list "condition") :slots (list) :name "warning"}
"simple-condition"
{:parents (list "condition") :slots (list "format-control" "format-arguments") :name "simple-condition"}
"simple-error"
{:parents (list "error" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-error"}
"simple-warning"
{:parents (list "warning" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-warning"}
"type-error"
{:parents (list "error") :slots (list "datum" "expected-type") :name "type-error"}
"arithmetic-error"
{:parents (list "error") :slots (list "operation" "operands") :name "arithmetic-error"}
"division-by-zero"
{:parents (list "arithmetic-error") :slots (list) :name "division-by-zero"}
"cell-error"
{:parents (list "error") :slots (list "name") :name "cell-error"}
"unbound-variable"
{:parents (list "cell-error") :slots (list) :name "unbound-variable"}
"undefined-function"
{:parents (list "cell-error") :slots (list) :name "undefined-function"}
"program-error"
{:parents (list "error") :slots (list) :name "program-error"}
"storage-condition"
{:parents (list "serious-condition") :slots (list) :name "storage-condition"}))
;; ── condition predicates ───────────────────────────────────────────────────
(define
cl-condition?
(fn (x) (and (dict? x) (= (get x "cl-type") "cl-condition"))))
;; cl-condition-of-type? walks the class hierarchy.
;; We capture cl-condition-classes at define time via let to avoid
;; free-variable scoping issues at call time.
(define
cl-condition-of-type?
(let
((classes cl-condition-classes))
(fn
(c type-name)
(if
(not (cl-condition? c))
false
(let
((class-name (get c "class")))
(define
check
(fn
(n)
(if
(= n type-name)
true
(let
((entry (get classes n)))
(if
(nil? entry)
false
(some (fn (p) (check p)) (get entry "parents")))))))
(check class-name))))))
;; ── condition constructors ─────────────────────────────────────────────────
;; cl-define-condition registers a new condition class.
;; name: string (condition class name)
;; parents: list of strings (parent class names)
;; slot-names: list of strings
(define
cl-define-condition
(fn
(name parents slot-names)
(begin (dict-set! cl-condition-classes name {:parents parents :slots slot-names :name name}) name)))
;; cl-make-condition constructs a condition object.
;; Keyword args (alternating slot-name/value pairs) populate the slots dict.
(define
cl-make-condition
(fn
(name &rest kw-args)
(let
((slots (dict)))
(define
fill
(fn
(args)
(when
(>= (len args) 2)
(begin
(dict-set! slots (first args) (first (rest args)))
(fill (rest (rest args)))))))
(fill kw-args)
{:cl-type "cl-condition" :slots slots :class name})))
;; ── condition accessors ────────────────────────────────────────────────────
(define
cl-condition-slot
(fn
(c slot-name)
(if (cl-condition? c) (get (get c "slots") slot-name) nil)))
(define
cl-condition-message
(fn
(c)
(if
(not (cl-condition? c))
(str c)
(let
((slots (get c "slots")))
(or
(get slots "message")
(get slots "format-control")
(str "Condition: " (get c "class")))))))
(define
cl-simple-condition-format-control
(fn (c) (cl-condition-slot c "format-control")))
(define
cl-simple-condition-format-arguments
(fn (c) (cl-condition-slot c "format-arguments")))
(define cl-type-error-datum (fn (c) (cl-condition-slot c "datum")))
(define
cl-type-error-expected-type
(fn (c) (cl-condition-slot c "expected-type")))
(define
cl-arithmetic-error-operation
(fn (c) (cl-condition-slot c "operation")))
(define
cl-arithmetic-error-operands
(fn (c) (cl-condition-slot c "operands")))
;; ── mutable handler + restart stacks ──────────────────────────────────────
;;
;; Handler entry: {:type "type-name" :fn (fn (condition) result)}
;; Restart entry: {:name "restart-name" :fn (fn (&optional arg) result) :escape k}
;;
;; New handlers are prepended (checked first = most recent handler wins).
(define cl-handler-stack (list))
(define cl-restart-stack (list))
(define
cl-push-handlers
(fn (entries) (set! cl-handler-stack (append entries cl-handler-stack))))
(define
cl-pop-handlers
(fn
(n)
(set! cl-handler-stack (slice cl-handler-stack n (len cl-handler-stack)))))
(define
cl-push-restarts
(fn (entries) (set! cl-restart-stack (append entries cl-restart-stack))))
(define
cl-pop-restarts
(fn
(n)
(set! cl-restart-stack (slice cl-restart-stack n (len cl-restart-stack)))))
;; ── *debugger-hook* + invoke-debugger ────────────────────────────────────
;;
;; cl-debugger-hook: called when an error propagates with no handler.
;; Signature: (fn (condition hook) result). The hook arg is itself
;; (so the hook can rebind it to nil to prevent recursion).
;; nil = use default (re-raise as host error).
(define cl-debugger-hook nil)
(define cl-invoke-debugger
(fn (c)
(if (nil? cl-debugger-hook)
(error (str "Debugger: " (cl-condition-message c)))
(let ((hook cl-debugger-hook))
(set! cl-debugger-hook nil)
(let ((result (hook c hook)))
(set! cl-debugger-hook hook)
result)))))
;; ── *break-on-signals* ────────────────────────────────────────────────────
;;
;; When set to a type name string, cl-signal invokes the debugger hook
;; before walking handlers if the condition is of that type.
;; nil = disabled (ANSI default).
(define cl-break-on-signals nil)
;; ── invoke-restart-interactively ──────────────────────────────────────────
;;
;; Like invoke-restart but calls the restart's fn with no arguments
;; (real CL would prompt the user for each arg via :interactive).
(define cl-invoke-restart-interactively
(fn (name)
(let ((entry (cl-find-restart-entry name cl-restart-stack)))
(if (nil? entry)
(error (str "No active restart: " name))
(let ((restart-fn (get entry "fn"))
(escape (get entry "escape")))
(escape (restart-fn)))))))
;; ── cl-signal (non-unwinding) ─────────────────────────────────────────────
;;
;; Walks cl-handler-stack; for each matching entry, calls the handler fn.
;; Handlers return normally — signal continues to the next matching handler.
(define
cl-signal-obj
(fn
(obj stack)
(if
(empty? stack)
nil
(let
((entry (first stack)))
(if
(cl-condition-of-type? obj (get entry "type"))
(begin ((get entry "fn") obj) (cl-signal-obj obj (rest stack)))
(cl-signal-obj obj (rest stack)))))))
(define cl-signal
(fn (c)
(let ((obj (if (cl-condition? c)
c
(cl-make-condition "simple-condition"
"format-control" (str c)))))
;; *break-on-signals*: invoke debugger hook when type matches
(when (and (not (nil? cl-break-on-signals))
(cl-condition-of-type? obj cl-break-on-signals))
(cl-invoke-debugger obj))
(cl-signal-obj obj cl-handler-stack))))
;; ── cl-error ───────────────────────────────────────────────────────────────
;;
;; Signals an error. If no handler catches it, raises a host-level error.
(define
cl-error
(fn
(c &rest args)
(let
((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
(cl-signal-obj obj cl-handler-stack)
(cl-invoke-debugger obj))))
;; ── cl-warn ────────────────────────────────────────────────────────────────
(define
cl-warn
(fn
(c &rest args)
(let
((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-warning" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-warning" "format-control" (str c))))))
(cl-signal-obj obj cl-handler-stack))))
;; ── cl-handler-bind (non-unwinding) ───────────────────────────────────────
;;
;; bindings: list of (type-name handler-fn) pairs
;; thunk: (fn () body)
(define
cl-handler-bind
(fn
(bindings thunk)
(let
((entries (map (fn (b) {:fn (first (rest b)) :type (first b)}) bindings)))
(begin
(cl-push-handlers entries)
(let
((result (thunk)))
(begin (cl-pop-handlers (len entries)) result))))))
;; ── cl-handler-case (unwinding) ───────────────────────────────────────────
;;
;; thunk: (fn () body)
;; cases: list of (type-name handler-fn) pairs
;;
;; Uses call/cc for the escape continuation.
(define
cl-handler-case
(fn
(thunk &rest cases)
(call/cc
(fn
(escape)
(let
((entries (map (fn (c) {:fn (fn (x) (escape ((first (rest c)) x))) :type (first c)}) cases)))
(begin
(cl-push-handlers entries)
(let
((result (thunk)))
(begin (cl-pop-handlers (len entries)) result))))))))
;; ── cl-restart-case ────────────────────────────────────────────────────────
;;
;; thunk: (fn () body)
;; restarts: list of (name params body-fn) triples
;; body-fn is (fn () val) or (fn (arg) val)
(define
cl-restart-case
(fn
(thunk &rest restarts)
(call/cc
(fn
(escape)
(let
((entries (map (fn (r) {:fn (first (rest (rest r))) :escape escape :name (first r)}) restarts)))
(begin
(cl-push-restarts entries)
(let
((result (thunk)))
(begin (cl-pop-restarts (len entries)) result))))))))
;; ── cl-with-simple-restart ─────────────────────────────────────────────────
(define
cl-with-simple-restart
(fn
(name description thunk)
(cl-restart-case thunk (list name (list) (fn () nil)))))
;; ── find-restart / invoke-restart / compute-restarts ──────────────────────
(define
cl-find-restart-entry
(fn
(name stack)
(if
(empty? stack)
nil
(let
((entry (first stack)))
(if
(= (get entry "name") name)
entry
(cl-find-restart-entry name (rest stack)))))))
(define
cl-find-restart
(fn (name) (cl-find-restart-entry name cl-restart-stack)))
(define
cl-invoke-restart
(fn
(name &rest args)
(let
((entry (cl-find-restart-entry name cl-restart-stack)))
(if
(nil? entry)
(error (str "No active restart: " name))
(let
((restart-fn (get entry "fn")) (escape (get entry "escape")))
(escape
(if (empty? args) (restart-fn) (restart-fn (first args)))))))))
(define
cl-compute-restarts
(fn () (map (fn (e) (get e "name")) cl-restart-stack)))
;; ── with-condition-restarts (stub — association is advisory) ──────────────
(define cl-with-condition-restarts (fn (c restarts thunk) (thunk)))
;; ── cl-cerror ──────────────────────────────────────────────────────────────
;;
;; Signals a continuable error. The "continue" restart is established;
;; invoke-restart "continue" to proceed past the error.
;; ── cl-cerror ──────────────────────────────────────────────────────────────
;;
;; Signals a continuable error. The "continue" restart is established;
;; invoke-restart "continue" to proceed past the error.
(define cl-cerror
(fn (continue-string c &rest args)
(let ((obj (if (cl-condition? c)
c
(cl-make-condition "simple-error"
"format-control" (str c)
"format-arguments" args))))
(cl-restart-case
(fn () (cl-signal-obj obj cl-handler-stack))
(list "continue" (list) (fn () nil))))))

19
lib/common-lisp/scoreboard.json
View File

@@ -1,19 +0,0 @@
{
"generated": "2026-05-06T22:55:42Z",
"total_pass": 518,
"total_fail": 0,
"suites": [
{"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
{"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
{"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
{"name": "Phase 3: condition system", "pass": 59, "fail": 0},
{"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
{"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
{"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
{"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
{"name": "Phase 4: geometry", "pass": 12, "fail": 0},
{"name": "Phase 4: mop-trace", "pass": 13, "fail": 0},
{"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0},
{"name": "Phase 6: stdlib", "pass": 54, "fail": 0}
]
}

20
lib/common-lisp/scoreboard.md
View File

@@ -1,20 +0,0 @@
# Common Lisp on SX — Scoreboard
_Generated: 2026-05-06 22:55 UTC_
| Suite | Pass | Fail | Status |
|-------|------|------|--------|
| Phase 1: tokenizer/reader | 79 | 0 | pass |
| Phase 1: parser/lambda-lists | 31 | 0 | pass |
| Phase 2: evaluator | 182 | 0 | pass |
| Phase 3: condition system | 59 | 0 | pass |
| Phase 3: restart-demo | 7 | 0 | pass |
| Phase 3: parse-recover | 6 | 0 | pass |
| Phase 3: interactive-debugger | 7 | 0 | pass |
| Phase 4: CLOS | 41 | 0 | pass |
| Phase 4: geometry | 12 | 0 | pass |
| Phase 4: mop-trace | 13 | 0 | pass |
| Phase 5: macros+LOOP | 27 | 0 | pass |
| Phase 6: stdlib | 54 | 0 | pass |
**Total: 518 passed, 0 failed**

443
lib/common-lisp/test.sh
View File

@@ -1,443 +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"
# ── Phase 2: condition system unit tests ─────────────────────────────────────
# Load runtime.sx then conditions.sx; query the passed/failed/failures globals.
UNIT_FILE=$(mktemp); trap "rm -f $UNIT_FILE" EXIT
cat > "$UNIT_FILE" << 'UNIT'
(epoch 1)
(load "spec/stdlib.sx")
(epoch 2)
(load "lib/common-lisp/runtime.sx")
(epoch 3)
(load "lib/common-lisp/tests/conditions.sx")
(epoch 4)
(eval "passed")
(epoch 5)
(eval "failed")
(epoch 6)
(eval "failures")
UNIT
UNIT_OUT=$(timeout 30 "$SX_SERVER" < "$UNIT_FILE" 2>/dev/null)
# extract passed/failed counts from ok-len lines
UNIT_PASSED=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 4 " | tail -1 || true)
UNIT_FAILED=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
UNIT_ERRS=$(echo "$UNIT_OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
# fallback: try plain ok lines
[ -z "$UNIT_PASSED" ] && UNIT_PASSED=$(echo "$UNIT_OUT" | grep "^(ok 4 " | awk '{print $3}' | tr -d ')' || true)
[ -z "$UNIT_FAILED" ] && UNIT_FAILED=$(echo "$UNIT_OUT" | grep "^(ok 5 " | awk '{print $3}' | tr -d ')' || true)
[ -z "$UNIT_PASSED" ] && UNIT_PASSED=0
[ -z "$UNIT_FAILED" ] && UNIT_FAILED=0
if [ "$UNIT_FAILED" = "0" ] && [ "$UNIT_PASSED" -gt 0 ] 2>/dev/null; then
PASS=$((PASS + UNIT_PASSED))
[ "$VERBOSE" = "-v" ] && echo " ok condition tests ($UNIT_PASSED)"
else
FAIL=$((FAIL + 1))
ERRORS+=" FAIL [condition tests] (${UNIT_PASSED} passed, ${UNIT_FAILED} failed) ${UNIT_ERRS}
"
fi
# ── Phase 3: classic program tests ───────────────────────────────────────────
run_program_suite() {
local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
local PROG_FILE=$(mktemp)
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "%s")\n(epoch 4)\n(eval "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n' \
"$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
rm -f "$PROG_FILE"
local P F
P=$(echo "$OUT" | grep -A1 "^(ok-len 4 " | tail -1 || true)
F=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then
PASS=$((PASS + P))
[ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)"
else
FAIL=$((FAIL + 1))
ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS}
"
fi
}
run_program_suite \
"lib/common-lisp/tests/programs/restart-demo.sx" \
"demo-passed" "demo-failed" "demo-failures"
run_program_suite \
"lib/common-lisp/tests/programs/parse-recover.sx" \
"parse-passed" "parse-failed" "parse-failures"
run_program_suite \
"lib/common-lisp/tests/programs/interactive-debugger.sx" \
"debugger-passed" "debugger-failed" "debugger-failures"
# ── Phase 4: CLOS unit tests ─────────────────────────────────────────────────
CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null)
rm -f "$CLOS_FILE"
CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
CLOS_FAILED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
[ -z "$CLOS_PASSED" ] && CLOS_PASSED=$(echo "$CLOS_OUT" | grep "^(ok 5 " | awk '{print $3}' | tr -d ')' || true)
[ -z "$CLOS_FAILED" ] && CLOS_FAILED=$(echo "$CLOS_OUT" | grep "^(ok 6 " | awk '{print $3}' | tr -d ')' || true)
[ -z "$CLOS_PASSED" ] && CLOS_PASSED=0; [ -z "$CLOS_FAILED" ] && CLOS_FAILED=0
if [ "$CLOS_FAILED" = "0" ] && [ "$CLOS_PASSED" -gt 0 ] 2>/dev/null; then
PASS=$((PASS + CLOS_PASSED))
[ "$VERBOSE" = "-v" ] && echo " ok CLOS unit tests ($CLOS_PASSED)"
else
FAIL=$((FAIL + 1))
ERRORS+=" FAIL [CLOS unit tests] (${CLOS_PASSED} passed, ${CLOS_FAILED} failed)
"
fi
# ── Phase 4: CLOS classic programs ───────────────────────────────────────────
run_clos_suite() {
local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
local PROG_FILE=$(mktemp)
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
"$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
rm -f "$PROG_FILE"
local P F
P=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
F=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 7 " | tail -1 || true)
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then
PASS=$((PASS + P))
[ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)"
else
FAIL=$((FAIL + 1))
ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS}
"
fi
}
run_clos_suite \
"lib/common-lisp/tests/programs/geometry.sx" \
"geo-passed" "geo-failed" "geo-failures"
run_clos_suite \
"lib/common-lisp/tests/programs/mop-trace.sx" \
"mop-passed" "mop-failed" "mop-failures"
# ── Phase 5: macros + LOOP ───────────────────────────────────────────────────
MACRO_FILE=$(mktemp); trap "rm -f $MACRO_FILE" EXIT
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/reader.sx")\n(epoch 3)\n(load "lib/common-lisp/parser.sx")\n(epoch 4)\n(load "lib/common-lisp/eval.sx")\n(epoch 5)\n(load "lib/common-lisp/loop.sx")\n(epoch 6)\n(load "lib/common-lisp/tests/macros.sx")\n(epoch 7)\n(eval "macro-passed")\n(epoch 8)\n(eval "macro-failed")\n(epoch 9)\n(eval "macro-failures")\n' > "$MACRO_FILE"
MACRO_OUT=$(timeout 60 "$SX_SERVER" < "$MACRO_FILE" 2>/dev/null)
rm -f "$MACRO_FILE"
MACRO_PASSED=$(echo "$MACRO_OUT" | grep -A1 "^(ok-len 7 " | tail -1 || true)
MACRO_FAILED=$(echo "$MACRO_OUT" | grep -A1 "^(ok-len 8 " | tail -1 || true)
[ -z "$MACRO_PASSED" ] && MACRO_PASSED=0; [ -z "$MACRO_FAILED" ] && MACRO_FAILED=0
if [ "$MACRO_FAILED" = "0" ] && [ "$MACRO_PASSED" -gt 0 ] 2>/dev/null; then
PASS=$((PASS + MACRO_PASSED))
[ "$VERBOSE" = "-v" ] && echo " ok Phase 5 macros+LOOP ($MACRO_PASSED)"
else
FAIL=$((FAIL + 1))
ERRORS+=" FAIL [Phase 5 macros+LOOP] (${MACRO_PASSED} passed, ${MACRO_FAILED} failed)
"
fi
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 ]

334
lib/common-lisp/tests/clos.sx
View File

@@ -1,334 +0,0 @@
;; lib/common-lisp/tests/clos.sx — CLOS test suite
;;
;; Loaded after: spec/stdlib.sx, lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
(define passed 0)
(define failed 0)
(define failures (list))
(define
assert-equal
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
(define
assert-true
(fn
(label got)
(if
got
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str "FAIL [" label "]: expected true, got " (inspect got)))))))))
(define
assert-nil
(fn
(label got)
(if
(nil? got)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list (str "FAIL [" label "]: expected nil, got " (inspect got)))))))))
;; ── 1. class-of for built-in types ────────────────────────────────────────
(assert-equal "class-of integer" (clos-class-of 42) "integer")
(assert-equal "class-of float" (clos-class-of 3.14) "float")
(assert-equal "class-of string" (clos-class-of "hi") "string")
(assert-equal "class-of nil" (clos-class-of nil) "null")
(assert-equal "class-of list" (clos-class-of (list 1)) "cons")
(assert-equal "class-of empty" (clos-class-of (list)) "null")
;; ── 2. subclass-of? ───────────────────────────────────────────────────────
(assert-true "integer subclass-of t" (clos-subclass-of? "integer" "t"))
(assert-true "float subclass-of t" (clos-subclass-of? "float" "t"))
(assert-true "t subclass-of t" (clos-subclass-of? "t" "t"))
(assert-equal
"integer not subclass-of float"
(clos-subclass-of? "integer" "float")
false)
;; ── 3. defclass + make-instance ───────────────────────────────────────────
(clos-defclass "point" (list "t") (list {:initform 0 :initarg ":x" :reader nil :writer nil :accessor "point-x" :name "x"} {:initform 0 :initarg ":y" :reader nil :writer nil :accessor "point-y" :name "y"}))
(let
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
(begin
(assert-equal "make-instance slot x" (clos-slot-value p "x") 3)
(assert-equal "make-instance slot y" (clos-slot-value p "y") 4)
(assert-equal "class-of instance" (clos-class-of p) "point")
(assert-true "instance-of? point" (clos-instance-of? p "point"))
(assert-true "instance-of? t" (clos-instance-of? p "t"))
(assert-equal "instance-of? string" (clos-instance-of? p "string") false)))
;; initform defaults
(let
((p0 (clos-make-instance "point")))
(begin
(assert-equal "initform default x=0" (clos-slot-value p0 "x") 0)
(assert-equal "initform default y=0" (clos-slot-value p0 "y") 0)))
;; ── 4. slot-value / set-slot-value! ──────────────────────────────────────
(let
((p (clos-make-instance "point" ":x" 10 ":y" 20)))
(begin
(clos-set-slot-value! p "x" 99)
(assert-equal "set-slot-value! x" (clos-slot-value p "x") 99)
(assert-equal "slot-value y unchanged" (clos-slot-value p "y") 20)))
;; ── 5. slot-boundp ────────────────────────────────────────────────────────
(let
((p (clos-make-instance "point" ":x" 5)))
(begin
(assert-true "slot-boundp x" (clos-slot-boundp p "x"))
(assert-true "slot-boundp y (initform 0)" (clos-slot-boundp p "y"))))
;; ── 6. find-class ─────────────────────────────────────────────────────────
(assert-equal
"find-class point"
(get (clos-find-class "point") "name")
"point")
(assert-nil "find-class missing" (clos-find-class "no-such-class"))
;; ── 7. inheritance ────────────────────────────────────────────────────────
(clos-defclass "colored-point" (list "point") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"}))
(let
((cp (clos-make-instance "colored-point" ":x" 1 ":y" 2 ":color" "red")))
(begin
(assert-equal "inherited slot x" (clos-slot-value cp "x") 1)
(assert-equal "inherited slot y" (clos-slot-value cp "y") 2)
(assert-equal "own slot color" (clos-slot-value cp "color") "red")
(assert-true
"instance-of? colored-point"
(clos-instance-of? cp "colored-point"))
(assert-true "instance-of? point (parent)" (clos-instance-of? cp "point"))
(assert-true "instance-of? t (root)" (clos-instance-of? cp "t"))))
;; ── 8. defgeneric + primary method ───────────────────────────────────────
(clos-defgeneric "describe-obj" {})
(clos-defmethod
"describe-obj"
(list)
(list "point")
(fn
(args next-fn)
(let
((p (first args)))
(str "(" (clos-slot-value p "x") "," (clos-slot-value p "y") ")"))))
(clos-defmethod
"describe-obj"
(list)
(list "t")
(fn (args next-fn) (str "object:" (inspect (first args)))))
(let
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
(begin
(assert-equal
"primary method for point"
(clos-call-generic "describe-obj" (list p))
"(3,4)")
(assert-equal
"fallback t method"
(clos-call-generic "describe-obj" (list 42))
"object:42")))
;; ── 9. method inheritance + specificity ───────────────────────────────────
(clos-defmethod
"describe-obj"
(list)
(list "colored-point")
(fn
(args next-fn)
(let
((cp (first args)))
(str
(clos-slot-value cp "color")
"@("
(clos-slot-value cp "x")
","
(clos-slot-value cp "y")
")"))))
(let
((cp (clos-make-instance "colored-point" ":x" 5 ":y" 6 ":color" "blue")))
(assert-equal
"most specific method wins"
(clos-call-generic "describe-obj" (list cp))
"blue@(5,6)"))
;; ── 10. :before / :after / :around qualifiers ─────────────────────────────
(clos-defgeneric "logged-action" {})
(clos-defmethod
"logged-action"
(list "before")
(list "t")
(fn (args next-fn) (set! action-log (append action-log (list "before")))))
(clos-defmethod
"logged-action"
(list)
(list "t")
(fn
(args next-fn)
(set! action-log (append action-log (list "primary")))
"result"))
(clos-defmethod
"logged-action"
(list "after")
(list "t")
(fn (args next-fn) (set! action-log (append action-log (list "after")))))
(define action-log (list))
(clos-call-generic "logged-action" (list 1))
(assert-equal
":before/:after order"
action-log
(list "before" "primary" "after"))
;; :around
(define around-log (list))
(clos-defgeneric "wrapped-action" {})
(clos-defmethod
"wrapped-action"
(list "around")
(list "t")
(fn
(args next-fn)
(set! around-log (append around-log (list "around-enter")))
(let
((r (next-fn)))
(set! around-log (append around-log (list "around-exit")))
r)))
(clos-defmethod
"wrapped-action"
(list)
(list "t")
(fn
(args next-fn)
(set! around-log (append around-log (list "primary")))
42))
(let
((r (clos-call-generic "wrapped-action" (list nil))))
(begin
(assert-equal ":around result" r 42)
(assert-equal
":around log"
around-log
(list "around-enter" "primary" "around-exit"))))
;; ── 11. call-next-method ─────────────────────────────────────────────────
(clos-defgeneric "chain-test" {})
(clos-defmethod
"chain-test"
(list)
(list "colored-point")
(fn (args next-fn) (str "colored:" (clos-call-next-method next-fn))))
(clos-defmethod
"chain-test"
(list)
(list "point")
(fn (args next-fn) "point-base"))
(let
((cp (clos-make-instance "colored-point" ":x" 0 ":y" 0 ":color" "green")))
(assert-equal
"call-next-method chains"
(clos-call-generic "chain-test" (list cp))
"colored:point-base"))
;; ── 12. accessor methods ──────────────────────────────────────────────────
(let
((p (clos-make-instance "point" ":x" 7 ":y" 8)))
(begin
(assert-equal
"accessor point-x"
(clos-call-generic "point-x" (list p))
7)
(assert-equal
"accessor point-y"
(clos-call-generic "point-y" (list p))
8)))
;; ── 13. with-slots ────────────────────────────────────────────────────────
(let
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
(assert-equal
"with-slots"
(clos-with-slots p (list "x" "y") (fn (x y) (* x y)))
12))
;; ── 14. change-class ─────────────────────────────────────────────────────
(clos-defclass "special-point" (list "point") (list {:initform "" :initarg ":label" :reader nil :writer nil :accessor nil :name "label"}))
(let
((p (clos-make-instance "point" ":x" 1 ":y" 2)))
(begin
(clos-change-class! p "special-point")
(assert-equal
"change-class updates class"
(clos-class-of p)
"special-point")))
;; ── summary ────────────────────────────────────────────────────────────────
(if
(= failed 0)
(print (str "ok " passed "/" (+ passed failed) " CLOS tests passed"))
(begin
(for-each (fn (f) (print f)) failures)
(print
(str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed"))))

478
lib/common-lisp/tests/conditions.sx
View File

@@ -1,478 +0,0 @@
;; lib/common-lisp/tests/conditions.sx — Phase 3 condition system tests
;;
;; Loaded by lib/common-lisp/test.sh after:
;; (load "spec/stdlib.sx")
;; (load "lib/common-lisp/runtime.sx")
;;
;; Each test resets the handler/restart stacks to ensure isolation.
(define
reset-stacks!
(fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))
;; ── helpers ────────────────────────────────────────────────────────────────
(define passed 0)
(define failed 0)
(define failures (list))
(define
assert-equal
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
(define
assert-true
(fn
(label got)
(if
got
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str "FAIL [" label "]: expected true, got " (inspect got)))))))))
(define
assert-nil
(fn
(label got)
(if
(nil? got)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list (str "FAIL [" label "]: expected nil, got " (inspect got)))))))))
;; ── 1. condition predicates ────────────────────────────────────────────────
(reset-stacks!)
(let
((c (cl-make-condition "simple-error" "format-control" "oops")))
(begin
(assert-true "cl-condition? on condition" (cl-condition? c))
(assert-equal "cl-condition? on string" (cl-condition? "hello") false)
(assert-equal "cl-condition? on number" (cl-condition? 42) false)
(assert-equal "cl-condition? on nil" (cl-condition? nil) false)))
;; ── 2. cl-make-condition + slot access ────────────────────────────────────
(reset-stacks!)
(let
((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2))))
(begin
(assert-equal "class field" (get c "class") "simple-error")
(assert-equal "cl-type field" (get c "cl-type") "cl-condition")
(assert-equal
"format-control slot"
(cl-condition-slot c "format-control")
"msg")
(assert-equal
"format-arguments slot"
(cl-condition-slot c "format-arguments")
(list 1 2))
(assert-nil "missing slot is nil" (cl-condition-slot c "no-such-slot"))
(assert-equal "condition-message" (cl-condition-message c) "msg")))
;; ── 3. cl-condition-of-type? — hierarchy walking ─────────────────────────
(reset-stacks!)
(let
((se (cl-make-condition "simple-error" "format-control" "x"))
(w (cl-make-condition "simple-warning" "format-control" "y"))
(te
(cl-make-condition
"type-error"
"datum"
5
"expected-type"
"string"))
(dz (cl-make-condition "division-by-zero")))
(begin
(assert-true
"se isa simple-error"
(cl-condition-of-type? se "simple-error"))
(assert-true "se isa error" (cl-condition-of-type? se "error"))
(assert-true
"se isa serious-condition"
(cl-condition-of-type? se "serious-condition"))
(assert-true "se isa condition" (cl-condition-of-type? se "condition"))
(assert-equal
"se not isa warning"
(cl-condition-of-type? se "warning")
false)
(assert-true
"w isa simple-warning"
(cl-condition-of-type? w "simple-warning"))
(assert-true "w isa warning" (cl-condition-of-type? w "warning"))
(assert-true "w isa condition" (cl-condition-of-type? w "condition"))
(assert-equal "w not isa error" (cl-condition-of-type? w "error") false)
(assert-true "te isa type-error" (cl-condition-of-type? te "type-error"))
(assert-true "te isa error" (cl-condition-of-type? te "error"))
(assert-true
"dz isa division-by-zero"
(cl-condition-of-type? dz "division-by-zero"))
(assert-true
"dz isa arithmetic-error"
(cl-condition-of-type? dz "arithmetic-error"))
(assert-true "dz isa error" (cl-condition-of-type? dz "error"))
(assert-equal
"non-condition not isa anything"
(cl-condition-of-type? 42 "error")
false)))
;; ── 4. cl-define-condition ────────────────────────────────────────────────
(reset-stacks!)
(begin
(cl-define-condition "my-app-error" (list "error") (list "code" "detail"))
(let
((c (cl-make-condition "my-app-error" "code" 404 "detail" "not found")))
(begin
(assert-true "user condition: cl-condition?" (cl-condition? c))
(assert-true
"user condition isa my-app-error"
(cl-condition-of-type? c "my-app-error"))
(assert-true
"user condition isa error"
(cl-condition-of-type? c "error"))
(assert-true
"user condition isa condition"
(cl-condition-of-type? c "condition"))
(assert-equal
"user condition slot code"
(cl-condition-slot c "code")
404)
(assert-equal
"user condition slot detail"
(cl-condition-slot c "detail")
"not found"))))
;; ── 5. cl-handler-bind (non-unwinding) ───────────────────────────────────
(reset-stacks!)
(let
((log (list)))
(begin
(cl-handler-bind
(list
(list
"error"
(fn (c) (set! log (append log (list (cl-condition-message c)))))))
(fn
()
(cl-signal (cl-make-condition "simple-error" "format-control" "oops"))))
(assert-equal "handler-bind: handler fired" log (list "oops"))))
(reset-stacks!)
;; Non-unwinding: body continues after signal
(let
((body-ran false))
(begin
(cl-handler-bind
(list (list "error" (fn (c) nil)))
(fn
()
(cl-signal (cl-make-condition "simple-error" "format-control" "x"))
(set! body-ran true)))
(assert-true "handler-bind: body continues after signal" body-ran)))
(reset-stacks!)
;; Type filtering: warning handler does not fire for error
(let
((w-fired false))
(begin
(cl-handler-bind
(list (list "warning" (fn (c) (set! w-fired true))))
(fn
()
(cl-signal (cl-make-condition "simple-error" "format-control" "e"))))
(assert-equal
"handler-bind: type filter (warning ignores error)"
w-fired
false)))
(reset-stacks!)
;; Multiple handlers: both matching handlers fire
(let
((log (list)))
(begin
(cl-handler-bind
(list
(list "error" (fn (c) (set! log (append log (list "e1")))))
(list "condition" (fn (c) (set! log (append log (list "e2"))))))
(fn
()
(cl-signal (cl-make-condition "simple-error" "format-control" "x"))))
(assert-equal "handler-bind: both handlers fire" log (list "e1" "e2"))))
(reset-stacks!)
;; ── 6. cl-handler-case (unwinding) ───────────────────────────────────────
;; Catches error, returns handler result
(let
((result (cl-handler-case (fn () (cl-error "boom") 99) (list "error" (fn (c) (str "caught: " (cl-condition-message c)))))))
(assert-equal "handler-case: catches error" result "caught: boom"))
(reset-stacks!)
;; Returns body result when no signal
(let
((result (cl-handler-case (fn () 42) (list "error" (fn (c) -1)))))
(assert-equal "handler-case: body result" result 42))
(reset-stacks!)
;; Only first matching handler runs (unwinding)
(let
((result (cl-handler-case (fn () (cl-error "x")) (list "simple-error" (fn (c) "simple")) (list "error" (fn (c) "error")))))
(assert-equal "handler-case: most specific wins" result "simple"))
(reset-stacks!)
;; ── 7. cl-warn ────────────────────────────────────────────────────────────
(let
((warned false))
(begin
(cl-handler-bind
(list (list "warning" (fn (c) (set! warned true))))
(fn () (cl-warn "be careful")))
(assert-true "cl-warn: fires warning handler" warned)))
(reset-stacks!)
;; Warn with condition object
(let
((msg ""))
(begin
(cl-handler-bind
(list (list "warning" (fn (c) (set! msg (cl-condition-message c)))))
(fn
()
(cl-warn
(cl-make-condition "simple-warning" "format-control" "take care"))))
(assert-equal "cl-warn: condition object" msg "take care")))
(reset-stacks!)
;; ── 8. cl-restart-case + cl-invoke-restart ───────────────────────────────
;; Basic restart invocation
(let
((result (cl-restart-case (fn () (cl-invoke-restart "use-zero")) (list "use-zero" (list) (fn () 0)))))
(assert-equal "restart-case: invoke-restart use-zero" result 0))
(reset-stacks!)
;; Restart with argument
(let
((result (cl-restart-case (fn () (cl-invoke-restart "use-value" 77)) (list "use-value" (list "v") (fn (v) v)))))
(assert-equal "restart-case: invoke-restart with arg" result 77))
(reset-stacks!)
;; Body returns normally when restart not invoked
(let
((result (cl-restart-case (fn () 42) (list "never-used" (list) (fn () -1)))))
(assert-equal "restart-case: body result" result 42))
(reset-stacks!)
;; ── 9. cl-with-simple-restart ─────────────────────────────────────────────
(let
((result (cl-with-simple-restart "skip" "Skip this step" (fn () (cl-invoke-restart "skip") 99))))
(assert-nil "with-simple-restart: invoke returns nil" result))
(reset-stacks!)
;; ── 10. cl-find-restart ───────────────────────────────────────────────────
(let
((found (cl-restart-case (fn () (cl-find-restart "retry")) (list "retry" (list) (fn () nil)))))
(assert-true "find-restart: finds active restart" (not (nil? found))))
(reset-stacks!)
(let
((not-found (cl-restart-case (fn () (cl-find-restart "nonexistent")) (list "retry" (list) (fn () nil)))))
(assert-nil "find-restart: nil for inactive restart" not-found))
(reset-stacks!)
;; ── 11. cl-compute-restarts ───────────────────────────────────────────────
(let
((names (cl-restart-case (fn () (cl-restart-case (fn () (cl-compute-restarts)) (list "inner" (list) (fn () nil)))) (list "outer" (list) (fn () nil)))))
(assert-equal
"compute-restarts: both restarts"
names
(list "inner" "outer")))
(reset-stacks!)
;; ── 12. handler-bind + restart-case interop ───────────────────────────────
;; Classic CL pattern: error handler invokes a restart
(let
((result (cl-restart-case (fn () (cl-handler-bind (list (list "error" (fn (c) (cl-invoke-restart "use-zero")))) (fn () (cl-error "divide by zero")))) (list "use-zero" (list) (fn () 0)))))
(assert-equal "interop: handler invokes restart" result 0))
(reset-stacks!)
;; ── 13. cl-cerror ─────────────────────────────────────────────────────────
;; When "continue" restart is invoked, cerror returns nil
(let
((result (cl-restart-case (fn () (cl-cerror "continue anyway" "something bad") 42) (list "continue" (list) (fn () "resumed")))))
(assert-true
"cerror: returns"
(or (nil? result) (= result 42) (= result "resumed"))))
(reset-stacks!)
;; ── 14. slot accessor helpers ─────────────────────────────────────────────
(let
((c (cl-make-condition "simple-error" "format-control" "msg" "format-arguments" (list 1 2))))
(begin
(assert-equal
"simple-condition-format-control"
(cl-simple-condition-format-control c)
"msg")
(assert-equal
"simple-condition-format-arguments"
(cl-simple-condition-format-arguments c)
(list 1 2))))
(let
((c (cl-make-condition "type-error" "datum" 42 "expected-type" "string")))
(begin
(assert-equal "type-error-datum" (cl-type-error-datum c) 42)
(assert-equal
"type-error-expected-type"
(cl-type-error-expected-type c)
"string")))
(let
((c (cl-make-condition "arithmetic-error" "operation" "/" "operands" (list 1 0))))
(begin
(assert-equal
"arithmetic-error-operation"
(cl-arithmetic-error-operation c)
"/")
(assert-equal
"arithmetic-error-operands"
(cl-arithmetic-error-operands c)
(list 1 0))))
;; ── 15. *debugger-hook* ───────────────────────────────────────────────────
(reset-stacks!)
(let ((received nil))
(begin
(set! cl-debugger-hook
(fn (c h)
(set! received (cl-condition-message c))
(cl-invoke-restart "escape")))
(cl-restart-case
(fn () (cl-error "debugger test"))
(list "escape" (list) (fn () nil)))
(set! cl-debugger-hook nil)
(assert-equal "debugger-hook receives condition" received "debugger test")))
(reset-stacks!)
;; ── 16. *break-on-signals* ────────────────────────────────────────────────
(reset-stacks!)
(let ((triggered false))
(begin
(set! cl-break-on-signals "error")
(set! cl-debugger-hook
(fn (c h)
(set! triggered true)
(cl-invoke-restart "abort")))
(cl-restart-case
(fn ()
(cl-signal (cl-make-condition "simple-error" "format-control" "x")))
(list "abort" (list) (fn () nil)))
(set! cl-break-on-signals nil)
(set! cl-debugger-hook nil)
(assert-true "break-on-signals fires hook" triggered)))
(reset-stacks!)
;; break-on-signals: non-matching type does NOT fire hook
(let ((triggered false))
(begin
(set! cl-break-on-signals "error")
(set! cl-debugger-hook
(fn (c h) (set! triggered true) nil))
(cl-handler-bind
(list (list "warning" (fn (c) nil)))
(fn ()
(cl-signal (cl-make-condition "simple-warning" "format-control" "w"))))
(set! cl-break-on-signals nil)
(set! cl-debugger-hook nil)
(assert-equal "break-on-signals: type mismatch not triggered" triggered false)))
(reset-stacks!)
;; ── 17. cl-invoke-restart-interactively ──────────────────────────────────
(let ((result
(cl-restart-case
(fn () (cl-invoke-restart-interactively "use-default"))
(list "use-default" (list) (fn () 99)))))
(assert-equal "invoke-restart-interactively: returns restart value" result 99))
(reset-stacks!)
;; ── summary ────────────────────────────────────────────────────────────────
(if
(= failed 0)
(print (str "ok " passed "/" (+ passed failed) " condition tests passed"))
(begin
(for-each (fn (f) (print f)) failures)
(print
(str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed"))))

466
lib/common-lisp/tests/eval.sx
View File

@@ -1,466 +0,0 @@
;; CL evaluator tests
(define cl-test-pass 0)
(define cl-test-fail 0)
(define cl-test-fails (list))
(define
cl-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) (cl-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
chk
(fn
()
(when
(and ok (< i (len a)))
(do
(when
(not (cl-deep= (nth a i) (nth b i)))
(set! ok false))
(set! i (+ i 1))
(chk)))))
(chk)
ok)))
(:else false))))
(define
cl-test
(fn
(name actual expected)
(if
(cl-deep= actual expected)
(set! cl-test-pass (+ cl-test-pass 1))
(do
(set! cl-test-fail (+ cl-test-fail 1))
(append! cl-test-fails {:name name :expected expected :actual actual})))))
;; Convenience: evaluate CL string with fresh env each time
(define ev (fn (src) (cl-eval-str src (cl-make-env))))
(define evall (fn (src) (cl-eval-all-str src (cl-make-env))))
;; ── self-evaluating literals ──────────────────────────────────────
(cl-test "lit: nil" (ev "nil") nil)
(cl-test "lit: t" (ev "t") true)
(cl-test "lit: integer" (ev "42") 42)
(cl-test "lit: negative" (ev "-7") -7)
(cl-test "lit: zero" (ev "0") 0)
(cl-test "lit: string" (ev "\"hello\"") "hello")
(cl-test "lit: empty string" (ev "\"\"") "")
(cl-test "lit: keyword type" (get (ev ":foo") "cl-type") "keyword")
(cl-test "lit: keyword name" (get (ev ":foo") "name") "FOO")
(cl-test "lit: float type" (get (ev "3.14") "cl-type") "float")
;; ── QUOTE ─────────────────────────────────────────────────────────
(cl-test "quote: symbol" (ev "'x") "X")
(cl-test "quote: list" (ev "'(a b c)") (list "A" "B" "C"))
(cl-test "quote: nil" (ev "'nil") nil)
(cl-test "quote: integer" (ev "'42") 42)
(cl-test "quote: nested" (ev "'(a (b c))") (list "A" (list "B" "C")))
;; ── IF ────────────────────────────────────────────────────────────
(cl-test "if: true branch" (ev "(if t 1 2)") 1)
(cl-test "if: false branch" (ev "(if nil 1 2)") 2)
(cl-test "if: no else nil" (ev "(if nil 99)") nil)
(cl-test "if: number truthy" (ev "(if 0 'yes 'no)") "YES")
(cl-test "if: empty string truthy" (ev "(if \"\" 'yes 'no)") "YES")
(cl-test "if: nested" (ev "(if t (if nil 1 2) 3)") 2)
;; ── PROGN ────────────────────────────────────────────────────────
(cl-test "progn: single" (ev "(progn 42)") 42)
(cl-test "progn: multiple" (ev "(progn 1 2 3)") 3)
(cl-test "progn: nil last" (ev "(progn 1 nil)") nil)
;; ── AND / OR ─────────────────────────────────────────────────────
(cl-test "and: empty" (ev "(and)") true)
(cl-test "and: all true" (ev "(and 1 2 3)") 3)
(cl-test "and: short-circuit" (ev "(and nil 99)") nil)
(cl-test "and: returns last" (ev "(and 1 2)") 2)
(cl-test "or: empty" (ev "(or)") nil)
(cl-test "or: first truthy" (ev "(or 1 2)") 1)
(cl-test "or: all nil" (ev "(or nil nil)") nil)
(cl-test "or: short-circuit" (ev "(or nil 42)") 42)
;; ── COND ─────────────────────────────────────────────────────────
(cl-test "cond: first match" (ev "(cond (t 1) (t 2))") 1)
(cl-test "cond: second match" (ev "(cond (nil 1) (t 2))") 2)
(cl-test "cond: no match" (ev "(cond (nil 1) (nil 2))") nil)
(cl-test "cond: returns test value" (ev "(cond (42))") 42)
;; ── WHEN / UNLESS ─────────────────────────────────────────────────
(cl-test "when: true" (ev "(when t 1 2 3)") 3)
(cl-test "when: nil" (ev "(when nil 99)") nil)
(cl-test "unless: nil runs" (ev "(unless nil 42)") 42)
(cl-test "unless: true skips" (ev "(unless t 99)") nil)
;; ── LET ──────────────────────────────────────────────────────────
(cl-test "let: empty bindings" (ev "(let () 42)") 42)
(cl-test "let: single binding" (ev "(let ((x 5)) x)") 5)
(cl-test "let: two bindings" (ev "(let ((x 3) (y 4)) (+ x y))") 7)
(cl-test "let: parallel" (ev "(let ((x 1)) (let ((x 2) (y x)) y))") 1)
(cl-test "let: nested" (ev "(let ((x 1)) (let ((y 2)) (+ x y)))") 3)
(cl-test "let: progn body" (ev "(let ((x 5)) (+ x 1) (* x 2))") 10)
(cl-test "let: bare name nil" (ev "(let (x) x)") nil)
;; ── LET* ─────────────────────────────────────────────────────────
(cl-test "let*: sequential" (ev "(let* ((x 1) (y (+ x 1))) y)") 2)
(cl-test "let*: chain" (ev "(let* ((a 2) (b (* a 3)) (c (+ b 1))) c)") 7)
(cl-test "let*: shadow" (ev "(let ((x 1)) (let* ((x 2) (y x)) y))") 2)
;; ── SETQ / SETF ──────────────────────────────────────────────────
(cl-test "setq: basic" (ev "(let ((x 0)) (setq x 5) x)") 5)
(cl-test "setq: returns value" (ev "(let ((x 0)) (setq x 99))") 99)
(cl-test "setf: basic" (ev "(let ((x 0)) (setf x 7) x)") 7)
;; ── LAMBDA ────────────────────────────────────────────────────────
(cl-test "lambda: call" (ev "((lambda (x) x) 42)") 42)
(cl-test "lambda: multi-arg" (ev "((lambda (x y) (+ x y)) 3 4)") 7)
(cl-test "lambda: closure" (ev "(let ((n 10)) ((lambda (x) (+ x n)) 5))") 15)
(cl-test "lambda: rest arg"
(ev "((lambda (x &rest xs) (cons x xs)) 1 2 3)")
{:cl-type "cons" :car 1 :cdr (list 2 3)})
(cl-test "lambda: optional no default"
(ev "((lambda (&optional x) x))")
nil)
(cl-test "lambda: optional with arg"
(ev "((lambda (&optional (x 99)) x) 42)")
42)
(cl-test "lambda: optional default used"
(ev "((lambda (&optional (x 7)) x))")
7)
;; ── FUNCTION ─────────────────────────────────────────────────────
(cl-test "function: lambda" (get (ev "(function (lambda (x) x))") "cl-type") "function")
;; ── DEFUN ────────────────────────────────────────────────────────
(cl-test "defun: returns name" (evall "(defun sq (x) (* x x))") "SQ")
(cl-test "defun: call" (evall "(defun sq (x) (* x x)) (sq 5)") 25)
(cl-test "defun: multi-arg" (evall "(defun add (x y) (+ x y)) (add 3 4)") 7)
(cl-test "defun: recursive factorial"
(evall "(defun fact (n) (if (<= n 1) 1 (* n (fact (- n 1))))) (fact 5)")
120)
(cl-test "defun: multiple calls"
(evall "(defun double (x) (* x 2)) (+ (double 3) (double 5))")
16)
;; ── FLET ─────────────────────────────────────────────────────────
(cl-test "flet: basic"
(ev "(flet ((double (x) (* x 2))) (double 5))")
10)
(cl-test "flet: sees outer vars"
(ev "(let ((n 3)) (flet ((add-n (x) (+ x n))) (add-n 7)))")
10)
(cl-test "flet: non-recursive"
(ev "(flet ((f (x) (+ x 1))) (flet ((f (x) (f (f x)))) (f 5)))")
7)
;; ── LABELS ────────────────────────────────────────────────────────
(cl-test "labels: basic"
(ev "(labels ((greet (x) x)) (greet 42))")
42)
(cl-test "labels: recursive"
(ev "(labels ((count (n) (if (<= n 0) 0 (+ 1 (count (- n 1)))))) (count 5))")
5)
(cl-test "labels: mutual recursion"
(ev "(labels
((even? (n) (if (= n 0) t (odd? (- n 1))))
(odd? (n) (if (= n 0) nil (even? (- n 1)))))
(list (even? 4) (odd? 3)))")
(list true true))
;; ── THE / LOCALLY / EVAL-WHEN ────────────────────────────────────
(cl-test "the: passthrough" (ev "(the integer 42)") 42)
(cl-test "the: string" (ev "(the string \"hi\")") "hi")
(cl-test "locally: body" (ev "(locally 1 2 3)") 3)
(cl-test "eval-when: execute" (ev "(eval-when (:execute) 99)") 99)
(cl-test "eval-when: no execute" (ev "(eval-when (:compile-toplevel) 99)") nil)
;; ── DEFVAR / DEFPARAMETER ────────────────────────────────────────
(cl-test "defvar: returns name" (evall "(defvar *x* 10)") "*X*")
(cl-test "defparameter: sets value" (evall "(defparameter *y* 42) *y*") 42)
(cl-test "defvar: no reinit" (evall "(defvar *z* 1) (defvar *z* 99) *z*") 1)
;; ── built-in arithmetic ───────────────────────────────────────────
(cl-test "arith: +" (ev "(+ 1 2 3)") 6)
(cl-test "arith: + zero" (ev "(+)") 0)
(cl-test "arith: -" (ev "(- 10 3 2)") 5)
(cl-test "arith: - negate" (ev "(- 5)") -5)
(cl-test "arith: *" (ev "(* 2 3 4)") 24)
(cl-test "arith: * one" (ev "(*)") 1)
(cl-test "arith: /" (ev "(/ 12 3)") 4)
(cl-test "arith: max" (ev "(max 3 1 4 1 5)") 5)
(cl-test "arith: min" (ev "(min 3 1 4 1 5)") 1)
(cl-test "arith: abs neg" (ev "(abs -7)") 7)
(cl-test "arith: abs pos" (ev "(abs 7)") 7)
;; ── built-in comparisons ──────────────────────────────────────────
(cl-test "cmp: = true" (ev "(= 3 3)") true)
(cl-test "cmp: = false" (ev "(= 3 4)") nil)
(cl-test "cmp: /=" (ev "(/= 3 4)") true)
(cl-test "cmp: <" (ev "(< 1 2)") true)
(cl-test "cmp: > false" (ev "(> 1 2)") nil)
(cl-test "cmp: <=" (ev "(<= 2 2)") true)
;; ── built-in predicates ───────────────────────────────────────────
(cl-test "pred: null nil" (ev "(null nil)") true)
(cl-test "pred: null non-nil" (ev "(null 5)") nil)
(cl-test "pred: not nil" (ev "(not nil)") true)
(cl-test "pred: not truthy" (ev "(not 5)") nil)
(cl-test "pred: numberp" (ev "(numberp 5)") true)
(cl-test "pred: numberp str" (ev "(numberp \"x\")") nil)
(cl-test "pred: stringp" (ev "(stringp \"hello\")") true)
(cl-test "pred: listp list" (ev "(listp '(1))") true)
(cl-test "pred: listp nil" (ev "(listp nil)") true)
(cl-test "pred: zerop" (ev "(zerop 0)") true)
(cl-test "pred: plusp" (ev "(plusp 3)") true)
(cl-test "pred: evenp" (ev "(evenp 4)") true)
(cl-test "pred: oddp" (ev "(oddp 3)") true)
;; ── built-in list ops ─────────────────────────────────────────────
(cl-test "list: car" (ev "(car '(1 2 3))") 1)
(cl-test "list: cdr" (ev "(cdr '(1 2 3))") (list 2 3))
(cl-test "list: cons" (get (ev "(cons 1 2)") "car") 1)
(cl-test "list: list fn" (ev "(list 1 2 3)") (list 1 2 3))
(cl-test "list: length" (ev "(length '(a b c))") 3)
(cl-test "list: length nil" (ev "(length nil)") 0)
(cl-test "list: append" (ev "(append '(1 2) '(3 4))") (list 1 2 3 4))
(cl-test "list: first" (ev "(first '(10 20 30))") 10)
(cl-test "list: second" (ev "(second '(10 20 30))") 20)
(cl-test "list: third" (ev "(third '(10 20 30))") 30)
(cl-test "list: rest" (ev "(rest '(1 2 3))") (list 2 3))
(cl-test "list: nth" (ev "(nth 1 '(a b c))") "B")
(cl-test "list: reverse" (ev "(reverse '(1 2 3))") (list 3 2 1))
;; ── FUNCALL / APPLY / MAPCAR ─────────────────────────────────────
(cl-test "funcall: lambda"
(ev "(funcall (lambda (x) (* x x)) 5)")
25)
(cl-test "apply: basic"
(ev "(apply #'+ '(1 2 3))")
6)
(cl-test "apply: leading args"
(ev "(apply #'+ 1 2 '(3 4))")
10)
(cl-test "mapcar: basic"
(ev "(mapcar (lambda (x) (* x 2)) '(1 2 3))")
(list 2 4 6))
;; ── BLOCK / RETURN-FROM / RETURN ─────────────────────────────────
(cl-test "block: last form value"
(ev "(block done 1 2 3)")
3)
(cl-test "block: empty body"
(ev "(block done)")
nil)
(cl-test "block: single form"
(ev "(block foo 42)")
42)
(cl-test "block: return-from"
(ev "(block done 1 (return-from done 99) 2)")
99)
(cl-test "block: return-from nil block"
(ev "(block nil 1 (return-from nil 42) 3)")
42)
(cl-test "block: return-from no value"
(ev "(block done (return-from done))")
nil)
(cl-test "block: nested inner return stays inner"
(ev "(block outer (block inner (return-from inner 1) 2) 3)")
3)
(cl-test "block: nested outer return"
(ev "(block outer (block inner 1 2) (return-from outer 99) 3)")
99)
(cl-test "return: shorthand for nil block"
(ev "(block nil (return 77))")
77)
(cl-test "return: no value"
(ev "(block nil 1 (return) 2)")
nil)
(cl-test "block: return-from inside let"
(ev "(block done (let ((x 5)) (when (> x 3) (return-from done x))) 0)")
5)
(cl-test "block: return-from inside progn"
(ev "(block done (progn (return-from done 7) 99))")
7)
(cl-test "block: return-from through function"
(ev "(block done (flet ((f () (return-from done 42))) (f)) nil)")
42)
;; ── TAGBODY / GO ─────────────────────────────────────────────────
(cl-test "tagbody: empty returns nil"
(ev "(tagbody)")
nil)
(cl-test "tagbody: forms only, returns nil"
(ev "(let ((x 0)) (tagbody (setq x 1) (setq x 2)) x)")
2)
(cl-test "tagbody: tag only, returns nil"
(ev "(tagbody done)")
nil)
(cl-test "tagbody: go skips forms"
(ev "(let ((x 0)) (tagbody (go done) (setq x 99) done) x)")
0)
(cl-test "tagbody: go to later tag"
(ev "(let ((x 0)) (tagbody start (setq x (+ x 1)) (go done) (setq x 99) done) x)")
1)
(cl-test "tagbody: loop with counter"
(ev "(let ((n 0)) (tagbody loop (when (>= n 3) (go done)) (setq n (+ n 1)) (go loop) done) n)")
3)
(cl-test "tagbody: go inside when"
(ev "(let ((x 0)) (tagbody (setq x 1) (when t (go done)) (setq x 99) done) x)")
1)
(cl-test "tagbody: go inside progn"
(ev "(let ((x 0)) (tagbody (progn (setq x 1) (go done)) (setq x 99) done) x)")
1)
(cl-test "tagbody: go inside let"
(ev "(let ((acc 0)) (tagbody (let ((y 5)) (when (> y 3) (go done))) (setq acc 99) done) acc)")
0)
(cl-test "tagbody: integer tags"
(ev "(let ((x 0)) (tagbody (go 2) 1 (setq x 1) (go 3) 2 (setq x 2) (go 3) 3) x)")
2)
(cl-test "tagbody: block-return propagates out"
(ev "(block done (tagbody (return-from done 42)) nil)")
42)
;; ── UNWIND-PROTECT ───────────────────────────────────────────────
(cl-test "unwind-protect: normal returns protected"
(ev "(unwind-protect 42 nil)")
42)
(cl-test "unwind-protect: cleanup runs"
(ev "(let ((x 0)) (unwind-protect 1 (setq x 99)) x)")
99)
(cl-test "unwind-protect: cleanup result ignored"
(ev "(unwind-protect 42 777)")
42)
(cl-test "unwind-protect: multiple cleanup forms"
(ev "(let ((x 0)) (unwind-protect 1 (setq x (+ x 1)) (setq x (+ x 1))) x)")
2)
(cl-test "unwind-protect: cleanup on return-from"
(ev "(let ((x 0)) (block done (unwind-protect (return-from done 7) (setq x 99))) x)")
99)
(cl-test "unwind-protect: return-from still propagates"
(ev "(block done (unwind-protect (return-from done 42) nil))")
42)
(cl-test "unwind-protect: cleanup on go"
(ev "(let ((x 0)) (tagbody (unwind-protect (go done) (setq x 1)) done) x)")
1)
(cl-test "unwind-protect: nested, inner cleanup first"
(ev "(let ((n 0)) (unwind-protect (unwind-protect 1 (setq n (+ n 10))) (setq n (+ n 1))) n)")
11)
;; ── VALUES / MULTIPLE-VALUE-BIND / NTH-VALUE ────────────────────
(cl-test "values: single returns plain"
(ev "(values 42)")
42)
(cl-test "values: zero returns nil"
(ev "(values)")
nil)
(cl-test "values: multi — primary via funcall"
(ev "(car (list (values 1 2)))")
1)
(cl-test "multiple-value-bind: basic"
(ev "(multiple-value-bind (a b) (values 1 2) (+ a b))")
3)
(cl-test "multiple-value-bind: extra vars get nil"
(ev "(multiple-value-bind (a b c) (values 10 20) (list a b c))")
(list 10 20 nil))
(cl-test "multiple-value-bind: extra values ignored"
(ev "(multiple-value-bind (a) (values 1 2 3) a)")
1)
(cl-test "multiple-value-bind: single value source"
(ev "(multiple-value-bind (a b) 42 (list a b))")
(list 42 nil))
(cl-test "nth-value: 0"
(ev "(nth-value 0 (values 10 20 30))")
10)
(cl-test "nth-value: 1"
(ev "(nth-value 1 (values 10 20 30))")
20)
(cl-test "nth-value: out of range"
(ev "(nth-value 5 (values 10 20))")
nil)
(cl-test "multiple-value-call: basic"
(ev "(multiple-value-call #'+ (values 1 2) (values 3 4))")
10)
(cl-test "multiple-value-prog1: returns first"
(ev "(multiple-value-prog1 1 2 3)")
1)
(cl-test "multiple-value-prog1: side effects run"
(ev "(let ((x 0)) (multiple-value-prog1 99 (setq x 7)) x)")
7)
(cl-test "values: nil primary in if"
(ev "(if (values nil t) 'yes 'no)")
"NO")
(cl-test "values: truthy primary in if"
(ev "(if (values 42 nil) 'yes 'no)")
"YES")
;; --- Dynamic variables ---
(cl-test "defvar marks special"
(do (ev "(defvar *dv* 10)")
(cl-special? "*DV*"))
true)
(cl-test "defvar: let rebinds dynamically"
(ev "(progn (defvar *x* 1) (defun get-x () *x*) (let ((*x* 99)) (get-x)))")
99)
(cl-test "defvar: binding restores after let"
(ev "(progn (defvar *yrst* 5) (let ((*yrst* 42)) *yrst*) *yrst*)")
5)
(cl-test "defparameter marks special"
(do (ev "(defparameter *dp* 0)")
(cl-special? "*DP*"))
true)
(cl-test "defparameter: let rebinds dynamically"
(ev "(progn (defparameter *z* 10) (defun get-z () *z*) (let ((*z* 77)) (get-z)))")
77)
(cl-test "defparameter: always assigns"
(ev "(progn (defparameter *p* 1) (defparameter *p* 2) *p*)")
2)
(cl-test "dynamic binding: nested lets"
(ev "(progn (defvar *n* 0) (let ((*n* 1)) (let ((*n* 2)) *n*)))")
2)
(cl-test "dynamic binding: restores across nesting"
(ev "(progn (defvar *m* 10) (let ((*m* 20)) (let ((*m* 30)) nil)) *m*)")
10)

204
lib/common-lisp/tests/lambda.sx
View File

@@ -1,204 +0,0 @@
;; Lambda list parser tests
(define cl-test-pass 0)
(define cl-test-fail 0)
(define cl-test-fails (list))
;; Deep structural equality for dicts and lists
(define
cl-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) (cl-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
chk
(fn
()
(when
(and ok (< i (len a)))
(do
(when
(not (cl-deep= (nth a i) (nth b i)))
(set! ok false))
(set! i (+ i 1))
(chk)))))
(chk)
ok)))
(:else false))))
(define
cl-test
(fn
(name actual expected)
(if
(cl-deep= actual expected)
(set! cl-test-pass (+ cl-test-pass 1))
(do
(set! cl-test-fail (+ cl-test-fail 1))
(append! cl-test-fails {:name name :expected expected :actual actual})))))
;; Helper: parse lambda list from string "(x y ...)"
(define ll (fn (src) (cl-parse-lambda-list-str src)))
(define ll-req (fn (src) (get (ll src) "required")))
(define ll-opt (fn (src) (get (ll src) "optional")))
(define ll-rest (fn (src) (get (ll src) "rest")))
(define ll-key (fn (src) (get (ll src) "key")))
(define ll-aok (fn (src) (get (ll src) "allow-other-keys")))
(define ll-aux (fn (src) (get (ll src) "aux")))
;; ── required parameters ───────────────────────────────────────────
(cl-test "required: empty" (ll-req "()") (list))
(cl-test "required: one" (ll-req "(x)") (list "X"))
(cl-test "required: two" (ll-req "(x y)") (list "X" "Y"))
(cl-test "required: three" (ll-req "(a b c)") (list "A" "B" "C"))
(cl-test "required: upcased" (ll-req "(foo bar)") (list "FOO" "BAR"))
;; ── &optional ─────────────────────────────────────────────────────
(cl-test "optional: none" (ll-opt "(x)") (list))
(cl-test
"optional: bare symbol"
(ll-opt "(x &optional z)")
(list {:name "Z" :default nil :supplied nil}))
(cl-test
"optional: with default"
(ll-opt "(x &optional (z 0))")
(list {:name "Z" :default 0 :supplied nil}))
(cl-test
"optional: with supplied-p"
(ll-opt "(x &optional (z 0 z-p))")
(list {:name "Z" :default 0 :supplied "Z-P"}))
(cl-test
"optional: two params"
(ll-opt "(&optional a (b 1))")
(list {:name "A" :default nil :supplied nil} {:name "B" :default 1 :supplied nil}))
(cl-test
"optional: string default"
(ll-opt "(&optional (name \"world\"))")
(list {:name "NAME" :default {:cl-type "string" :value "world"} :supplied nil}))
;; ── &rest ─────────────────────────────────────────────────────────
(cl-test "rest: none" (ll-rest "(x)") nil)
(cl-test "rest: present" (ll-rest "(x &rest args)") "ARGS")
(cl-test "rest: with required" (ll-rest "(a b &rest tail)") "TAIL")
;; &body is an alias for &rest
(cl-test "body: alias for rest" (ll-rest "(&body forms)") "FORMS")
;; rest doesn't consume required params
(cl-test "rest: required still there" (ll-req "(a b &rest rest)") (list "A" "B"))
;; ── &key ──────────────────────────────────────────────────────────
(cl-test "key: none" (ll-key "(x)") (list))
(cl-test
"key: bare symbol"
(ll-key "(&key x)")
(list {:name "X" :keyword "X" :default nil :supplied nil}))
(cl-test
"key: with default"
(ll-key "(&key (x 42))")
(list {:name "X" :keyword "X" :default 42 :supplied nil}))
(cl-test
"key: with supplied-p"
(ll-key "(&key (x 42 x-p))")
(list {:name "X" :keyword "X" :default 42 :supplied "X-P"}))
(cl-test
"key: two params"
(ll-key "(&key a b)")
(list
{:name "A" :keyword "A" :default nil :supplied nil}
{:name "B" :keyword "B" :default nil :supplied nil}))
;; ── &allow-other-keys ─────────────────────────────────────────────
(cl-test "aok: absent" (ll-aok "(x)") false)
(cl-test "aok: present" (ll-aok "(&key x &allow-other-keys)") true)
;; ── &aux ──────────────────────────────────────────────────────────
(cl-test "aux: none" (ll-aux "(x)") (list))
(cl-test
"aux: bare symbol"
(ll-aux "(&aux temp)")
(list {:name "TEMP" :init nil}))
(cl-test
"aux: with init"
(ll-aux "(&aux (count 0))")
(list {:name "COUNT" :init 0}))
(cl-test
"aux: two vars"
(ll-aux "(&aux a (b 1))")
(list {:name "A" :init nil} {:name "B" :init 1}))
;; ── combined ──────────────────────────────────────────────────────
(cl-test
"combined: full lambda list"
(let
((parsed (ll "(x y &optional (z 0 z-p) &rest args &key a (b nil b-p) &aux temp)")))
(list
(get parsed "required")
(get (nth (get parsed "optional") 0) "name")
(get (nth (get parsed "optional") 0) "default")
(get (nth (get parsed "optional") 0) "supplied")
(get parsed "rest")
(get (nth (get parsed "key") 0) "name")
(get (nth (get parsed "key") 1) "supplied")
(get (nth (get parsed "aux") 0) "name")))
(list
(list "X" "Y")
"Z"
0
"Z-P"
"ARGS"
"A"
"B-P"
"TEMP"))
(cl-test
"combined: required only stops before &"
(ll-req "(a b &optional c)")
(list "A" "B"))
(cl-test
"combined: required only with &key"
(ll-req "(x &key y)")
(list "X"))
(cl-test
"combined: &rest and &key together"
(let
((parsed (ll "(&rest args &key verbose)")))
(list (get parsed "rest") (get (nth (get parsed "key") 0) "name")))
(list "ARGS" "VERBOSE"))

204
lib/common-lisp/tests/macros.sx
View File

@@ -1,204 +0,0 @@
;; lib/common-lisp/tests/macros.sx — Phase 5: defmacro, gensym, LOOP tests
;;
;; Depends on: runtime.sx, eval.sx, loop.sx already loaded.
;; Tests via (ev "...") using the CL evaluator.
(define ev (fn (src) (cl-eval-str src (cl-make-env))))
(define evall (fn (src) (cl-eval-all-str src (cl-make-env))))
(define passed 0)
(define failed 0)
(define failures (list))
(define
check
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
;; ── defmacro basics ──────────────────────────────────────────────────────────
(check
"defmacro returns name"
(ev "(defmacro my-or (a b) (list 'if a a b))")
"MY-OR")
(check
"defmacro expansion works"
(ev "(progn (defmacro my-inc (x) (list '+ x 1)) (my-inc 5))")
6)
(check
"defmacro with &rest"
(ev "(progn (defmacro my-list (&rest xs) (cons 'list xs)) (my-list 1 2 3))")
(list 1 2 3))
(check
"nested macro expansion"
(ev "(progn (defmacro sq (x) (list '* x x)) (sq 7))")
49)
(check
"macro in conditional"
(ev
"(progn (defmacro my-when (c &rest body) (list 'if c (cons 'progn body) nil)) (my-when t 10 20))")
20)
(check
"macro returns nil branch"
(ev
"(progn (defmacro my-when (c &rest body) (list 'if c (cons 'progn body) nil)) (my-when nil 42))")
nil)
;; ── macroexpand ───────────────────────────────────────────────────────────────
(check
"macroexpand returns expanded form"
(ev "(progn (defmacro double (x) (list '+ x x)) (macroexpand '(double 5)))")
(list "+" 5 5))
;; ── gensym ────────────────────────────────────────────────────────────────────
(check "gensym returns string" (ev "(stringp (gensym))") true)
(check
"gensym prefix"
(ev "(let ((g (gensym \"MY\"))) (not (= g nil)))")
true)
(check "gensyms are unique" (ev "(not (= (gensym) (gensym)))") true)
;; ── swap! macro with gensym ───────────────────────────────────────────────────
(check
"swap! macro"
(evall
"(defmacro swap! (a b) (let ((tmp (gensym))) (list 'let (list (list tmp a)) (list 'setq a b) (list 'setq b tmp)))) (defvar *a* 10) (defvar *b* 20) (swap! *a* *b*) (list *a* *b*)")
(list 20 10))
;; ── LOOP: basic repeat and collect ────────────────────────────────────────────
(check
"loop repeat collect"
(ev "(loop repeat 3 collect 99)")
(list 99 99 99))
(check
"loop for-in collect"
(ev "(loop for x in '(1 2 3) collect (* x x))")
(list 1 4 9))
(check
"loop for-from-to collect"
(ev "(loop for i from 1 to 5 collect i)")
(list 1 2 3 4 5))
(check
"loop for-from-below collect"
(ev "(loop for i from 0 below 4 collect i)")
(list 0 1 2 3))
(check
"loop for-downto collect"
(ev "(loop for i from 5 downto 1 collect i)")
(list 5 4 3 2 1))
(check
"loop for-by collect"
(ev "(loop for i from 0 to 10 by 2 collect i)")
(list 0 2 4 6 8 10))
;; ── LOOP: sum, count, maximize, minimize ─────────────────────────────────────
(check "loop sum" (ev "(loop for i from 1 to 5 sum i)") 15)
(check
"loop count"
(ev "(loop for x in '(1 2 3 4 5) count (> x 3))")
2)
(check
"loop maximize"
(ev "(loop for x in '(3 1 4 1 5 9 2 6) maximize x)")
9)
(check
"loop minimize"
(ev "(loop for x in '(3 1 4 1 5 9 2 6) minimize x)")
1)
;; ── LOOP: while and until ─────────────────────────────────────────────────────
(check
"loop while"
(ev "(loop for i from 1 to 10 while (< i 5) collect i)")
(list 1 2 3 4))
(check
"loop until"
(ev "(loop for i from 1 to 10 until (= i 5) collect i)")
(list 1 2 3 4))
;; ── LOOP: when / unless ───────────────────────────────────────────────────────
(check
"loop when filter"
(ev "(loop for i from 0 below 8 when (evenp i) collect i)")
(list 0 2 4 6))
(check
"loop unless filter"
(ev "(loop for i from 0 below 8 unless (evenp i) collect i)")
(list 1 3 5 7))
;; ── LOOP: append ─────────────────────────────────────────────────────────────
(check
"loop append"
(ev "(loop for x in '((1 2) (3 4) (5 6)) append x)")
(list 1 2 3 4 5 6))
;; ── LOOP: always, never, thereis ─────────────────────────────────────────────
(check
"loop always true"
(ev "(loop for x in '(2 4 6) always (evenp x))")
true)
(check
"loop always false"
(ev "(loop for x in '(2 3 6) always (evenp x))")
false)
(check "loop never" (ev "(loop for x in '(1 3 5) never (evenp x))") true)
(check "loop thereis" (ev "(loop for x in '(1 2 3) thereis (> x 2))") true)
;; ── LOOP: for = then (general iteration) ─────────────────────────────────────
(check
"loop for = then doubling"
(ev "(loop repeat 5 for x = 1 then (* x 2) collect x)")
(list 1 2 4 8 16))
;; ── summary ────────────────────────────────────────────────────────────────
(define macro-passed passed)
(define macro-failed failed)
(define macro-failures failures)

160
lib/common-lisp/tests/parse.sx
View File

@@ -1,160 +0,0 @@
;; Common Lisp reader/parser tests
(define cl-test-pass 0)
(define cl-test-fail 0)
(define cl-test-fails (list))
(define
cl-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) (cl-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
chk
(fn
()
(when
(and ok (< i (len a)))
(do
(when
(not (cl-deep= (nth a i) (nth b i)))
(set! ok false))
(set! i (+ i 1))
(chk)))))
(chk)
ok)))
(:else false))))
(define
cl-test
(fn
(name actual expected)
(if
(cl-deep= actual expected)
(set! cl-test-pass (+ cl-test-pass 1))
(do
(set! cl-test-fail (+ cl-test-fail 1))
(append! cl-test-fails {:name name :expected expected :actual actual})))))
;; ── atoms ─────────────────────────────────────────────────────────
(cl-test "integer: 42" (cl-read "42") 42)
(cl-test "integer: 0" (cl-read "0") 0)
(cl-test "integer: negative" (cl-read "-5") -5)
(cl-test "integer: positive sign" (cl-read "+3") 3)
(cl-test "integer: hex #xFF" (cl-read "#xFF") 255)
(cl-test "integer: hex #xAB" (cl-read "#xAB") 171)
(cl-test "integer: binary #b1010" (cl-read "#b1010") 10)
(cl-test "integer: octal #o17" (cl-read "#o17") 15)
(cl-test "float: type" (get (cl-read "3.14") "cl-type") "float")
(cl-test "float: value" (get (cl-read "3.14") "value") "3.14")
(cl-test "float: neg" (get (cl-read "-2.5") "value") "-2.5")
(cl-test "float: exp" (get (cl-read "1.0e10") "value") "1.0e10")
(cl-test "ratio: type" (get (cl-read "1/3") "cl-type") "ratio")
(cl-test "ratio: value" (get (cl-read "1/3") "value") "1/3")
(cl-test "ratio: 22/7" (get (cl-read "22/7") "value") "22/7")
(cl-test "string: basic" (cl-read "\"hello\"") {:cl-type "string" :value "hello"})
(cl-test "string: empty" (cl-read "\"\"") {:cl-type "string" :value ""})
(cl-test "string: with escape" (cl-read "\"a\\nb\"") {:cl-type "string" :value "a\nb"})
(cl-test "symbol: foo" (cl-read "foo") "FOO")
(cl-test "symbol: BAR" (cl-read "BAR") "BAR")
(cl-test "symbol: pkg:sym" (cl-read "cl:car") "CL:CAR")
(cl-test "symbol: pkg::sym" (cl-read "pkg::foo") "PKG::FOO")
(cl-test "nil: symbol" (cl-read "nil") nil)
(cl-test "nil: uppercase" (cl-read "NIL") nil)
(cl-test "t: symbol" (cl-read "t") true)
(cl-test "t: uppercase" (cl-read "T") true)
(cl-test "keyword: type" (get (cl-read ":foo") "cl-type") "keyword")
(cl-test "keyword: name" (get (cl-read ":foo") "name") "FOO")
(cl-test "keyword: :test" (get (cl-read ":test") "name") "TEST")
(cl-test "char: type" (get (cl-read "#\\a") "cl-type") "char")
(cl-test "char: value" (get (cl-read "#\\a") "value") "a")
(cl-test "char: Space" (get (cl-read "#\\Space") "value") " ")
(cl-test "char: Newline" (get (cl-read "#\\Newline") "value") "\n")
(cl-test "uninterned: type" (get (cl-read "#:foo") "cl-type") "uninterned")
(cl-test "uninterned: name" (get (cl-read "#:foo") "name") "FOO")
;; ── lists ─────────────────────────────────────────────────────────
(cl-test "list: empty" (cl-read "()") (list))
(cl-test "list: one element" (cl-read "(foo)") (list "FOO"))
(cl-test "list: two elements" (cl-read "(foo bar)") (list "FOO" "BAR"))
(cl-test "list: nested" (cl-read "((a b) c)") (list (list "A" "B") "C"))
(cl-test "list: with integer" (cl-read "(+ 1 2)") (list "+" 1 2))
(cl-test "list: with string" (cl-read "(print \"hi\")") (list "PRINT" {:cl-type "string" :value "hi"}))
(cl-test "list: nil element" (cl-read "(a nil b)") (list "A" nil "B"))
(cl-test "list: t element" (cl-read "(a t b)") (list "A" true "B"))
;; ── dotted pairs ──────────────────────────────────────────────<E29480><E29480>──
(cl-test "dotted: type" (get (cl-read "(a . b)") "cl-type") "cons")
(cl-test "dotted: car" (get (cl-read "(a . b)") "car") "A")
(cl-test "dotted: cdr" (get (cl-read "(a . b)") "cdr") "B")
(cl-test "dotted: number cdr" (get (cl-read "(x . 42)") "cdr") 42)
;; ── reader macros ────────────────────────────────────────────────<E29480><E29480>
(cl-test "quote: form" (cl-read "'x") (list "QUOTE" "X"))
(cl-test "quote: list" (cl-read "'(a b)") (list "QUOTE" (list "A" "B")))
(cl-test "backquote: form" (cl-read "`x") (list "QUASIQUOTE" "X"))
(cl-test "unquote: form" (cl-read ",x") (list "UNQUOTE" "X"))
(cl-test "comma-at: form" (cl-read ",@x") (list "UNQUOTE-SPLICING" "X"))
(cl-test "function: form" (cl-read "#'foo") (list "FUNCTION" "FOO"))
;; ── vector ────────────────────────────────────────────────────────
(cl-test "vector: type" (get (cl-read "#(1 2 3)") "cl-type") "vector")
(cl-test "vector: elements" (get (cl-read "#(1 2 3)") "elements") (list 1 2 3))
(cl-test "vector: empty" (get (cl-read "#()") "elements") (list))
(cl-test "vector: mixed" (get (cl-read "#(a 1 \"s\")") "elements") (list "A" 1 {:cl-type "string" :value "s"}))
;; ── cl-read-all ───────────────────────────────────────────────────
(cl-test
"read-all: empty"
(cl-read-all "")
(list))
(cl-test
"read-all: two forms"
(cl-read-all "42 foo")
(list 42 "FOO"))
(cl-test
"read-all: three forms"
(cl-read-all "(+ 1 2) (+ 3 4) hello")
(list (list "+" 1 2) (list "+" 3 4) "HELLO"))
(cl-test
"read-all: with comments"
(cl-read-all "; this is a comment\n42 ; inline\nfoo")
(list 42 "FOO"))
(cl-test
"read-all: defun form"
(nth (cl-read-all "(defun square (x) (* x x))") 0)
(list "DEFUN" "SQUARE" (list "X") (list "*" "X" "X")))

291
lib/common-lisp/tests/programs/geometry.sx
View File

@@ -1,291 +0,0 @@
;; geometry.sx — Multiple dispatch with CLOS
;;
;; Demonstrates generic functions dispatching on combinations of
;; geometric types: point, line, plane.
;;
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
;; ── geometric classes ──────────────────────────────────────────────────────
(clos-defclass "geo-point" (list "t") (list {:initform 0 :initarg ":px" :reader nil :writer nil :accessor nil :name "px"} {:initform 0 :initarg ":py" :reader nil :writer nil :accessor nil :name "py"}))
(clos-defclass "geo-line" (list "t") (list {:initform nil :initarg ":p1" :reader nil :writer nil :accessor nil :name "p1"} {:initform nil :initarg ":p2" :reader nil :writer nil :accessor nil :name "p2"}))
(clos-defclass "geo-plane" (list "t") (list {:initform nil :initarg ":normal" :reader nil :writer nil :accessor nil :name "normal"} {:initform 0 :initarg ":d" :reader nil :writer nil :accessor nil :name "d"}))
;; ── helpers ────────────────────────────────────────────────────────────────
(define geo-point-x (fn (p) (clos-slot-value p "px")))
(define geo-point-y (fn (p) (clos-slot-value p "py")))
(define
geo-make-point
(fn (x y) (clos-make-instance "geo-point" ":px" x ":py" y)))
(define
geo-make-line
(fn (p1 p2) (clos-make-instance "geo-line" ":p1" p1 ":p2" p2)))
(define
geo-make-plane
(fn
(nx ny d)
(clos-make-instance "geo-plane" ":normal" (list nx ny) ":d" d)))
;; ── describe generic ───────────────────────────────────────────────────────
(clos-defgeneric "geo-describe" {})
(clos-defmethod
"geo-describe"
(list)
(list "geo-point")
(fn
(args next-fn)
(let
((p (first args)))
(str "P(" (geo-point-x p) "," (geo-point-y p) ")"))))
(clos-defmethod
"geo-describe"
(list)
(list "geo-line")
(fn
(args next-fn)
(let
((l (first args)))
(str
"L["
(clos-call-generic "geo-describe" (list (clos-slot-value l "p1")))
"-"
(clos-call-generic "geo-describe" (list (clos-slot-value l "p2")))
"]"))))
(clos-defmethod
"geo-describe"
(list)
(list "geo-plane")
(fn
(args next-fn)
(let
((pl (first args)))
(str "Plane(d=" (clos-slot-value pl "d") ")"))))
;; ── intersect: multi-dispatch generic ─────────────────────────────────────
;;
;; Returns a string description of the intersection result.
(clos-defgeneric "intersect" {})
;; point ∩ point: same if coordinates match
(clos-defmethod
"intersect"
(list)
(list "geo-point" "geo-point")
(fn
(args next-fn)
(let
((p1 (first args)) (p2 (first (rest args))))
(if
(and
(= (geo-point-x p1) (geo-point-x p2))
(= (geo-point-y p1) (geo-point-y p2)))
"point"
"empty"))))
;; point ∩ line: check if point lies on line (cross product = 0)
(clos-defmethod
"intersect"
(list)
(list "geo-point" "geo-line")
(fn
(args next-fn)
(let
((pt (first args)) (ln (first (rest args))))
(let
((lp1 (clos-slot-value ln "p1")) (lp2 (clos-slot-value ln "p2")))
(let
((dx (- (geo-point-x lp2) (geo-point-x lp1)))
(dy (- (geo-point-y lp2) (geo-point-y lp1)))
(ex (- (geo-point-x pt) (geo-point-x lp1)))
(ey (- (geo-point-y pt) (geo-point-y lp1))))
(if (= (- (* dx ey) (* dy ex)) 0) "point" "empty"))))))
;; line ∩ line: parallel (same slope = empty) or point
(clos-defmethod
"intersect"
(list)
(list "geo-line" "geo-line")
(fn
(args next-fn)
(let
((l1 (first args)) (l2 (first (rest args))))
(let
((p1 (clos-slot-value l1 "p1"))
(p2 (clos-slot-value l1 "p2"))
(p3 (clos-slot-value l2 "p1"))
(p4 (clos-slot-value l2 "p2")))
(let
((dx1 (- (geo-point-x p2) (geo-point-x p1)))
(dy1 (- (geo-point-y p2) (geo-point-y p1)))
(dx2 (- (geo-point-x p4) (geo-point-x p3)))
(dy2 (- (geo-point-y p4) (geo-point-y p3))))
(let
((cross (- (* dx1 dy2) (* dy1 dx2))))
(if (= cross 0) "parallel" "point")))))))
;; line ∩ plane: general case = point (or parallel if line ⊥ normal)
(clos-defmethod
"intersect"
(list)
(list "geo-line" "geo-plane")
(fn
(args next-fn)
(let
((ln (first args)) (pl (first (rest args))))
(let
((p1 (clos-slot-value ln "p1"))
(p2 (clos-slot-value ln "p2"))
(n (clos-slot-value pl "normal")))
(let
((dx (- (geo-point-x p2) (geo-point-x p1)))
(dy (- (geo-point-y p2) (geo-point-y p1)))
(nx (first n))
(ny (first (rest n))))
(let
((dot (+ (* dx nx) (* dy ny))))
(if (= dot 0) "parallel" "point")))))))
;; ── tests ─────────────────────────────────────────────────────────────────
(define passed 0)
(define failed 0)
(define failures (list))
(define
check
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
;; describe
(check
"describe point"
(clos-call-generic
"geo-describe"
(list (geo-make-point 3 4)))
"P(3,4)")
(check
"describe line"
(clos-call-generic
"geo-describe"
(list
(geo-make-line
(geo-make-point 0 0)
(geo-make-point 1 1))))
"L[P(0,0)-P(1,1)]")
(check
"describe plane"
(clos-call-generic
"geo-describe"
(list (geo-make-plane 0 1 5)))
"Plane(d=5)")
;; intersect point×point
(check
"P∩P same"
(clos-call-generic
"intersect"
(list
(geo-make-point 2 3)
(geo-make-point 2 3)))
"point")
(check
"P∩P diff"
(clos-call-generic
"intersect"
(list
(geo-make-point 1 2)
(geo-make-point 3 4)))
"empty")
;; intersect point×line
(let
((origin (geo-make-point 0 0))
(p10 (geo-make-point 10 0))
(p55 (geo-make-point 5 5))
(l-x
(geo-make-line
(geo-make-point 0 0)
(geo-make-point 10 0))))
(begin
(check
"P∩L on line"
(clos-call-generic "intersect" (list p10 l-x))
"point")
(check
"P∩L on x-axis"
(clos-call-generic "intersect" (list origin l-x))
"point")
(check
"P∩L off line"
(clos-call-generic "intersect" (list p55 l-x))
"empty")))
;; intersect line×line
(let
((horiz (geo-make-line (geo-make-point 0 0) (geo-make-point 10 0)))
(vert
(geo-make-line
(geo-make-point 5 -5)
(geo-make-point 5 5)))
(horiz2
(geo-make-line
(geo-make-point 0 3)
(geo-make-point 10 3))))
(begin
(check
"L∩L crossing"
(clos-call-generic "intersect" (list horiz vert))
"point")
(check
"L∩L parallel"
(clos-call-generic "intersect" (list horiz horiz2))
"parallel")))
;; intersect line×plane
(let
((diag (geo-make-line (geo-make-point 0 0) (geo-make-point 1 1)))
(vert-plane (geo-make-plane 1 0 5))
(diag-plane (geo-make-plane -1 1 0)))
(begin
(check
"L∩Plane cross"
(clos-call-generic "intersect" (list diag vert-plane))
"point")
(check
"L∩Plane parallel"
(clos-call-generic "intersect" (list diag diag-plane))
"parallel")))
;; ── summary ────────────────────────────────────────────────────────────────
(define geo-passed passed)
(define geo-failed failed)
(define geo-failures failures)

196
lib/common-lisp/tests/programs/interactive-debugger.sx
View File

@@ -1,196 +0,0 @@
;; interactive-debugger.sx — Condition debugger using *debugger-hook*
;;
;; Demonstrates the classic CL debugger pattern:
;; - *debugger-hook* is invoked when an unhandled error reaches the top level
;; - The hook receives the condition and a reference to itself
;; - It can offer restarts interactively (here simulated with a policy fn)
;;
;; In real CL the debugger reads from the terminal. Here we simulate
;; the "user input" via a policy function passed in at call time.
;;
;; Depends on: lib/common-lisp/runtime.sx already loaded.
;; ── *debugger-hook* global ────────────────────────────────────────────────
;;
;; CL: when error is unhandled, invoke *debugger-hook* with (condition hook).
;; A nil hook means use the system default (which we simulate as re-raise).
(define cl-debugger-hook nil)
;; ── invoke-debugger ────────────────────────────────────────────────────────
;;
;; Called when cl-error finds no handler. Tries cl-debugger-hook first;
;; falls back to a simple error report.
(define
cl-invoke-debugger
(fn
(c)
(if
(nil? cl-debugger-hook)
(error (str "Debugger: " (cl-condition-message c)))
(begin
(let
((hook cl-debugger-hook))
(set! cl-debugger-hook nil)
(let
((result (hook c hook)))
(set! cl-debugger-hook hook)
result))))))
;; ── cl-error/debugger — error that routes through invoke-debugger ─────────
(define
cl-error-with-debugger
(fn
(c &rest args)
(let
((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
(cl-signal-obj obj cl-handler-stack)
(cl-invoke-debugger obj))))
;; ── simulated debugger session ────────────────────────────────────────────
;;
;; A debugger hook takes (condition hook) and "reads" user commands.
;; We simulate this with a policy function: (fn (c restarts) restart-name)
;; that picks a restart given the condition and available restarts.
(define
make-policy-debugger
(fn
(policy)
(fn
(c hook)
(let
((available (cl-compute-restarts)))
(let
((choice (policy c available)))
(if
(and choice (not (nil? (cl-find-restart choice))))
(cl-invoke-restart choice)
(error
(str
"Debugger: no restart chosen for: "
(cl-condition-message c)))))))))
;; ── tests ─────────────────────────────────────────────────────────────────
(define passed 0)
(define failed 0)
(define failures (list))
(define
check
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
(define
reset-stacks!
(fn
()
(set! cl-handler-stack (list))
(set! cl-restart-stack (list))
(set! cl-debugger-hook nil)))
;; Test 1: debugger hook receives condition
(reset-stacks!)
(let
((received-msg ""))
(begin
(set!
cl-debugger-hook
(fn (c hook) (set! received-msg (cl-condition-message c)) nil))
(cl-restart-case
(fn () (cl-error-with-debugger "something broke"))
(list "abort" (list) (fn () nil)))
(check "debugger hook receives condition" received-msg "something broke")))
;; Test 2: policy-driven restart selection (use-zero)
(reset-stacks!)
(let
((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "use-zero"))) (cl-restart-case (fn () (cl-error-with-debugger (cl-make-condition "division-by-zero")) 999) (list "use-zero" (list) (fn () 0))))))
(check "policy debugger: use-zero restart" result 0))
;; Test 3: policy selects abort
(reset-stacks!)
(let
((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "abort"))) (cl-restart-case (fn () (cl-error-with-debugger "aborting error") 999) (list "abort" (list) (fn () "aborted"))))))
(check "policy debugger: abort restart" result "aborted"))
;; Test 4: compute-restarts inside debugger hook
(reset-stacks!)
(let
((seen-restarts (list)))
(begin
(set!
cl-debugger-hook
(fn
(c hook)
(set! seen-restarts (cl-compute-restarts))
(cl-invoke-restart "continue")))
(cl-restart-case
(fn () (cl-error-with-debugger "test") 42)
(list "continue" (list) (fn () "ok"))
(list "abort" (list) (fn () "no")))
(check
"debugger: compute-restarts visible"
(= (len seen-restarts) 2)
true)))
;; Test 5: hook not invoked when handler catches first
(reset-stacks!)
(let
((hook-called false)
(result
(begin
(set! cl-debugger-hook (fn (c hook) (set! hook-called true) nil))
(cl-handler-case
(fn () (cl-error-with-debugger "handled"))
(list "error" (fn (c) "handler-won"))))))
(check "handler wins; hook not called" hook-called false)
(check "handler result returned" result "handler-won"))
;; Test 6: debugger-hook nil after re-raise guard
(reset-stacks!)
(let
((hook-calls 0))
(begin
(set!
cl-debugger-hook
(fn
(c hook)
(set! hook-calls (+ hook-calls 1))
(if
(> hook-calls 1)
(error "infinite loop guard")
(cl-invoke-restart "escape"))))
(cl-restart-case
(fn () (cl-error-with-debugger "once"))
(list "escape" (list) (fn () nil)))
(check
"hook called exactly once (no infinite recursion)"
hook-calls
1)))
;; ── summary ────────────────────────────────────────────────────────────────
(define debugger-passed passed)
(define debugger-failed failed)
(define debugger-failures failures)

228
lib/common-lisp/tests/programs/mop-trace.sx
View File

@@ -1,228 +0,0 @@
;; mop-trace.sx — :before/:after method tracing with CLOS
;;
;; Classic CLOS pattern: instrument generic functions with :before and :after
;; qualifiers to print call/return traces without modifying the primary method.
;;
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
;; ── trace log (mutable accumulator) ───────────────────────────────────────
(define trace-log (list))
(define
trace-push
(fn (msg) (set! trace-log (append trace-log (list msg)))))
(define trace-clear (fn () (set! trace-log (list))))
;; ── domain classes ─────────────────────────────────────────────────────────
(clos-defclass "shape" (list "t") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"}))
(clos-defclass "circle" (list "shape") (list {:initform 1 :initarg ":radius" :reader nil :writer nil :accessor nil :name "radius"}))
(clos-defclass "rect" (list "shape") (list {:initform 1 :initarg ":width" :reader nil :writer nil :accessor nil :name "width"} {:initform 1 :initarg ":height" :reader nil :writer nil :accessor nil :name "height"}))
;; ── generic function: area ─────────────────────────────────────────────────
(clos-defgeneric "area" {})
;; primary methods
(clos-defmethod
"area"
(list)
(list "circle")
(fn
(args next-fn)
(let
((c (first args)))
(let ((r (clos-slot-value c "radius"))) (* r r)))))
(clos-defmethod
"area"
(list)
(list "rect")
(fn
(args next-fn)
(let
((r (first args)))
(* (clos-slot-value r "width") (clos-slot-value r "height")))))
;; :before tracing
(clos-defmethod
"area"
(list "before")
(list "shape")
(fn
(args next-fn)
(trace-push (str "BEFORE area(" (clos-class-of (first args)) ")"))))
;; :after tracing
(clos-defmethod
"area"
(list "after")
(list "shape")
(fn
(args next-fn)
(trace-push (str "AFTER area(" (clos-class-of (first args)) ")"))))
;; ── generic function: describe-shape ──────────────────────────────────────
(clos-defgeneric "describe-shape" {})
(clos-defmethod
"describe-shape"
(list)
(list "shape")
(fn
(args next-fn)
(let
((s (first args)))
(str "shape[" (clos-slot-value s "color") "]"))))
(clos-defmethod
"describe-shape"
(list)
(list "circle")
(fn
(args next-fn)
(let
((c (first args)))
(str
"circle[r="
(clos-slot-value c "radius")
" "
(clos-call-next-method next-fn)
"]"))))
(clos-defmethod
"describe-shape"
(list)
(list "rect")
(fn
(args next-fn)
(let
((r (first args)))
(str
"rect["
(clos-slot-value r "width")
"x"
(clos-slot-value r "height")
" "
(clos-call-next-method next-fn)
"]"))))
;; :before on base shape (fires for all subclasses too)
(clos-defmethod
"describe-shape"
(list "before")
(list "shape")
(fn
(args next-fn)
(trace-push
(str "BEFORE describe-shape(" (clos-class-of (first args)) ")"))))
;; ── tests ─────────────────────────────────────────────────────────────────
(define passed 0)
(define failed 0)
(define failures (list))
(define
check
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
;; ── area tests ────────────────────────────────────────────────────────────
;; circle area = r*r (no pi — integer arithmetic for predictability)
(let
((c (clos-make-instance "circle" ":radius" 5 ":color" "red")))
(do
(trace-clear)
(check "circle area" (clos-call-generic "area" (list c)) 25)
(check
":before fired for circle"
(= (first trace-log) "BEFORE area(circle)")
true)
(check
":after fired for circle"
(= (first (rest trace-log)) "AFTER area(circle)")
true)
(check "trace length 2" (len trace-log) 2)))
;; rect area = w*h
(let
((r (clos-make-instance "rect" ":width" 4 ":height" 6 ":color" "blue")))
(do
(trace-clear)
(check "rect area" (clos-call-generic "area" (list r)) 24)
(check
":before fired for rect"
(= (first trace-log) "BEFORE area(rect)")
true)
(check
":after fired for rect"
(= (first (rest trace-log)) "AFTER area(rect)")
true)
(check "trace length 2 (rect)" (len trace-log) 2)))
;; ── describe-shape tests ───────────────────────────────────────────────────
(let
((c (clos-make-instance "circle" ":radius" 3 ":color" "green")))
(do
(trace-clear)
(check
"circle describe"
(clos-call-generic "describe-shape" (list c))
"circle[r=3 shape[green]]")
(check
":before fired for describe circle"
(= (first trace-log) "BEFORE describe-shape(circle)")
true)))
(let
((r (clos-make-instance "rect" ":width" 2 ":height" 7 ":color" "black")))
(do
(trace-clear)
(check
"rect describe"
(clos-call-generic "describe-shape" (list r))
"rect[2x7 shape[black]]")
(check
":before fired for describe rect"
(= (first trace-log) "BEFORE describe-shape(rect)")
true)))
;; ── call-next-method: circle -> shape ─────────────────────────────────────
(let
((c (clos-make-instance "circle" ":radius" 1 ":color" "purple")))
(check
"call-next-method result in describe"
(clos-call-generic "describe-shape" (list c))
"circle[r=1 shape[purple]]"))
;; ── summary ────────────────────────────────────────────────────────────────
(define mop-passed passed)
(define mop-failed failed)
(define mop-failures failures)

163
lib/common-lisp/tests/programs/parse-recover.sx
View File

@@ -1,163 +0,0 @@
;; parse-recover.sx — Parser with skipped-token restart
;;
;; Classic CL pattern: a simple token parser that signals a condition
;; when it encounters an unexpected token. The :skip-token restart
;; allows the parser to continue past the offending token.
;;
;; Depends on: lib/common-lisp/runtime.sx already loaded.
;; ── condition type ─────────────────────────────────────────────────────────
(cl-define-condition "parse-error" (list "error") (list "token" "position"))
;; ── simple token parser ────────────────────────────────────────────────────
;;
;; parse-numbers: given a list of tokens (strings), parse integers.
;; Non-integer tokens signal parse-error with two restarts:
;; skip-token — skip the bad token and continue
;; use-zero — use 0 in place of the bad token
(define
parse-numbers
(fn
(tokens)
(define result (list))
(define
process
(fn
(toks)
(if
(empty? toks)
result
(let
((tok (first toks)) (rest-toks (rest toks)))
(let
((n (string->number tok 10)))
(if
n
(begin
(set! result (append result (list n)))
(process rest-toks))
(cl-restart-case
(fn
()
(cl-signal
(cl-make-condition
"parse-error"
"token"
tok
"position"
(len result)))
(set! result (append result (list 0)))
(process rest-toks))
(list "skip-token" (list) (fn () (process rest-toks)))
(list
"use-zero"
(list)
(fn
()
(begin
(set! result (append result (list 0)))
(process rest-toks)))))))))))
(process tokens)
result))
;; ── tests ─────────────────────────────────────────────────────────────────
(define passed 0)
(define failed 0)
(define failures (list))
(define
check
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
(define
reset-stacks!
(fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))
;; All valid tokens
(reset-stacks!)
(check
"all valid: 1 2 3"
(cl-handler-bind
(list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
(fn () (parse-numbers (list "1" "2" "3"))))
(list 1 2 3))
;; Skip bad token
(reset-stacks!)
(check
"skip bad token: 1 x 3 -> (1 3)"
(cl-handler-bind
(list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
(fn () (parse-numbers (list "1" "x" "3"))))
(list 1 3))
;; Use zero for bad token
(reset-stacks!)
(check
"use-zero for bad: 1 x 3 -> (1 0 3)"
(cl-handler-bind
(list (list "parse-error" (fn (c) (cl-invoke-restart "use-zero"))))
(fn () (parse-numbers (list "1" "x" "3"))))
(list 1 0 3))
;; Multiple bad tokens, all skipped
(reset-stacks!)
(check
"skip multiple bad: a 2 b 4 -> (2 4)"
(cl-handler-bind
(list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
(fn () (parse-numbers (list "a" "2" "b" "4"))))
(list 2 4))
;; handler-case: abort on first bad token
(reset-stacks!)
(check
"handler-case: abort on first bad"
(cl-handler-case
(fn () (parse-numbers (list "1" "bad" "3")))
(list
"parse-error"
(fn
(c)
(str
"parse error at position "
(cl-condition-slot c "position")
": "
(cl-condition-slot c "token")))))
"parse error at position 1: bad")
;; Verify condition type hierarchy
(reset-stacks!)
(check
"parse-error isa error"
(cl-condition-of-type?
(cl-make-condition "parse-error" "token" "x" "position" 0)
"error")
true)
;; ── summary ────────────────────────────────────────────────────────────────
(define parse-passed passed)
(define parse-failed failed)
(define parse-failures failures)

141
lib/common-lisp/tests/programs/restart-demo.sx
View File

@@ -1,141 +0,0 @@
;; restart-demo.sx — Classic CL condition system demo
;;
;; Demonstrates resumable exceptions via restarts.
;; The `safe-divide` function signals a division-by-zero condition
;; and offers two restarts:
;; :use-zero — return 0 as the result
;; :retry — call safe-divide again with a corrected divisor
;;
;; Depends on: lib/common-lisp/runtime.sx already loaded.
;; ── safe-divide ────────────────────────────────────────────────────────────
;;
;; Divides numerator by denominator.
;; When denominator is 0, signals division-by-zero with two restarts.
(define
safe-divide
(fn
(n d)
(if
(= d 0)
(cl-restart-case
(fn
()
(cl-signal
(cl-make-condition
"division-by-zero"
"operation"
"/"
"operands"
(list n d)))
(error "division by zero — no restart invoked"))
(list "use-zero" (list) (fn () 0))
(list "retry" (list "d") (fn (d2) (safe-divide n d2))))
(/ n d))))
;; ── tests ─────────────────────────────────────────────────────────────────
(define passed 0)
(define failed 0)
(define failures (list))
(define
check
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
(define
reset-stacks!
(fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))
;; Normal division
(reset-stacks!)
(check "10 / 2 = 5" (safe-divide 10 2) 5)
;; Invoke use-zero restart
(reset-stacks!)
(check
"10 / 0 -> use-zero"
(cl-handler-bind
(list
(list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero"))))
(fn () (safe-divide 10 0)))
0)
;; Invoke retry restart with a corrected denominator
(reset-stacks!)
(check
"10 / 0 -> retry with 2"
(cl-handler-bind
(list
(list
"division-by-zero"
(fn (c) (cl-invoke-restart "retry" 2))))
(fn () (safe-divide 10 0)))
5)
;; Nested calls: outer handles the inner divide-by-zero
(reset-stacks!)
(check
"nested: 20 / (0->4) = 5"
(cl-handler-bind
(list
(list
"division-by-zero"
(fn (c) (cl-invoke-restart "retry" 4))))
(fn () (let ((r1 (safe-divide 20 0))) r1)))
5)
;; handler-case — unwinding version
(reset-stacks!)
(check
"handler-case: catches division-by-zero"
(cl-handler-case
(fn () (safe-divide 9 0))
(list "division-by-zero" (fn (c) "caught!")))
"caught!")
;; Verify use-zero is idempotent (two uses)
(reset-stacks!)
(check
"two use-zero invocations"
(cl-handler-bind
(list
(list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero"))))
(fn
()
(+
(safe-divide 10 0)
(safe-divide 3 0))))
0)
;; No restart needed for normal division
(reset-stacks!)
(check
"no restart needed for 8/4"
(safe-divide 8 4)
2)
;; ── summary ────────────────────────────────────────────────────────────────
(define demo-passed passed)
(define demo-failed failed)
(define demo-failures failures)

180
lib/common-lisp/tests/read.sx
View File

@@ -1,180 +0,0 @@
;; Common Lisp tokenizer tests
(define cl-test-pass 0)
(define cl-test-fail 0)
(define cl-test-fails (list))
(define
cl-test
(fn
(name actual expected)
(if
(= actual expected)
(set! cl-test-pass (+ cl-test-pass 1))
(do
(set! cl-test-fail (+ cl-test-fail 1))
(append! cl-test-fails {:name name :expected expected :actual actual})))))
;; Helpers: extract types and values from token stream (drops eof)
(define
cl-tok-types
(fn
(src)
(map
(fn (t) (get t "type"))
(filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src)))))
(define
cl-tok-values
(fn
(src)
(map
(fn (t) (get t "value"))
(filter (fn (t) (not (= (get t "type") "eof"))) (cl-tokenize src)))))
(define
cl-tok-first
(fn (src) (nth (cl-tokenize src) 0)))
;; ── symbols ───────────────────────────────────────────────────────
(cl-test "symbol: bare lowercase" (cl-tok-values "foo") (list "FOO"))
(cl-test "symbol: uppercase" (cl-tok-values "BAR") (list "BAR"))
(cl-test "symbol: mixed case folded" (cl-tok-values "FooBar") (list "FOOBAR"))
(cl-test "symbol: with hyphen" (cl-tok-values "foo-bar") (list "FOO-BAR"))
(cl-test "symbol: with star" (cl-tok-values "*special*") (list "*SPECIAL*"))
(cl-test "symbol: with question" (cl-tok-values "null?") (list "NULL?"))
(cl-test "symbol: with exclamation" (cl-tok-values "set!") (list "SET!"))
(cl-test "symbol: plus sign alone" (cl-tok-values "+") (list "+"))
(cl-test "symbol: minus sign alone" (cl-tok-values "-") (list "-"))
(cl-test "symbol: type is symbol" (cl-tok-types "foo") (list "symbol"))
;; ── package-qualified symbols ─────────────────────────────────────
(cl-test "symbol: pkg:sym external" (cl-tok-values "cl:car") (list "CL:CAR"))
(cl-test "symbol: pkg::sym internal" (cl-tok-values "pkg::foo") (list "PKG::FOO"))
(cl-test "symbol: cl:car type" (cl-tok-types "cl:car") (list "symbol"))
;; ── keywords ──────────────────────────────────────────────────────
(cl-test "keyword: basic" (cl-tok-values ":foo") (list "FOO"))
(cl-test "keyword: type" (cl-tok-types ":foo") (list "keyword"))
(cl-test "keyword: upcase" (cl-tok-values ":hello-world") (list "HELLO-WORLD"))
(cl-test "keyword: multiple" (cl-tok-types ":a :b :c") (list "keyword" "keyword" "keyword"))
;; ── integers ──────────────────────────────────────────────────────
(cl-test "integer: zero" (cl-tok-values "0") (list "0"))
(cl-test "integer: positive" (cl-tok-values "42") (list "42"))
(cl-test "integer: negative" (cl-tok-values "-5") (list "-5"))
(cl-test "integer: positive-sign" (cl-tok-values "+3") (list "+3"))
(cl-test "integer: type" (cl-tok-types "42") (list "integer"))
(cl-test "integer: multi-digit" (cl-tok-values "12345678") (list "12345678"))
;; ── hex, binary, octal ───────────────────────────────────────────
(cl-test "hex: lowercase x" (cl-tok-values "#xFF") (list "#xFF"))
(cl-test "hex: uppercase X" (cl-tok-values "#XFF") (list "#XFF"))
(cl-test "hex: type" (cl-tok-types "#xFF") (list "integer"))
(cl-test "hex: zero" (cl-tok-values "#x0") (list "#x0"))
(cl-test "binary: #b" (cl-tok-values "#b1010") (list "#b1010"))
(cl-test "binary: type" (cl-tok-types "#b1010") (list "integer"))
(cl-test "octal: #o" (cl-tok-values "#o17") (list "#o17"))
(cl-test "octal: type" (cl-tok-types "#o17") (list "integer"))
;; ── floats ────────────────────────────────────────────────────────
(cl-test "float: basic" (cl-tok-values "3.14") (list "3.14"))
(cl-test "float: type" (cl-tok-types "3.14") (list "float"))
(cl-test "float: negative" (cl-tok-values "-2.5") (list "-2.5"))
(cl-test "float: exponent" (cl-tok-values "1.0e10") (list "1.0e10"))
(cl-test "float: neg exponent" (cl-tok-values "1.5e-3") (list "1.5e-3"))
(cl-test "float: leading dot" (cl-tok-values ".5") (list "0.5"))
(cl-test "float: exp only" (cl-tok-values "1e5") (list "1e5"))
;; ── ratios ────────────────────────────────────────────────────────
(cl-test "ratio: 1/3" (cl-tok-values "1/3") (list "1/3"))
(cl-test "ratio: type" (cl-tok-types "1/3") (list "ratio"))
(cl-test "ratio: 22/7" (cl-tok-values "22/7") (list "22/7"))
(cl-test "ratio: negative" (cl-tok-values "-1/2") (list "-1/2"))
;; ── strings ───────────────────────────────────────────────────────
(cl-test "string: empty" (cl-tok-values "\"\"") (list ""))
(cl-test "string: basic" (cl-tok-values "\"hello\"") (list "hello"))
(cl-test "string: type" (cl-tok-types "\"hello\"") (list "string"))
(cl-test "string: with space" (cl-tok-values "\"hello world\"") (list "hello world"))
(cl-test "string: escaped quote" (cl-tok-values "\"say \\\"hi\\\"\"") (list "say \"hi\""))
(cl-test "string: escaped backslash" (cl-tok-values "\"a\\\\b\"") (list "a\\b"))
(cl-test "string: newline escape" (cl-tok-values "\"a\\nb\"") (list "a\nb"))
(cl-test "string: tab escape" (cl-tok-values "\"a\\tb\"") (list "a\tb"))
;; ── characters ────────────────────────────────────────────────────
(cl-test "char: lowercase a" (cl-tok-values "#\\a") (list "a"))
(cl-test "char: uppercase A" (cl-tok-values "#\\A") (list "A"))
(cl-test "char: digit" (cl-tok-values "#\\1") (list "1"))
(cl-test "char: type" (cl-tok-types "#\\a") (list "char"))
(cl-test "char: Space" (cl-tok-values "#\\Space") (list " "))
(cl-test "char: Newline" (cl-tok-values "#\\Newline") (list "\n"))
(cl-test "char: Tab" (cl-tok-values "#\\Tab") (list "\t"))
(cl-test "char: Return" (cl-tok-values "#\\Return") (list "\r"))
;; ── reader macros ─────────────────────────────────────────────────
(cl-test "quote: type" (cl-tok-types "'x") (list "quote" "symbol"))
(cl-test "backquote: type" (cl-tok-types "`x") (list "backquote" "symbol"))
(cl-test "comma: type" (cl-tok-types ",x") (list "comma" "symbol"))
(cl-test "comma-at: type" (cl-tok-types ",@x") (list "comma-at" "symbol"))
(cl-test "hash-quote: type" (cl-tok-types "#'foo") (list "hash-quote" "symbol"))
(cl-test "hash-paren: type" (cl-tok-types "#(1 2)") (list "hash-paren" "integer" "integer" "rparen"))
;; ── uninterned ────────────────────────────────────────────────────
(cl-test "uninterned: type" (cl-tok-types "#:foo") (list "uninterned"))
(cl-test "uninterned: value upcase" (cl-tok-values "#:foo") (list "FOO"))
(cl-test "uninterned: compound" (cl-tok-values "#:my-sym") (list "MY-SYM"))
;; ── parens and structure ──────────────────────────────────────────
(cl-test "paren: empty list" (cl-tok-types "()") (list "lparen" "rparen"))
(cl-test "paren: nested" (cl-tok-types "((a))") (list "lparen" "lparen" "symbol" "rparen" "rparen"))
(cl-test "dot: standalone" (cl-tok-types "(a . b)") (list "lparen" "symbol" "dot" "symbol" "rparen"))
;; ── comments ──────────────────────────────────────────────────────
(cl-test "comment: line" (cl-tok-types "; comment\nfoo") (list "symbol"))
(cl-test "comment: inline" (cl-tok-values "foo ; bar\nbaz") (list "FOO" "BAZ"))
(cl-test "block-comment: basic" (cl-tok-types "#| hello |# foo") (list "symbol"))
(cl-test "block-comment: nested" (cl-tok-types "#| a #| b |# c |# x") (list "symbol"))
;; ── combined ──────────────────────────────────────────────────────
(cl-test
"combined: defun skeleton"
(cl-tok-types "(defun foo (x) x)")
(list "lparen" "symbol" "symbol" "lparen" "symbol" "rparen" "symbol" "rparen"))
(cl-test
"combined: let form"
(cl-tok-types "(let ((x 1)) x)")
(list
"lparen"
"symbol"
"lparen"
"lparen"
"symbol"
"integer"
"rparen"
"rparen"
"symbol"
"rparen"))
(cl-test
"combined: whitespace skip"
(cl-tok-values " foo bar baz ")
(list "FOO" "BAR" "BAZ"))
(cl-test "eof: present" (get (nth (cl-tokenize "") 0) "type") "eof")
(cl-test "eof: at end of tokens" (get (nth (cl-tokenize "x") 1) "type") "eof")

207
lib/common-lisp/tests/runtime.sx
View File

@@ -1,207 +0,0 @@
;; lib/common-lisp/tests/runtime.sx — tests for CL runtime layer
(load "lib/common-lisp/runtime.sx")
(defsuite
"cl-types"
(deftest "cl-null? nil" (assert= true (cl-null? nil)))
(deftest "cl-null? false" (assert= false (cl-null? false)))
(deftest
"cl-consp? pair"
(assert= true (cl-consp? (list 1 2))))
(deftest "cl-consp? nil" (assert= false (cl-consp? nil)))
(deftest "cl-listp? nil" (assert= true (cl-listp? nil)))
(deftest
"cl-listp? list"
(assert= true (cl-listp? (list 1 2))))
(deftest "cl-atom? nil" (assert= true (cl-atom? nil)))
(deftest "cl-atom? pair" (assert= false (cl-atom? (list 1))))
(deftest "cl-integerp?" (assert= true (cl-integerp? 42)))
(deftest "cl-floatp?" (assert= true (cl-floatp? 3.14)))
(deftest
"cl-characterp?"
(assert= true (cl-characterp? (integer->char 65))))
(deftest "cl-stringp?" (assert= true (cl-stringp? "hello")))
(deftest "cl-symbolp?" (assert= true (cl-symbolp? (quote foo)))))
(defsuite
"cl-arithmetic"
(deftest "cl-mod" (assert= 1 (cl-mod 10 3)))
(deftest "cl-rem" (assert= 1 (cl-rem 10 3)))
(deftest
"cl-quotient"
(assert= 3 (cl-quotient 10 3)))
(deftest "cl-gcd" (assert= 4 (cl-gcd 12 8)))
(deftest "cl-lcm" (assert= 12 (cl-lcm 4 6)))
(deftest "cl-abs pos" (assert= 5 (cl-abs 5)))
(deftest "cl-abs neg" (assert= 5 (cl-abs -5)))
(deftest "cl-min" (assert= 2 (cl-min 2 7)))
(deftest "cl-max" (assert= 7 (cl-max 2 7)))
(deftest "cl-evenp? t" (assert= true (cl-evenp? 4)))
(deftest "cl-evenp? f" (assert= false (cl-evenp? 3)))
(deftest "cl-oddp? t" (assert= true (cl-oddp? 7)))
(deftest "cl-zerop?" (assert= true (cl-zerop? 0)))
(deftest "cl-plusp?" (assert= true (cl-plusp? 1)))
(deftest "cl-minusp?" (assert= true (cl-minusp? -1)))
(deftest "cl-signum pos" (assert= 1 (cl-signum 42)))
(deftest "cl-signum neg" (assert= -1 (cl-signum -7)))
(deftest "cl-signum zero" (assert= 0 (cl-signum 0))))
(defsuite
"cl-chars"
(deftest
"cl-char-code"
(assert= 65 (cl-char-code (integer->char 65))))
(deftest "cl-code-char" (assert= true (char? (cl-code-char 65))))
(deftest
"cl-char-upcase"
(assert=
(integer->char 65)
(cl-char-upcase (integer->char 97))))
(deftest
"cl-char-downcase"
(assert=
(integer->char 97)
(cl-char-downcase (integer->char 65))))
(deftest
"cl-alpha-char-p"
(assert= true (cl-alpha-char-p (integer->char 65))))
(deftest
"cl-digit-char-p"
(assert= true (cl-digit-char-p (integer->char 48))))
(deftest
"cl-char=?"
(assert=
true
(cl-char=? (integer->char 65) (integer->char 65))))
(deftest
"cl-char<?"
(assert=
true
(cl-char<? (integer->char 65) (integer->char 90))))
(deftest
"cl-char space"
(assert= (integer->char 32) cl-char-space))
(deftest
"cl-char newline"
(assert= (integer->char 10) cl-char-newline)))
(defsuite
"cl-format"
(deftest
"cl-format nil basic"
(assert= "hello" (cl-format nil "~a" "hello")))
(deftest
"cl-format nil number"
(assert= "42" (cl-format nil "~d" 42)))
(deftest
"cl-format nil hex"
(assert= "ff" (cl-format nil "~x" 255)))
(deftest
"cl-format nil template"
(assert= "x=3 y=4" (cl-format nil "x=~d y=~d" 3 4)))
(deftest "cl-format nil tilde" (assert= "a~b" (cl-format nil "a~~b"))))
(defsuite
"cl-gensym"
(deftest
"cl-gensym returns symbol"
(assert= "symbol" (type-of (cl-gensym))))
(deftest "cl-gensym unique" (assert= false (= (cl-gensym) (cl-gensym)))))
(defsuite
"cl-sets"
(deftest "cl-make-set empty" (assert= true (cl-set? (cl-make-set))))
(deftest
"cl-set-add/member"
(let
((s (cl-make-set)))
(do
(cl-set-add s 1)
(assert= true (cl-set-memberp s 1)))))
(deftest
"cl-set-memberp false"
(assert= false (cl-set-memberp (cl-make-set) 42)))
(deftest
"cl-list->set"
(let
((s (cl-list->set (list 1 2 3))))
(assert= true (cl-set-memberp s 2)))))
(defsuite
"cl-lists"
(deftest
"cl-nth 0"
(assert=
1
(cl-nth 0 (list 1 2 3))))
(deftest
"cl-nth 2"
(assert=
3
(cl-nth 2 (list 1 2 3))))
(deftest
"cl-last"
(assert=
(list 3)
(cl-last (list 1 2 3))))
(deftest
"cl-butlast"
(assert=
(list 1 2)
(cl-butlast (list 1 2 3))))
(deftest
"cl-nthcdr 1"
(assert=
(list 2 3)
(cl-nthcdr 1 (list 1 2 3))))
(deftest
"cl-assoc hit"
(assert=
(list "b" 2)
(cl-assoc "b" (list (list "a" 1) (list "b" 2)))))
(deftest
"cl-assoc miss"
(assert= nil (cl-assoc "z" (list (list "a" 1)))))
(deftest
"cl-getf hit"
(assert= 42 (cl-getf (list "x" 42 "y" 99) "x")))
(deftest "cl-getf miss" (assert= nil (cl-getf (list "x" 42) "z")))
(deftest
"cl-adjoin new"
(assert=
(list 0 1 2)
(cl-adjoin 0 (list 1 2))))
(deftest
"cl-adjoin dup"
(assert=
(list 1 2)
(cl-adjoin 1 (list 1 2))))
(deftest
"cl-flatten"
(assert=
(list 1 2 3 4)
(cl-flatten (list 1 (list 2 3) 4))))
(deftest
"cl-member hit"
(assert=
(list 2 3)
(cl-member 2 (list 1 2 3))))
(deftest
"cl-member miss"
(assert=
nil
(cl-member 9 (list 1 2 3)))))
(defsuite
"cl-radix"
(deftest "binary" (assert= "1010" (cl-format-binary 10)))
(deftest "octal" (assert= "17" (cl-format-octal 15)))
(deftest "hex" (assert= "ff" (cl-format-hex 255)))
(deftest "decimal" (assert= "42" (cl-format-decimal 42)))
(deftest
"n->s r16"
(assert= "1f" (cl-integer-to-string 31 16)))
(deftest
"s->n r16"
(assert= 31 (cl-string-to-integer "1f" 16))))

285
lib/common-lisp/tests/stdlib.sx
View File

@@ -1,285 +0,0 @@
;; lib/common-lisp/tests/stdlib.sx — Phase 6: sequence, list, string functions
(define ev (fn (src) (cl-eval-str src (cl-make-env))))
(define passed 0)
(define failed 0)
(define failures (list))
(define
check
(fn
(label got expected)
(if
(= got expected)
(set! passed (+ passed 1))
(begin
(set! failed (+ failed 1))
(set!
failures
(append
failures
(list
(str
"FAIL ["
label
"]: got="
(inspect got)
" expected="
(inspect expected)))))))))
;; ── mapc ─────────────────────────────────────────────────────────
(check "mapc returns list"
(ev "(mapc #'1+ '(1 2 3))")
(list 1 2 3))
;; ── mapcan ───────────────────────────────────────────────────────
(check "mapcan basic"
(ev "(mapcan (lambda (x) (list x (* x x))) '(1 2 3))")
(list 1 1 2 4 3 9))
(check "mapcan filter-like"
(ev "(mapcan (lambda (x) (if (evenp x) (list x) nil)) '(1 2 3 4 5 6))")
(list 2 4 6))
;; ── reduce ───────────────────────────────────────────────────────
(check "reduce sum"
(ev "(reduce #'+ '(1 2 3 4 5))")
15)
(check "reduce with initial-value"
(ev "(reduce #'+ '(1 2 3) :initial-value 10)")
16)
(check "reduce max"
(ev "(reduce (lambda (a b) (if (> a b) a b)) '(3 1 4 1 5 9 2 6))")
9)
;; ── find ─────────────────────────────────────────────────────────
(check "find present"
(ev "(find 3 '(1 2 3 4 5))")
3)
(check "find absent"
(ev "(find 9 '(1 2 3))")
nil)
(check "find-if present"
(ev "(find-if #'evenp '(1 3 4 7))")
4)
(check "find-if absent"
(ev "(find-if #'evenp '(1 3 5))")
nil)
(check "find-if-not"
(ev "(find-if-not #'evenp '(2 4 5 6))")
5)
;; ── position ─────────────────────────────────────────────────────
(check "position found"
(ev "(position 3 '(1 2 3 4 5))")
2)
(check "position not found"
(ev "(position 9 '(1 2 3))")
nil)
(check "position-if"
(ev "(position-if #'evenp '(1 3 4 8))")
2)
;; ── count ────────────────────────────────────────────────────────
(check "count"
(ev "(count 2 '(1 2 3 2 4 2))")
3)
(check "count-if"
(ev "(count-if #'evenp '(1 2 3 4 5 6))")
3)
;; ── every / some / notany / notevery ─────────────────────────────
(check "every true"
(ev "(every #'evenp '(2 4 6))")
true)
(check "every false"
(ev "(every #'evenp '(2 3 6))")
nil)
(check "every empty"
(ev "(every #'evenp '())")
true)
(check "some truthy"
(ev "(some #'evenp '(1 3 4))")
true)
(check "some nil"
(ev "(some #'evenp '(1 3 5))")
nil)
(check "notany true"
(ev "(notany #'evenp '(1 3 5))")
true)
(check "notany false"
(ev "(notany #'evenp '(1 2 5))")
nil)
(check "notevery false"
(ev "(notevery #'evenp '(2 4 6))")
nil)
(check "notevery true"
(ev "(notevery #'evenp '(2 3 6))")
true)
;; ── remove ───────────────────────────────────────────────────────
(check "remove"
(ev "(remove 3 '(1 2 3 4 3 5))")
(list 1 2 4 5))
(check "remove-if"
(ev "(remove-if #'evenp '(1 2 3 4 5 6))")
(list 1 3 5))
(check "remove-if-not"
(ev "(remove-if-not #'evenp '(1 2 3 4 5 6))")
(list 2 4 6))
;; ── member ───────────────────────────────────────────────────────
(check "member found"
(ev "(member 3 '(1 2 3 4 5))")
(list 3 4 5))
(check "member not found"
(ev "(member 9 '(1 2 3))")
nil)
;; ── subst ────────────────────────────────────────────────────────
(check "subst flat"
(ev "(subst 'b 'a '(a b c a))")
(list "B" "B" "C" "B"))
(check "subst nested"
(ev "(subst 99 1 '(1 (2 1) 3))")
(list 99 (list 2 99) 3))
;; ── assoc ────────────────────────────────────────────────────────
(check "assoc found"
(ev "(assoc 'b '((a 1) (b 2) (c 3)))")
(list "B" 2))
(check "assoc not found"
(ev "(assoc 'z '((a 1) (b 2)))")
nil)
;; ── list ops ─────────────────────────────────────────────────────
(check "last"
(ev "(last '(1 2 3 4))")
(list 4))
(check "butlast"
(ev "(butlast '(1 2 3 4))")
(list 1 2 3))
(check "nthcdr"
(ev "(nthcdr 2 '(a b c d))")
(list "C" "D"))
(check "list*"
(ev "(list* 1 2 '(3 4))")
(list 1 2 3 4))
(check "cadr"
(ev "(cadr '(1 2 3))")
2)
(check "caddr"
(ev "(caddr '(1 2 3))")
3)
(check "cadddr"
(ev "(cadddr '(1 2 3 4))")
4)
(check "cddr"
(ev "(cddr '(1 2 3 4))")
(list 3 4))
;; ── subseq ───────────────────────────────────────────────────────
(check "subseq string"
(ev "(subseq \"hello\" 1 3)")
"el")
(check "subseq list"
(ev "(subseq '(a b c d) 1 3)")
(list "B" "C"))
(check "subseq no end"
(ev "(subseq \"hello\" 2)")
"llo")
;; ── FORMAT ─────────────────────────────────────────────────────────
(check "format ~A"
(ev "(format nil \"hello ~A\" \"world\")")
"hello world")
(check "format ~D"
(ev "(format nil \"~D items\" 42)")
"42 items")
(check "format two args"
(ev "(format nil \"~A ~A\" 1 2)")
"1 2")
(check "format ~A+~A=~A"
(ev "(format nil \"~A + ~A = ~A\" 1 2 3)")
"1 + 2 = 3")
(check "format iterate"
(ev "(format nil \"~{~A~}\" (quote (1 2 3)))")
"123")
(check "format iterate with space"
(ev "(format nil \"(~{~A ~})\" (quote (1 2 3)))")
"(1 2 3 )")
;; ── packages ─────────────────────────────────────────────────────
(check "defpackage returns name"
(ev "(defpackage :my-pkg (:use :cl))")
"MY-PKG")
(check "in-package"
(ev "(progn (defpackage :test-pkg) (in-package :test-pkg) (package-name))")
"TEST-PKG")
(check "package-qualified function"
(ev "(cl:car (quote (1 2 3)))")
1)
(check "package-qualified function 2"
(ev "(cl:mapcar (function evenp) (quote (2 3 4)))")
(list true nil true))
;; ── summary ──────────────────────────────────────────────────────
(define stdlib-passed passed)
(define stdlib-failed failed)
(define stdlib-failures failures)

24
lib/compiler.sx
View File

@@ -1008,27 +1008,11 @@
(let
((name (symbol-name head))
(argc (len args))
(specialized-op (cond
(and (= argc 2) (= name "+")) 160
(and (= argc 2) (= name "-")) 161
(and (= argc 2) (= name "*")) 162
(and (= argc 2) (= name "/")) 163
(and (= argc 2) (= name "=")) 164
(and (= argc 2) (= name "<")) 165
(and (= argc 2) (= name ">")) 166
(and (= argc 2) (= name "cons")) 172
(and (= argc 1) (= name "not")) 167
(and (= argc 1) (= name "len")) 168
(and (= argc 1) (= name "first")) 169
(and (= argc 1) (= name "rest")) 170
:else nil)))
(name-idx (pool-add (get em "pool") name)))
(for-each (fn (a) (compile-expr em a scope false)) args)
(if specialized-op
(emit-op em specialized-op)
(let ((name-idx (pool-add (get em "pool") name)))
(emit-op em 52)
(emit-u16 em name-idx)
(emit-byte em argc))))
(emit-op em 52)
(emit-u16 em name-idx)
(emit-byte em argc))
(do
(compile-expr em head scope false)
(for-each (fn (a) (compile-expr em a scope false)) args)

157
lib/datalog/aggregates.sx
View File

@@ -1,157 +0,0 @@
;; lib/datalog/aggregates.sx — count / sum / min / max / findall.
;;
;; Surface form (always 3-arg after the relation name):
;;
;; (count Result Var GoalLit)
;; (sum Result Var GoalLit)
;; (min Result Var GoalLit)
;; (max Result Var GoalLit)
;; (findall List Var GoalLit)
;;
;; Parsed naturally because arg-position compounds are already allowed
;; (Phase 4 needs them for arithmetic). At evaluation time the aggregator
;; runs `dl-find-bindings` on `GoalLit` under the current subst, collects
;; the distinct values of `Var`, and binds `Result`.
;;
;; Aggregation is non-monotonic — `count(C, X, p(X))` shrinks as p loses
;; tuples. The stratifier (lib/datalog/strata.sx) treats every aggregate's
;; goal relation as a negation-like edge so the inner relation is fully
;; derived before the aggregate fires.
;;
;; Empty input: count → 0, sum → 0, min/max → no binding (rule fails).
(define dl-aggregate-rels (list "count" "sum" "min" "max" "findall"))
(define
dl-aggregate?
(fn
(lit)
(and
(list? lit)
(>= (len lit) 4)
(let ((rel (dl-rel-name lit)))
(cond
((nil? rel) false)
(else (dl-member-string? rel dl-aggregate-rels)))))))
;; Apply aggregation operator to a list of (already-distinct) numeric or
;; symbolic values. Returns the aggregated value, or :empty if min/max
;; has no input.
(define
dl-do-aggregate
(fn
(op vals)
(cond
((= op "count") (len vals))
((= op "sum") (dl-sum-vals vals 0))
((= op "findall") vals)
((= op "min")
(cond
((= (len vals) 0) :empty)
(else (dl-min-vals vals 1 (first vals)))))
((= op "max")
(cond
((= (len vals) 0) :empty)
(else (dl-max-vals vals 1 (first vals)))))
(else (error (str "datalog: unknown aggregate " op))))))
(define
dl-sum-vals
(fn
(vals acc)
(cond
((= (len vals) 0) acc)
(else (dl-sum-vals (rest vals) (+ acc (first vals)))))))
(define
dl-min-vals
(fn
(vals i cur)
(cond
((>= i (len vals)) cur)
(else
(let ((v (nth vals i)))
(dl-min-vals vals (+ i 1) (if (< v cur) v cur)))))))
(define
dl-max-vals
(fn
(vals i cur)
(cond
((>= i (len vals)) cur)
(else
(let ((v (nth vals i)))
(dl-max-vals vals (+ i 1) (if (> v cur) v cur)))))))
;; Membership check by deep equality (so 30 == 30.0 etc).
(define
dl-val-member?
(fn
(v xs)
(cond
((= (len xs) 0) false)
((dl-tuple-equal? v (first xs)) true)
(else (dl-val-member? v (rest xs))))))
;; Evaluate an aggregate body lit under `subst`. Returns the list of
;; extended substitutions (0 or 1 element).
(define
dl-eval-aggregate
(fn
(lit db subst)
(let
((op (dl-rel-name lit))
(result-var (nth lit 1))
(agg-var (nth lit 2))
(goal (nth lit 3)))
(cond
((not (dl-var? agg-var))
(error (str "datalog aggregate (" op
"): second arg must be a variable, got " agg-var)))
((not (and (list? goal) (> (len goal) 0)
(symbol? (first goal))))
(error (str "datalog aggregate (" op
"): third arg must be a positive literal, got "
goal)))
((not (dl-member-string?
(symbol->string agg-var)
(dl-vars-of goal)))
(error (str "datalog aggregate (" op
"): aggregation variable " agg-var
" does not appear in the goal " goal
" — without it every match contributes the same "
"(unbound) value and the result is meaningless")))
(else
(let ((vals (list)))
(do
(for-each
(fn
(s)
(let ((v (dl-apply-subst agg-var s)))
(when (not (dl-val-member? v vals))
(append! vals v))))
(dl-find-bindings (list goal) db subst))
(let ((agg-val (dl-do-aggregate op vals)))
(cond
((= agg-val :empty) (list))
(else
(let ((s2 (dl-unify result-var agg-val subst)))
(if (nil? s2) (list) (list s2)))))))))))))
;; Stratification edges from aggregates: like negation, the goal's
;; relation must be in a strictly lower stratum so that the aggregate
;; fires only after the underlying tuples are settled.
(define
dl-aggregate-dep-edge
(fn
(lit)
(cond
((dl-aggregate? lit)
(let ((goal (nth lit 3)))
(cond
((and (list? goal) (> (len goal) 0))
(let ((rel (dl-rel-name goal)))
(if (nil? rel) nil {:rel rel :neg true})))
(else nil))))
(else nil))))

303
lib/datalog/api.sx
View File

@@ -1,303 +0,0 @@
;; lib/datalog/api.sx — SX-data embedding API.
;;
;; Where Phase 1's `dl-program` takes a Datalog source string,
;; this module exposes a parser-free API that consumes SX data
;; directly. Two rule shapes are accepted:
;;
;; - dict: {:head <literal> :body (<literal> ...)}
;; - list: (<head-elements...> <- <body-literal> ...)
;; — `<-` is an SX symbol used as the rule arrow.
;;
;; Examples:
;;
;; (dl-program-data
;; '((parent tom bob) (parent tom liz) (parent bob ann))
;; '((ancestor X Y <- (parent X Y))
;; (ancestor X Z <- (parent X Y) (ancestor Y Z))))
;;
;; (dl-query db '(ancestor tom X)) ; same query API as before
;;
;; Variables follow the parser convention: SX symbols whose first
;; character is uppercase or `_` are variables.
(define
dl-rule
(fn (head body) {:head head :body body}))
(define
dl-rule-arrow?
(fn
(x)
(and (symbol? x) (= (symbol->string x) "<-"))))
(define
dl-find-arrow
(fn
(rl i n)
(cond
((>= i n) nil)
((dl-rule-arrow? (nth rl i)) i)
(else (dl-find-arrow rl (+ i 1) n)))))
;; Given a list of the form (head-elt ... <- body-lit ...) returns
;; {:head (head-elt ...) :body (body-lit ...)}. If no arrow is
;; present, the whole list is treated as the head and the body is
;; empty (i.e. a fact written rule-style).
(define
dl-rule-from-list
(fn
(rl)
(let ((n (len rl)))
(let ((idx (dl-find-arrow rl 0 n)))
(cond
((nil? idx) {:head rl :body (list)})
(else
(let
((head (slice rl 0 idx))
(body (slice rl (+ idx 1) n)))
{:head head :body body})))))))
;; Coerce a rule given as either a dict or a list-with-arrow to a dict.
(define
dl-coerce-rule
(fn
(r)
(cond
((dict? r) r)
((list? r) (dl-rule-from-list r))
(else (error (str "dl-coerce-rule: expected dict or list, got " r))))))
;; Build a db from SX data lists.
(define
dl-program-data
(fn
(facts rules)
(let ((db (dl-make-db)))
(do
(for-each (fn (lit) (dl-add-fact! db lit)) facts)
(for-each
(fn (r) (dl-add-rule! db (dl-coerce-rule r)))
rules)
db))))
;; Add a single fact at runtime, then re-saturate the db so derived
;; tuples reflect the change. Returns the db.
(define
dl-assert!
(fn
(db lit)
(do
(dl-add-fact! db lit)
(dl-saturate! db)
db)))
;; Remove a fact and re-saturate. Mixed relations (which have BOTH
;; user-asserted facts AND rules) are supported via :edb-keys provenance
;; — explicit facts are marked at dl-add-fact! time, the saturator uses
;; dl-add-derived! which doesn't mark them, so the retract pass can
;; safely wipe IDB-derived tuples while preserving the user's EDB.
;;
;; Effect:
;; - remove tuples matching `lit` from :facts and :edb-keys
;; - for every relation that has a rule (i.e. potentially IDB or
;; mixed), drop the IDB-derived portion (anything not in :edb-keys)
;; so the saturator can re-derive cleanly
;; - re-saturate
(define
dl-retract!
(fn
(db lit)
(let
((rel-key (dl-rel-name lit)))
(do
;; Drop the matching tuple from its relation list, its facts-keys,
;; its first-arg index, AND from :edb-keys (if present).
(when
(has-key? (get db :facts) rel-key)
(let
((existing (get (get db :facts) rel-key))
(kept (list))
(kept-keys {})
(kept-index {})
(edb-rel (cond
((has-key? (get db :edb-keys) rel-key)
(get (get db :edb-keys) rel-key))
(else nil)))
(kept-edb {}))
(do
(for-each
(fn
(t)
(when
(not (dl-tuple-equal? t lit))
(do
(append! kept t)
(let ((tk (dl-tuple-key t)))
(do
(dict-set! kept-keys tk true)
(when
(and (not (nil? edb-rel))
(has-key? edb-rel tk))
(dict-set! kept-edb tk true))))
(when
(>= (len t) 2)
(let ((k (dl-arg-key (nth t 1))))
(do
(when
(not (has-key? kept-index k))
(dict-set! kept-index k (list)))
(append! (get kept-index k) t)))))))
existing)
(dict-set! (get db :facts) rel-key kept)
(dict-set! (get db :facts-keys) rel-key kept-keys)
(dict-set! (get db :facts-index) rel-key kept-index)
(when
(not (nil? edb-rel))
(dict-set! (get db :edb-keys) rel-key kept-edb)))))
;; For each rule-head relation, strip the IDB-derived tuples
;; (anything not marked in :edb-keys) so the saturator can
;; cleanly re-derive without leaving stale tuples that depended
;; on the now-removed fact.
(let ((rule-heads (dl-rule-head-rels db)))
(for-each
(fn
(k)
(when
(has-key? (get db :facts) k)
(let
((existing (get (get db :facts) k))
(kept (list))
(kept-keys {})
(kept-index {})
(edb-rel (cond
((has-key? (get db :edb-keys) k)
(get (get db :edb-keys) k))
(else {}))))
(do
(for-each
(fn
(t)
(let ((tk (dl-tuple-key t)))
(when
(has-key? edb-rel tk)
(do
(append! kept t)
(dict-set! kept-keys tk true)
(when
(>= (len t) 2)
(let ((kk (dl-arg-key (nth t 1))))
(do
(when
(not (has-key? kept-index kk))
(dict-set! kept-index kk (list)))
(append! (get kept-index kk) t))))))))
existing)
(dict-set! (get db :facts) k kept)
(dict-set! (get db :facts-keys) k kept-keys)
(dict-set! (get db :facts-index) k kept-index)))))
rule-heads))
(dl-saturate! db)
db))))
;; ── Convenience: single-call source + query ───────────────────
;; (dl-eval source query-source) parses both, builds a db, saturates,
;; runs the query, returns the substitution list. The query source
;; should be `?- goal[, goal ...].` — the parser produces a clause
;; with :query containing a list of literals which is fed straight
;; to dl-query.
(define
dl-eval
(fn
(source query-source)
(let
((db (dl-program source))
(queries (dl-parse query-source)))
(cond
((= (len queries) 0) (error "dl-eval: query string is empty"))
((not (has-key? (first queries) :query))
(error "dl-eval: second arg must be a `?- ...` query clause"))
(else
(dl-query db (get (first queries) :query)))))))
;; (dl-eval-magic source query-source) — like dl-eval but routes a
;; single-positive-literal query through `dl-magic-query` for goal-
;; directed evaluation. Multi-literal query bodies fall back to the
;; standard dl-query path (magic-sets is currently only wired for
;; single-positive goals). The caller's source is parsed afresh
;; each call so successive invocations are independent.
(define
dl-eval-magic
(fn
(source query-source)
(let
((db (dl-program source))
(queries (dl-parse query-source)))
(cond
((= (len queries) 0) (error "dl-eval-magic: query string is empty"))
((not (has-key? (first queries) :query))
(error
"dl-eval-magic: second arg must be a `?- ...` query clause"))
(else
(let
((qbody (get (first queries) :query)))
(cond
((and (= (len qbody) 1)
(list? (first qbody))
(> (len (first qbody)) 0)
(symbol? (first (first qbody))))
(dl-magic-query db (first qbody)))
(else (dl-query db qbody)))))))))
;; List rules whose head's relation matches `rel-name`. Useful for
;; inspection ("show me how this relation is derived") without
;; exposing the internal `:rules` list.
(define
dl-rules-of
(fn
(db rel-name)
(let ((out (list)))
(do
(for-each
(fn
(rule)
(when
(= (dl-rel-name (get rule :head)) rel-name)
(append! out rule)))
(dl-rules db))
out))))
(define
dl-rule-head-rels
(fn
(db)
(let ((seen (list)))
(do
(for-each
(fn
(rule)
(let ((h (dl-rel-name (get rule :head))))
(when
(and (not (nil? h)) (not (dl-member-string? h seen)))
(append! seen h))))
(dl-rules db))
seen))))
;; Wipe every relation that has at least one rule (i.e. every IDB
;; relation) — leaves EDB facts and rule definitions intact. Useful
;; before a follow-up `dl-saturate!` if you want a clean restart, or
;; for inspection of the EDB-only baseline.
(define
dl-clear-idb!
(fn
(db)
(let ((rule-heads (dl-rule-head-rels db)))
(do
(for-each
(fn
(k)
(do
(dict-set! (get db :facts) k (list))
(dict-set! (get db :facts-keys) k {})
(dict-set! (get db :facts-index) k {})))
rule-heads)
db))))

406
lib/datalog/builtins.sx
View File

@@ -1,406 +0,0 @@
;; lib/datalog/builtins.sx — comparison + arithmetic body literals.
;;
;; Built-in predicates filter / extend candidate substitutions during
;; rule evaluation. They are not stored facts and do not participate in
;; the Herbrand base.
;;
;; (< a b) (<= a b) (> a b) (>= a b) ; numeric (or string) compare
;; (= a b) ; unify (binds vars)
;; (!= a b) ; ground-only inequality
;; (is X expr) ; bind X to expr's value
;;
;; Arithmetic expressions are SX-list compounds:
;; (+ a b) (- a b) (* a b) (/ a b)
;; or numbers / variables (must be bound at evaluation time).
(define
dl-comparison?
(fn
(lit)
(and
(list? lit)
(> (len lit) 0)
(let
((rel (dl-rel-name lit)))
(cond
((nil? rel) false)
(else (dl-member-string? rel (list "<" "<=" ">" ">=" "!="))))))))
(define
dl-eq?
(fn
(lit)
(and
(list? lit)
(> (len lit) 0)
(let ((rel (dl-rel-name lit))) (and (not (nil? rel)) (= rel "="))))))
(define
dl-is?
(fn
(lit)
(and
(list? lit)
(> (len lit) 0)
(let
((rel (dl-rel-name lit)))
(and (not (nil? rel)) (= rel "is"))))))
;; Evaluate an arithmetic expression under subst. Returns the numeric
;; result, or raises if any operand is unbound or non-numeric.
(define
dl-eval-arith
(fn
(expr subst)
(let
((w (dl-walk expr subst)))
(cond
((number? w) w)
((dl-var? w)
(error (str "datalog arith: unbound variable " (symbol->string w))))
((list? w)
(let
((rel (dl-rel-name w)) (args (rest w)))
(cond
((not (= (len args) 2))
(error (str "datalog arith: need 2 args, got " w)))
(else
(let
((a (dl-eval-arith (first args) subst))
(b (dl-eval-arith (nth args 1) subst)))
(cond
((= rel "+") (+ a b))
((= rel "-") (- a b))
((= rel "*") (* a b))
((= rel "/")
(cond
((= b 0)
(error
(str "datalog arith: division by zero in "
w)))
(else (/ a b))))
(else (error (str "datalog arith: unknown op " rel)))))))))
(else (error (str "datalog arith: not a number — " w)))))))
;; Comparable types — both operands must be the same primitive type
;; (both numbers, both strings). `!=` is the exception: it's defined
;; for any pair (returns true iff not equal) since dl-tuple-equal?
;; handles type-mixed comparisons.
(define
dl-compare-typeok?
(fn
(rel a b)
(cond
((= rel "!=") true)
((and (number? a) (number? b)) true)
((and (string? a) (string? b)) true)
(else false))))
(define
dl-eval-compare
(fn
(lit subst)
(let
((rel (dl-rel-name lit))
(a (dl-walk (nth lit 1) subst))
(b (dl-walk (nth lit 2) subst)))
(cond
((or (dl-var? a) (dl-var? b))
(error
(str
"datalog: comparison "
rel
" has unbound argument; "
"ensure prior body literal binds the variable")))
((not (dl-compare-typeok? rel a b))
(error
(str "datalog: comparison " rel " requires same-type "
"operands (both numbers or both strings), got "
a " and " b)))
(else
(let
((ok (cond ((= rel "<") (< a b)) ((= rel "<=") (<= a b)) ((= rel ">") (> a b)) ((= rel ">=") (>= a b)) ((= rel "!=") (not (dl-tuple-equal? a b))) (else (error (str "datalog: unknown compare " rel))))))
(if ok subst nil)))))))
(define
dl-eval-eq
(fn
(lit subst)
(dl-unify (nth lit 1) (nth lit 2) subst)))
(define
dl-eval-is
(fn
(lit subst)
(let
((target (nth lit 1)) (expr (nth lit 2)))
(let
((value (dl-eval-arith expr subst)))
(dl-unify target value subst)))))
(define
dl-eval-builtin
(fn
(lit subst)
(cond
((dl-comparison? lit) (dl-eval-compare lit subst))
((dl-eq? lit) (dl-eval-eq lit subst))
((dl-is? lit) (dl-eval-is lit subst))
(else (error (str "dl-eval-builtin: not a built-in: " lit))))))
;; ── Safety analysis ──────────────────────────────────────────────
;;
;; Walks body literals left-to-right tracking a "bound" set. The check
;; understands these literal kinds:
;;
;; positive non-built-in → adds its vars to bound
;; (is X expr) → vars(expr) ⊆ bound, then add X (if var)
;; <,<=,>,>=,!= → all vars ⊆ bound (no binding)
;; (= a b) where:
;; both non-vars → constraint check, no binding
;; a var, b not → bind a
;; b var, a not → bind b
;; both vars → at least one in bound; bind the other
;; {:neg lit} → all vars ⊆ bound (Phase 7 enforces fully)
;;
;; At end, head vars (minus `_`) must be ⊆ bound.
(define
dl-vars-not-in
(fn
(vs bound)
(let
((out (list)))
(do
(for-each
(fn
(v)
(when (not (dl-member-string? v bound)) (append! out v)))
vs)
out))))
;; Filter a list of variable-name strings to exclude anonymous-renamed
;; vars (`_` in source → `_anon*` by dl-rename-anon-term). Used by
;; the negation safety check, where anonymous vars are existential
;; within the negated literal.
(define
dl-non-anon-vars
(fn
(vs)
(let
((out (list)))
(do
(for-each
(fn
(v)
(when
(not (and (>= (len v) 5)
(= (slice v 0 5) "_anon")))
(append! out v)))
vs)
out))))
(define
dl-rule-check-safety
(fn
(rule)
(let
((head (get rule :head))
(body (get rule :body))
(bound (list))
(err nil))
(do
(define
dl-add-bound!
(fn
(vs)
(for-each
(fn
(v)
(when (not (dl-member-string? v bound)) (append! bound v)))
vs)))
(define
dl-process-eq!
(fn
(lit)
(let
((a (nth lit 1)) (b (nth lit 2)))
(let
((va (dl-var? a)) (vb (dl-var? b)))
(cond
((and (not va) (not vb)) nil)
((and va (not vb))
(dl-add-bound! (list (symbol->string a))))
((and (not va) vb)
(dl-add-bound! (list (symbol->string b))))
(else
(let
((sa (symbol->string a)) (sb (symbol->string b)))
(cond
((dl-member-string? sa bound)
(dl-add-bound! (list sb)))
((dl-member-string? sb bound)
(dl-add-bound! (list sa)))
(else
(set!
err
(str
"= between two unbound variables "
(list sa sb)
" — at least one must be bound by an "
"earlier positive body literal")))))))))))
(define
dl-process-cmp!
(fn
(lit)
(let
((needed (dl-vars-of (list (nth lit 1) (nth lit 2)))))
(let
((missing (dl-vars-not-in needed bound)))
(when
(> (len missing) 0)
(set!
err
(str
"comparison "
(dl-rel-name lit)
" requires bound variable(s) "
missing
" (must be bound by an earlier positive "
"body literal)")))))))
(define
dl-process-is!
(fn
(lit)
(let
((tgt (nth lit 1)) (expr (nth lit 2)))
(let
((needed (dl-vars-of expr)))
(let
((missing (dl-vars-not-in needed bound)))
(cond
((> (len missing) 0)
(set!
err
(str
"is RHS uses unbound variable(s) "
missing
" — bind them via a prior positive body "
"literal")))
(else
(when
(dl-var? tgt)
(dl-add-bound! (list (symbol->string tgt)))))))))))
(define
dl-process-neg!
(fn
(lit)
(let
((inner (get lit :neg)))
(let
((inner-rn
(cond
((and (list? inner) (> (len inner) 0))
(dl-rel-name inner))
(else nil)))
;; Anonymous variables (`_` in source → `_anon*` after
;; renaming) are existentially quantified within the
;; negated literal — they don't need to be bound by
;; an earlier body lit, since `not p(X, _)` is a
;; valid idiom for "no Y exists s.t. p(X, Y)". Filter
;; them out of the safety check.
(needed (dl-non-anon-vars (dl-vars-of inner)))
(missing (dl-vars-not-in needed bound)))
(cond
((and (not (nil? inner-rn)) (dl-reserved-rel? inner-rn))
(set! err
(str "negated literal uses reserved name '"
inner-rn
"' — nested `not(...)` / negated built-ins are "
"not supported; introduce an intermediate "
"relation and negate that")))
((> (len missing) 0)
(set! err
(str "negation refers to unbound variable(s) "
missing
" — they must be bound by an earlier "
"positive body literal"))))))))
(define
dl-process-agg!
(fn
(lit)
(let
((result-var (nth lit 1)))
;; Aggregate goal vars are existentially quantified within
;; the aggregate; nothing required from outer context. The
;; result var becomes bound after the aggregate fires.
(when
(dl-var? result-var)
(dl-add-bound! (list (symbol->string result-var)))))))
(define
dl-process-lit!
(fn
(lit)
(when
(nil? err)
(cond
((and (dict? lit) (has-key? lit :neg))
(dl-process-neg! lit))
;; A bare dict that is not a recognised negation is
;; almost certainly a typo (e.g. `{:negs ...}` instead
;; of `{:neg ...}`). Without this guard the dict would
;; silently fall through every clause; the head safety
;; check would then flag the head variables as unbound
;; even though the real bug is the malformed body lit.
((dict? lit)
(set! err
(str "body literal is a dict but lacks :neg — "
"the only dict-shaped body lit recognised is "
"{:neg <positive-lit>} for stratified "
"negation, got " lit)))
((dl-aggregate? lit) (dl-process-agg! lit))
((dl-eq? lit) (dl-process-eq! lit))
((dl-is? lit) (dl-process-is! lit))
((dl-comparison? lit) (dl-process-cmp! lit))
((and (list? lit) (> (len lit) 0))
(let ((rn (dl-rel-name lit)))
(cond
((and (not (nil? rn)) (dl-reserved-rel? rn))
(set! err
(str "body literal uses reserved name '" rn
"' — built-ins / aggregates have their own "
"syntax; nested `not(...)` is not supported "
"(use stratified negation via an "
"intermediate relation)")))
(else (dl-add-bound! (dl-vars-of lit))))))
(else
;; Anything that's not a dict, not a list, or an
;; empty list. Numbers / strings / symbols as body
;; lits don't make sense — surface the type.
(set! err
(str "body literal must be a positive lit, "
"built-in, aggregate, or {:neg ...} dict, "
"got " lit)))))))
(for-each dl-process-lit! body)
(when
(nil? err)
(let
((head-vars (dl-vars-of head)) (missing (list)))
(do
(for-each
(fn
(v)
(when
(and (not (dl-member-string? v bound)) (not (= v "_")))
(append! missing v)))
head-vars)
(when
(> (len missing) 0)
(set!
err
(str
"head variable(s) "
missing
" do not appear in any positive body literal"))))))
err))))

32
lib/datalog/conformance.conf
View File

@@ -1,32 +0,0 @@
# Datalog conformance config — sourced by lib/guest/conformance.sh.
LANG_NAME=datalog
MODE=dict
PRELOADS=(
lib/datalog/tokenizer.sx
lib/datalog/parser.sx
lib/datalog/unify.sx
lib/datalog/db.sx
lib/datalog/builtins.sx
lib/datalog/aggregates.sx
lib/datalog/strata.sx
lib/datalog/eval.sx
lib/datalog/api.sx
lib/datalog/magic.sx
lib/datalog/demo.sx
)
SUITES=(
"tokenize:lib/datalog/tests/tokenize.sx:(dl-tokenize-tests-run!)"
"parse:lib/datalog/tests/parse.sx:(dl-parse-tests-run!)"
"unify:lib/datalog/tests/unify.sx:(dl-unify-tests-run!)"
"eval:lib/datalog/tests/eval.sx:(dl-eval-tests-run!)"
"builtins:lib/datalog/tests/builtins.sx:(dl-builtins-tests-run!)"
"semi_naive:lib/datalog/tests/semi_naive.sx:(dl-semi-naive-tests-run!)"
"negation:lib/datalog/tests/negation.sx:(dl-negation-tests-run!)"
"aggregates:lib/datalog/tests/aggregates.sx:(dl-aggregates-tests-run!)"
"api:lib/datalog/tests/api.sx:(dl-api-tests-run!)"
"magic:lib/datalog/tests/magic.sx:(dl-magic-tests-run!)"
"demo:lib/datalog/tests/demo.sx:(dl-demo-tests-run!)"
)

3
lib/datalog/conformance.sh
View File

@@ -1,3 +0,0 @@
#!/usr/bin/env bash
# Thin wrapper — see lib/guest/conformance.sh and lib/datalog/conformance.conf.
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

97
lib/datalog/datalog.sx
View File

@@ -1,97 +0,0 @@
;; lib/datalog/datalog.sx — public API documentation index.
;;
;; This file is reference-only — `load` is an epoch-protocol command,
;; not an SX function, so it cannot reload a list of files from inside
;; another `.sx` file. To set up a fresh sx_server session with all
;; modules in scope, issue these loads in order:
;;
;; (load "lib/datalog/tokenizer.sx")
;; (load "lib/datalog/parser.sx")
;; (load "lib/datalog/unify.sx")
;; (load "lib/datalog/db.sx")
;; (load "lib/datalog/builtins.sx")
;; (load "lib/datalog/aggregates.sx")
;; (load "lib/datalog/strata.sx")
;; (load "lib/datalog/eval.sx")
;; (load "lib/datalog/api.sx")
;; (load "lib/datalog/magic.sx")
;; (load "lib/datalog/demo.sx")
;;
;; (lib/datalog/conformance.sh runs this load list automatically.)
;;
;; ── Public API surface ─────────────────────────────────────────────
;;
;; Source / data:
;; (dl-tokenize "src") → token list
;; (dl-parse "src") → parsed clauses
;; (dl-program "src") → db built from a source string
;; (dl-program-data facts rules) → db from SX data lists; rules
;; accept either dict form or
;; list form with `<-` arrow
;;
;; Construction (mutates db):
;; (dl-make-db) empty db
;; (dl-add-fact! db lit) rejects non-ground
;; (dl-add-rule! db rule) rejects unsafe rules
;; (dl-rule head body) dict-rule constructor
;; (dl-add-clause! db clause) parser output → fact or rule
;; (dl-load-program! db src) string source
;; (dl-set-strategy! db strategy) :semi-naive default; :magic
;; is informational, use
;; dl-magic-query for actual
;; magic-sets evaluation
;;
;; Mutation:
;; (dl-assert! db lit) add + re-saturate
;; (dl-retract! db lit) drop EDB, wipe IDB, re-saturate
;; (dl-clear-idb! db) wipe rule-headed relations
;;
;; Query / inspection:
;; (dl-saturate! db) stratified semi-naive default
;; (dl-saturate-naive! db) reference (slow on chains)
;; (dl-saturate-rules! db rules) per-rule-set semi-naive worker
;; (dl-query db goal) list of substitution dicts
;; (dl-relation db rel-name) tuple list for a relation
;; (dl-rules db) rule list
;; (dl-fact-count db) total ground tuples
;; (dl-summary db) {<rel>: count} for inspection
;;
;; Single-call convenience:
;; (dl-eval source query-source) parse, run, return substs
;; (dl-eval-magic source query-source) single-goal → magic-sets
;;
;; Magic-sets (lib/datalog/magic.sx):
;; (dl-adorn-goal goal) "b/f" adornment string
;; (dl-rule-sips rule head-adn) SIPS analysis per body lit
;; (dl-magic-rewrite rules rel adn args)
;; rewritten rule list + seed
;; (dl-magic-query db query-goal) end-to-end magic-sets query
;;
;; ── Body literal kinds ─────────────────────────────────────────────
;;
;; Positive (rel arg ... arg)
;; Negation {:neg (rel arg ...)}
;; Comparison (< X Y), (<= X Y), (> X Y), (>= X Y),
;; (= X Y), (!= X Y)
;; Arithmetic (is Z (+ X Y)) and (- * /)
;; Aggregation (count R V Goal), (sum R V Goal),
;; (min R V Goal), (max R V Goal),
;; (findall L V Goal)
;;
;; ── Variable conventions ───────────────────────────────────────────
;;
;; Variables: SX symbols whose first char is uppercase A–Z or '_'.
;; Anonymous '_' is renamed to a fresh _anon<N> per occurrence at
;; rule/query load time so multiple '_' don't unify.
;;
;; ── Demo programs ──────────────────────────────────────────────────
;;
;; See lib/datalog/demo.sx — federation, content, permissions, and
;; the canonical "cooking posts by people I follow (transitively)"
;; example.
;;
;; ── Status ─────────────────────────────────────────────────────────
;;
;; See plans/datalog-on-sx.md — phase-by-phase progress log and
;; roadmap. Run `bash lib/datalog/conformance.sh` to refresh
;; `lib/datalog/scoreboard.{json,md}`.

575
lib/datalog/db.sx
View File

@@ -1,575 +0,0 @@
;; lib/datalog/db.sx — Datalog database (EDB + IDB + rules) + safety hook.
;;
;; A db is a mutable dict:
;; {:facts {<rel-name-string> -> (literal ...)}
;; :rules ({:head literal :body (literal ...)} ...)}
;;
;; Facts are stored as full literals `(rel arg ... arg)` so they unify
;; directly against rule body literals. Each relation's tuple list is
;; deduplicated on insert.
;;
;; Phase 3 introduced safety analysis for head variables; Phase 4 (in
;; lib/datalog/builtins.sx) swaps in the real `dl-rule-check-safety`,
;; which is order-aware and understands built-in predicates.
(define
dl-make-db
(fn ()
{:facts {}
:facts-keys {}
:facts-index {}
:edb-keys {}
:rules (list)
:strategy :semi-naive}))
;; Record (rel-key, tuple-key) as user-asserted EDB. dl-add-fact! calls
;; this when an explicit fact is added; the saturator (which uses
;; dl-add-derived!) does NOT, so derived tuples never appear here.
;; dl-retract! consults :edb-keys to know which tuples must survive
;; the wipe-and-resaturate round-trip.
(define
dl-mark-edb!
(fn
(db rel-key tk)
(let
((edb (get db :edb-keys)))
(do
(when
(not (has-key? edb rel-key))
(dict-set! edb rel-key {}))
(dict-set! (get edb rel-key) tk true)))))
(define
dl-edb-fact?
(fn
(db rel-key tk)
(let
((edb (get db :edb-keys)))
(and (has-key? edb rel-key)
(has-key? (get edb rel-key) tk)))))
;; Evaluation strategy. Default :semi-naive (used by dl-saturate!).
;; :naive selects dl-saturate-naive! (slower but easier to reason
;; about). :magic is a marker — goal-directed magic-sets evaluation
;; is invoked separately via `dl-magic-query`; setting :magic here
;; is purely informational. Any other value is rejected so typos
;; don't silently fall back to the default.
(define
dl-strategy-values
(list :semi-naive :naive :magic))
(define
dl-set-strategy!
(fn
(db strategy)
(cond
((not (dl-keyword-member? strategy dl-strategy-values))
(error (str "dl-set-strategy!: unknown strategy " strategy
" — must be one of " dl-strategy-values)))
(else
(do
(dict-set! db :strategy strategy)
db)))))
(define
dl-keyword-member?
(fn
(k xs)
(cond
((= (len xs) 0) false)
((= k (first xs)) true)
(else (dl-keyword-member? k (rest xs))))))
(define
dl-get-strategy
(fn
(db)
(if (has-key? db :strategy) (get db :strategy) :semi-naive)))
(define
dl-rel-name
(fn
(lit)
(cond
((and (dict? lit) (has-key? lit :neg)) (dl-rel-name (get lit :neg)))
((and (list? lit) (> (len lit) 0) (symbol? (first lit)))
(symbol->string (first lit)))
(else nil))))
(define dl-builtin-rels (list "<" "<=" ">" ">=" "=" "!=" "is"))
(define
dl-member-string?
(fn
(s xs)
(cond
((= (len xs) 0) false)
((= (first xs) s) true)
(else (dl-member-string? s (rest xs))))))
(define
dl-builtin?
(fn
(lit)
(and
(list? lit)
(> (len lit) 0)
(let
((rel (dl-rel-name lit)))
(cond
((nil? rel) false)
(else (dl-member-string? rel dl-builtin-rels)))))))
(define
dl-positive-lit?
(fn
(lit)
(cond
((and (dict? lit) (has-key? lit :neg)) false)
((dl-builtin? lit) false)
((and (list? lit) (> (len lit) 0)) true)
(else false))))
(define
dl-tuple-equal?
(fn
(a b)
(cond
((and (list? a) (list? b))
(and (= (len a) (len b)) (dl-tuple-equal-list? a b 0)))
((and (number? a) (number? b)) (= a b))
(else (equal? a b)))))
(define
dl-tuple-equal-list?
(fn
(a b i)
(cond
((>= i (len a)) true)
((not (dl-tuple-equal? (nth a i) (nth b i))) false)
(else (dl-tuple-equal-list? a b (+ i 1))))))
(define
dl-tuple-member?
(fn
(lit lits)
(dl-tuple-member-aux? lit lits 0 (len lits))))
(define
dl-tuple-member-aux?
(fn
(lit lits i n)
(cond
((>= i n) false)
((dl-tuple-equal? lit (nth lits i)) true)
(else (dl-tuple-member-aux? lit lits (+ i 1) n)))))
(define
dl-ensure-rel!
(fn
(db rel-key)
(let
((facts (get db :facts))
(fk (get db :facts-keys))
(fi (get db :facts-index)))
(do
(when
(not (has-key? facts rel-key))
(dict-set! facts rel-key (list)))
(when
(not (has-key? fk rel-key))
(dict-set! fk rel-key {}))
(when
(not (has-key? fi rel-key))
(dict-set! fi rel-key {}))
(get facts rel-key)))))
;; First-arg index helpers. Tuples are keyed by their first-after-rel
;; arg's `(str ...)`; when that arg is a constant, dl-match-positive
;; uses the index instead of scanning the full relation.
(define
dl-arg-key
(fn
(v)
(str v)))
(define
dl-index-add!
(fn
(db rel-key lit)
(let
((idx (get db :facts-index))
(n (len lit)))
(when
(and (>= n 2) (has-key? idx rel-key))
(let
((rel-idx (get idx rel-key))
(k (dl-arg-key (nth lit 1))))
(do
(when
(not (has-key? rel-idx k))
(dict-set! rel-idx k (list)))
(append! (get rel-idx k) lit)))))))
(define
dl-index-lookup
(fn
(db rel-key arg-val)
(let
((idx (get db :facts-index)))
(cond
((not (has-key? idx rel-key)) (list))
(else
(let ((rel-idx (get idx rel-key))
(k (dl-arg-key arg-val)))
(if (has-key? rel-idx k) (get rel-idx k) (list))))))))
(define dl-tuple-key (fn (lit) (str lit)))
(define
dl-rel-tuples
(fn
(db rel-key)
(let
((facts (get db :facts)))
(if (has-key? facts rel-key) (get facts rel-key) (list)))))
;; Reserved relation names: built-in / aggregate / negation / arrow.
;; Rules and facts may not have these as their head's relation, since
;; the saturator treats them specially or they are not relation names
;; at all.
(define
dl-reserved-rel-names
(list "not" "count" "sum" "min" "max" "findall" "is"
"<" "<=" ">" ">=" "=" "!=" "+" "-" "*" "/" ":-" "?-"))
(define
dl-reserved-rel?
(fn
(name) (dl-member-string? name dl-reserved-rel-names)))
;; Internal: append a derived tuple to :facts without the public
;; validation pass and without marking :edb-keys. Used by the saturator
;; (eval.sx) and magic-sets (magic.sx). Returns true if the tuple was
;; new, false if already present.
(define
dl-add-derived!
(fn
(db lit)
(let
((rel-key (dl-rel-name lit)))
(let
((tuples (dl-ensure-rel! db rel-key))
(key-dict (get (get db :facts-keys) rel-key))
(tk (dl-tuple-key lit)))
(cond
((has-key? key-dict tk) false)
(else
(do
(dict-set! key-dict tk true)
(append! tuples lit)
(dl-index-add! db rel-key lit)
true)))))))
;; A simple term — number, string, or symbol — i.e. anything legal
;; as an EDB fact arg. Compound (list) args belong only in body
;; literals where they encode arithmetic / aggregate sub-goals.
(define
dl-simple-term?
(fn
(term)
(or (number? term) (string? term) (symbol? term))))
(define
dl-args-simple?
(fn
(lit i n)
(cond
((>= i n) true)
((not (dl-simple-term? (nth lit i))) false)
(else (dl-args-simple? lit (+ i 1) n)))))
(define
dl-add-fact!
(fn
(db lit)
(cond
((not (and (list? lit) (> (len lit) 0)))
(error (str "dl-add-fact!: expected literal list, got " lit)))
((dl-reserved-rel? (dl-rel-name lit))
(error (str "dl-add-fact!: '" (dl-rel-name lit)
"' is a reserved name (built-in / aggregate / negation)")))
((not (dl-args-simple? lit 1 (len lit)))
(error (str "dl-add-fact!: fact args must be numbers, strings, "
"or symbols — compound args (e.g. arithmetic "
"expressions) are body-only and aren't evaluated "
"in fact position. got " lit)))
((not (dl-ground? lit (dl-empty-subst)))
(error (str "dl-add-fact!: expected ground literal, got " lit)))
(else
(let
((rel-key (dl-rel-name lit)) (tk (dl-tuple-key lit)))
(do
;; Always mark EDB origin — even if the tuple key was already
;; present (e.g. previously derived), so an explicit assert
;; promotes it to EDB and protects it from the IDB wipe.
(dl-mark-edb! db rel-key tk)
(dl-add-derived! db lit)))))))
;; The full safety check lives in builtins.sx (it has to know which
;; predicates are built-ins). dl-add-rule! calls it via forward
;; reference; load builtins.sx alongside db.sx in any setup that
;; adds rules. The fallback below is used if builtins.sx isn't loaded.
(define
dl-rule-check-safety
(fn
(rule)
(let
((head-vars (dl-vars-of (get rule :head))) (body-vars (list)))
(do
(for-each
(fn
(lit)
(when
(and
(list? lit)
(> (len lit) 0)
(not (and (dict? lit) (has-key? lit :neg))))
(for-each
(fn
(v)
(when
(not (dl-member-string? v body-vars))
(append! body-vars v)))
(dl-vars-of lit))))
(get rule :body))
(let
((missing (list)))
(do
(for-each
(fn
(v)
(when
(and
(not (dl-member-string? v body-vars))
(not (= v "_")))
(append! missing v)))
head-vars)
(cond
((> (len missing) 0)
(str
"head variable(s) "
missing
" do not appear in any body literal"))
(else nil))))))))
(define
dl-rename-anon-term
(fn
(term next-name)
(cond
((and (symbol? term) (= (symbol->string term) "_"))
(next-name))
((list? term)
(map (fn (x) (dl-rename-anon-term x next-name)) term))
(else term))))
(define
dl-rename-anon-lit
(fn
(lit next-name)
(cond
((and (dict? lit) (has-key? lit :neg))
{:neg (dl-rename-anon-term (get lit :neg) next-name)})
((list? lit) (dl-rename-anon-term lit next-name))
(else lit))))
(define
dl-make-anon-renamer
(fn
(start)
(let ((counter start))
(fn () (do (set! counter (+ counter 1))
(string->symbol (str "_anon" counter)))))))
;; Scan a rule for variables already named `_anon<N>` (which would
;; otherwise collide with the renamer's output). Returns the max N
;; seen, or 0 if none. The renamer then starts at that max + 1, so
;; freshly-introduced anonymous names can't shadow a user-written
;; `_anon<N>` symbol.
(define
dl-max-anon-num
(fn
(term acc)
(cond
((symbol? term)
(let ((s (symbol->string term)))
(cond
((and (>= (len s) 6) (= (slice s 0 5) "_anon"))
(let ((n (dl-try-parse-int (slice s 5 (len s)))))
(cond
((nil? n) acc)
((> n acc) n)
(else acc))))
(else acc))))
((dict? term)
(cond
((has-key? term :neg)
(dl-max-anon-num (get term :neg) acc))
(else acc)))
((list? term) (dl-max-anon-num-list term acc 0))
(else acc))))
(define
dl-max-anon-num-list
(fn
(xs acc i)
(cond
((>= i (len xs)) acc)
(else
(dl-max-anon-num-list xs (dl-max-anon-num (nth xs i) acc) (+ i 1))))))
;; Cheap "is this string a decimal int" check. Returns the number or
;; nil. Avoids relying on host parse-number, which on non-int strings
;; might raise rather than return nil.
(define
dl-try-parse-int
(fn
(s)
(cond
((= (len s) 0) nil)
((not (dl-all-digits? s 0 (len s))) nil)
(else (parse-number s)))))
(define
dl-all-digits?
(fn
(s i n)
(cond
((>= i n) true)
((let ((c (slice s i (+ i 1))))
(not (and (>= c "0") (<= c "9"))))
false)
(else (dl-all-digits? s (+ i 1) n)))))
(define
dl-rename-anon-rule
(fn
(rule)
(let
((start (dl-max-anon-num (get rule :head)
(dl-max-anon-num-list (get rule :body) 0 0))))
(let ((next-name (dl-make-anon-renamer start)))
{:head (dl-rename-anon-term (get rule :head) next-name)
:body (map (fn (lit) (dl-rename-anon-lit lit next-name))
(get rule :body))}))))
(define
dl-add-rule!
(fn
(db rule)
(cond
((not (dict? rule))
(error (str "dl-add-rule!: expected rule dict, got " rule)))
((not (has-key? rule :head))
(error (str "dl-add-rule!: rule missing :head, got " rule)))
((not (and (list? (get rule :head))
(> (len (get rule :head)) 0)
(symbol? (first (get rule :head)))))
(error (str "dl-add-rule!: head must be a non-empty list "
"starting with a relation-name symbol, got "
(get rule :head))))
((not (dl-args-simple? (get rule :head) 1 (len (get rule :head))))
(error (str "dl-add-rule!: rule head args must be variables or "
"constants — compound terms (e.g. `(*(X, 2))`) are "
"not legal in head position; introduce an `is`-bound "
"intermediate in the body. got " (get rule :head))))
((not (list? (if (has-key? rule :body) (get rule :body) (list))))
(error (str "dl-add-rule!: body must be a list of literals, got "
(get rule :body))))
((dl-reserved-rel? (dl-rel-name (get rule :head)))
(error (str "dl-add-rule!: '" (dl-rel-name (get rule :head))
"' is a reserved name (built-in / aggregate / negation)")))
(else
(let ((rule (dl-rename-anon-rule rule)))
(let
((err (dl-rule-check-safety rule)))
(cond
((not (nil? err)) (error (str "dl-add-rule!: " err)))
(else
(let
((rules (get db :rules)))
(do (append! rules rule) true))))))))))
(define
dl-add-clause!
(fn
(db clause)
(cond
((has-key? clause :query) false)
((and (has-key? clause :body) (= (len (get clause :body)) 0))
(dl-add-fact! db (get clause :head)))
(else (dl-add-rule! db clause)))))
(define
dl-load-program!
(fn
(db source)
(let
((clauses (dl-parse source)))
(do (for-each (fn (c) (dl-add-clause! db c)) clauses) db))))
(define
dl-program
(fn (source) (let ((db (dl-make-db))) (dl-load-program! db source))))
(define dl-rules (fn (db) (get db :rules)))
(define
dl-fact-count
(fn
(db)
(let
((facts (get db :facts)) (total 0))
(do
(for-each
(fn (k) (set! total (+ total (len (get facts k)))))
(keys facts))
total))))
;; Returns {<rel-name>: tuple-count} for debugging. Includes
;; relations with any tuples plus all rule-head relations (so empty
;; IDB shows as 0). Skips empty EDB-only entries that are placeholders
;; from internal `dl-ensure-rel!` calls.
(define
dl-summary
(fn
(db)
(let
((facts (get db :facts))
(out {})
(rule-heads (list)))
(do
(for-each
(fn
(rule)
(let ((h (dl-rel-name (get rule :head))))
(when
(and (not (nil? h)) (not (dl-member-string? h rule-heads)))
(append! rule-heads h))))
(dl-rules db))
(for-each
(fn
(k)
(let ((c (len (get facts k))))
(when
(or (> c 0) (dl-member-string? k rule-heads))
(dict-set! out k c))))
(keys facts))
;; Add rule heads that have no facts (yet).
(for-each
(fn
(k)
(when (not (has-key? out k)) (dict-set! out k 0)))
rule-heads)
out))))

162
lib/datalog/demo.sx
View File

@@ -1,162 +0,0 @@
;; lib/datalog/demo.sx — example programs over rose-ash-shaped data.
;;
;; Phase 10 prototypes Datalog as a rose-ash query language. Wiring
;; the EDB to actual PostgreSQL is out of scope for this loop (it
;; would touch service code outside lib/datalog/), but the programs
;; below show the shape of queries we want, and the test suite runs
;; them against synthetic in-memory tuples loaded via dl-program-data.
;;
;; Seven thematic demos:
;;
;; 1. Federation — follow graph, transitive reach, mutuals, FOAF.
;; 2. Content — posts, tags, likes, popularity, "for you" feed.
;; 3. Permissions — group membership and resource access.
;; 4. Cooking-posts — canonical "posts about cooking by people I
;; follow (transitively)" multi-domain query.
;; 5. Tag co-occurrence — distinct (T1, T2) pairs with counts.
;; 6. Shortest path — weighted-DAG path enumeration + min agg.
;; 7. Org chart — transitive subordinate + headcount per mgr.
;; ── Demo 1: federation follow graph ─────────────────────────────
;; EDB: (follows ACTOR-A ACTOR-B) — A follows B.
;; IDB:
;; (mutual A B) — A follows B and B follows A
;; (reachable A B) — transitive follow closure
;; (foaf A C) — friend of a friend (mutual filter)
(define
dl-demo-federation-rules
(quote
((mutual A B <- (follows A B) (follows B A))
(reachable A B <- (follows A B))
(reachable A C <- (follows A B) (reachable B C))
(foaf A C <- (follows A B) (follows B C) (!= A C)))))
;; ── Demo 2: content recommendation ──────────────────────────────
;; EDB:
;; (authored ACTOR POST)
;; (tagged POST TAG)
;; (liked ACTOR POST)
;; IDB:
;; (post-likes POST N) — count of likes per post
;; (popular POST) — posts with >= 3 likes
;; (tagged-by-mutual ACTOR POST) — post tagged TOPIC by someone
;; A's mutuals follow.
(define
dl-demo-content-rules
(quote
((post-likes P N <- (authored Author P) (count N L (liked L P)))
(popular P <- (authored Author P) (post-likes P N) (>= N 3))
(interesting Me P
<-
(follows Me Buddy)
(authored Buddy P)
(popular P)))))
;; ── Demo 3: role-based permissions ──────────────────────────────
;; EDB:
;; (member ACTOR GROUP)
;; (subgroup CHILD PARENT)
;; (allowed GROUP RESOURCE)
;; IDB:
;; (in-group ACTOR GROUP) — direct or via subgroup chain
;; (can-access ACTOR RESOURCE) — actor inherits group permission
(define
dl-demo-perm-rules
(quote
((in-group A G <- (member A G))
(in-group A G <- (member A H) (subgroup-trans H G))
(subgroup-trans X Y <- (subgroup X Y))
(subgroup-trans X Z <- (subgroup X Y) (subgroup-trans Y Z))
(can-access A R <- (in-group A G) (allowed G R)))))
;; ── Demo 4: cooking-posts (the canonical Phase 10 query) ────────
;; "Posts about cooking by people I follow (transitively)."
;; Combines federation (follows + transitive reach), authoring,
;; tagging — the rose-ash multi-domain join.
;;
;; EDB:
;; (follows ACTOR-A ACTOR-B)
;; (authored ACTOR POST)
;; (tagged POST TAG)
(define
dl-demo-cooking-rules
(quote
((reach Me Them <- (follows Me Them))
(reach Me Them <- (follows Me X) (reach X Them))
(cooking-post-by-network Me P
<-
(reach Me Author)
(authored Author P)
(tagged P cooking)))))
;; ── Demo 5: tag co-occurrence ───────────────────────────────────
;; "Posts tagged with both T1 AND T2." Useful for narrowed-down
;; recommendations like "vegetarian cooking" posts.
;;
;; EDB:
;; (tagged POST TAG)
;; IDB:
;; (cotagged POST T1 T2) — post has both T1 and T2 (T1 != T2)
;; (popular-pair T1 T2 N) — count of posts cotagged (T1, T2)
(define
dl-demo-tag-cooccur-rules
(quote
((cotagged P T1 T2 <- (tagged P T1) (tagged P T2) (!= T1 T2))
;; Distinct (T1, T2) pairs that occur somewhere.
(tag-pair T1 T2 <- (cotagged P T1 T2))
(tag-pair-count T1 T2 N
<-
(tag-pair T1 T2)
(count N P (cotagged P T1 T2))))))
;; ── Demo 6: weighted-DAG shortest path ─────────────────────────
;; "What's the cheapest way from X to Y?" Edge weights with `is`
;; arithmetic to sum costs, then `min` aggregation to pick the
;; shortest. Termination requires the graph to be a DAG (cycles
;; would produce infinite distances without a bound; programs
;; built on this should add a depth filter `(<, D, MAX)` if cycles
;; are possible).
;;
;; EDB:
;; (edge FROM TO COST)
;; IDB:
;; (path FROM TO COST) — any path
;; (shortest FROM TO COST) — minimum cost path
(define
dl-demo-shortest-path-rules
(quote
((path X Y W <- (edge X Y W))
(path X Z W
<-
(edge X Y W1)
(path Y Z W2)
(is W (+ W1 W2)))
(shortest X Y W <- (path X Y _) (min W C (path X Y C))))))
;; ── Demo 7: org chart + transitive headcount ───────────────────
;; Manager graph: each employee has a single manager. Compute the
;; transitive subordinate set and headcount per manager.
;;
;; EDB:
;; (manager EMP MGR) — EMP reports directly to MGR
;; IDB:
;; (subordinate MGR EMP) — EMP is in MGR's subtree
;; (headcount MGR N) — number of subordinates under MGR
(define
dl-demo-org-rules
(quote
((subordinate Mgr Emp <- (manager Emp Mgr))
(subordinate Mgr Emp
<- (manager Mid Mgr) (subordinate Mid Emp))
(headcount Mgr N
<- (subordinate Mgr Anyone) (count N E (subordinate Mgr E))))))
;; ── Loader stub ──────────────────────────────────────────────────
;; Wiring to PostgreSQL would replace these helpers with calls into
;; rose-ash's internal HTTP RPC (fetch_data → /internal/data/...).
;; The shape returned by dl-load-from-edb! is the same in either case.
(define
dl-demo-make
(fn
(facts rules)
(dl-program-data facts rules)))

Some files were not shown because too many files have changed in this diff Show More