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

Compare commits

base: coop:loops/dream
Branches Tags
coop:main coop:loops/content coop:loops/fed-sx-m2 coop:loops/artdag coop:architecture coop:loops/maude coop:loops/events coop:loops/radar coop:loops/dream coop:loops/fed-prims coop:loops/relations coop:loops/commerce coop:loops/conformance coop:loops/mod coop:loops/identity coop:loops/search coop:loops/host-persist coop:loops/acl coop:loops/persist coop:loops/flow coop:loops/feed coop:loops/ruby coop:loops/erlang coop:loops/fed-sx-m1 coop:loops/go coop:loops/sx-vm-extensions 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/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/common-lisp
Branches Tags
coop:loops/content coop:loops/fed-sx-m2 coop:loops/artdag coop:architecture coop:loops/maude coop:loops/events coop:loops/radar coop:loops/dream coop:loops/fed-prims coop:loops/relations coop:loops/commerce coop:loops/conformance coop:loops/mod coop:loops/identity coop:loops/search coop:loops/host-persist coop:loops/acl coop:loops/persist coop:loops/flow coop:loops/feed coop:loops/ruby coop:loops/erlang coop:loops/fed-sx-m1 coop:loops/go coop:loops/sx-vm-extensions 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/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

1 Commits
loops/drea ... loops/comm

Author SHA1 Message Date
giles
6d53d36495 briefing: push to origin/loops/common-lisp after each commit
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 40s
Details
2026-05-05 20:08:03 +00:00
1362 changed files with 15107 additions and 214589 deletions
Expand all files Collapse all files

1
.claude/scheduled_tasks.lock
View File

@@ -1 +0,0 @@
{"sessionId":"c4d97db1-361c-4a04-a99b-c838f9385469","pid":2426590,"procStart":"349789073","acquiredAt":1780789990975}

2
.mcp.json
View File

@@ -2,7 +2,7 @@
"mcpServers": {
"sx-tree": {
"type": "stdio",
"command": "/root/rose-ash/hosts/ocaml/_build/default/bin/mcp_tree.exe"
"command": "./hosts/ocaml/_build/default/bin/mcp_tree.exe"
},
"rose-ash-services": {
"type": "stdio",

114
hosts/javascript/platform.py
View File

@@ -1129,7 +1129,6 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
PRIMITIVES["boolean?"] = function(x) { return x === true || x === false; };
PRIMITIVES["symbol?"] = function(x) { return x != null && x._sym === true; };
PRIMITIVES["keyword?"] = function(x) { return x != null && x._kw === true; };
PRIMITIVES["adt?"] = function(x) { return x !== null && typeof x === "object" && x._adtv === true; };
PRIMITIVES["component-affinity"] = componentAffinity;
''',
@@ -1476,22 +1475,6 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
};
PRIMITIVES["string-buffer->string"] = function(buf) { return buf.parts.join(""); };
PRIMITIVES["string-buffer-length"] = function(buf) { return buf.len; };
// Short aliases — terser names; append accepts any value
PRIMITIVES["make-buffer"] = function() { return new SxStringBuffer(); };
PRIMITIVES["buffer?"] = function(x) { return x instanceof SxStringBuffer; };
PRIMITIVES["buffer-append!"] = function(buf, v) {
var s;
if (v === null || v === undefined || v === NIL) s = "";
else if (typeof v === "string") s = v;
else if (typeof v === "boolean") s = v ? "true" : "false";
else if (typeof v === "number") s = String(v);
else if (v && typeof v === "object" && typeof v.name === "string" && v.constructor && v.constructor.name === "Symbol") s = v.name;
else s = (typeof inspect === "function") ? inspect(v) : String(v);
buf.parts.push(s); buf.len += s.length; return NIL;
};
PRIMITIVES["buffer->string"] = function(buf) { return buf.parts.join(""); };
PRIMITIVES["buffer-length"] = function(buf) { return buf.len; };
''',
"stdlib.format": '''
@@ -1950,30 +1933,12 @@ PLATFORM_JS_PRE = '''
if (x._regexp) return "regexp";
if (x._bytevector) return "bytevector";
if (x._rational) return "rational";
if (x._adtv) return x._type;
if (typeof Node !== "undefined" && x instanceof Node) return "dom-node";
if (Array.isArray(x)) return "list";
if (typeof x === "object") return "dict";
return "unknown";
}
// AdtValue — native algebraic data type instance (Step 6 mirror of OCaml Step 5).
// Constructed by define-type. Carries _adt:true plus _adtv:true tag so type-of
// returns the type name rather than "dict". dict? remains true (shim approach)
// so spec-level match-pattern in evaluator.sx works without changes.
function makeAdtValue(typeName, ctorName, fields) {
return {
_adtv: true,
_adt: true,
_type: typeName,
_ctor: ctorName,
_fields: fields
};
}
function isAdtValue(x) {
return x !== null && typeof x === "object" && x._adtv === true;
}
function symbolName(s) { return s.name; }
function keywordName(k) { return k.name; }
function makeSymbol(n) { return new Symbol(n); }
@@ -2140,13 +2105,6 @@ PLATFORM_JS_PRE = '''
// hostError — throw a host-level error that propagates out of cekRun.
function hostError(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); }
// hostWarn — emit a host-level warning to console (no-op if console missing).
function hostWarn(msg) {
var m = typeof msg === "string" ? msg : inspect(msg);
if (typeof console !== "undefined" && console.warn) console.warn(m);
return NIL;
}
// Render dispatch — call the active adapter's render function.
// Set by each adapter when loaded; defaults to identity (no rendering).
var _renderExprFn = null;
@@ -2168,16 +2126,7 @@ PLATFORM_JS_PRE = '''
}
function error(msg) { throw new Error(msg); }
function inspect(x) {
if (x !== null && typeof x === "object" && x._adtv === true) {
var fs = x._fields || [];
if (fs.length === 0) return "(" + x._ctor + ")";
var parts = [];
for (var i = 0; i < fs.length; i++) parts.push(inspect(fs[i]));
return "(" + x._ctor + " " + parts.join(" ") + ")";
}
return JSON.stringify(x);
}
function inspect(x) { return JSON.stringify(x); }
function debugLog() { console.error.apply(console, ["[sx-debug]"].concat(Array.prototype.slice.call(arguments))); }
'''
@@ -2501,7 +2450,6 @@ CEK_FIXUPS_JS = '''
// Platform functions — defined in platform_js.py, not in .sx spec files.
// Spec defines self-register via js-emit-define; these are the platform interface.
PRIMITIVES["type-of"] = typeOf;
PRIMITIVES["inspect"] = inspect;
PRIMITIVES["symbol-name"] = symbolName;
PRIMITIVES["keyword-name"] = keywordName;
PRIMITIVES["callable?"] = isCallable;
@@ -2823,8 +2771,8 @@ PLATFORM_DOM_JS = """
// If lambda takes 0 params, call without event arg (convenience for on-click handlers)
var wrapped = isLambda(handler)
? (lambdaParams(handler).length === 0
? function(e) { try { var r = cekCall(handler, NIL); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
: function(e) { try { var r = cekCall(handler, [e]); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
: handler;
if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler));
var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 };
@@ -4033,11 +3981,6 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
// -----------------------------------------------------------------------
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
PRIMITIVES["host-error"] = function(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); };
PRIMITIVES["host-warn"] = function(msg) {
var m = typeof msg === "string" ? msg : inspect(msg);
if (typeof console !== "undefined" && console.warn) console.warn(m);
return NIL;
};
PRIMITIVES["try-catch"] = function(tryFn, catchFn) {
try {
return cekRun(continueWithCall(tryFn, [], makeEnv(), [], []));
@@ -4160,56 +4103,7 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
function clearStores() { _storeRegistry = {}; return NIL; }
PRIMITIVES["def-store"] = defStore;
PRIMITIVES["use-store"] = useStore;
PRIMITIVES["clear-stores"] = clearStores;
// -----------------------------------------------------------------------
// define-type override — produces native AdtValue instances (Step 6).
// The transpiled sfDefineType from evaluator.sx creates plain dict
// instances. We override here to construct AdtValue via makeAdtValue so
// type-of returns the type name and adt? can distinguish from dicts.
// dict? still returns true for AdtValue (shim) so spec-level match-pattern
// continues to work without changes.
// -----------------------------------------------------------------------
var _sfDefineTypeAdt = function(args, env) {
var typeSym = first(args);
var ctorSpecs = rest(args);
var typeName = symbolName(typeSym);
var ctorNames = map(function(spec) { return symbolName(first(spec)); }, ctorSpecs);
if (!isSxTruthy(envHas(env, "*adt-registry*"))) {
envBind(env, "*adt-registry*", {});
}
envGet(env, "*adt-registry*")[typeName] = ctorNames;
envBind(env, typeName + "?", function(v) { return isAdtValue(v) && v._type === typeName; });
for (var _i = 0; _i < ctorSpecs.length; _i++) {
(function(spec) {
var cn = symbolName(first(spec));
var fieldNames = map(function(f) { return symbolName(f); }, rest(spec));
var arity = fieldNames.length;
envBind(env, cn, function() {
var ctorArgs = Array.prototype.slice.call(arguments, 0);
if (ctorArgs.length !== arity) {
throw new Error(cn + ": expected " + arity + " args, got " + ctorArgs.length);
}
return makeAdtValue(typeName, cn, ctorArgs);
});
envBind(env, cn + "?", function(v) { return isAdtValue(v) && v._ctor === cn; });
for (var _j = 0; _j < fieldNames.length; _j++) {
(function(idx, fieldName) {
envBind(env, cn + "-" + fieldName, function(v) {
if (!isAdtValue(v)) throw new Error(cn + "-" + fieldName + ": not an ADT");
if (idx >= v._fields.length) throw new Error(cn + "-" + fieldName + ": index out of bounds");
return v._fields[idx];
});
})(_j, fieldNames[_j]);
}
})(ctorSpecs[_i]);
}
return NIL;
};
PRIMITIVES["sf-define-type"] = _sfDefineTypeAdt;
registerSpecialForm("define-type", _sfDefineTypeAdt);
PRIMITIVES["make-adt-value"] = makeAdtValue;
PRIMITIVES["adt-value?"] = isAdtValue;''']
PRIMITIVES["clear-stores"] = clearStores;''']
if has_deps:
lines.append('''
// Platform deps functions (native JS, not transpiled — need explicit registration)

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")]);

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

@@ -67,14 +67,6 @@ let rec deep_equal a b =
| NativeFn _, NativeFn _ -> a == b
| _ -> false
(* ====================================================================== *)
(* Test extensions for the VM extension registry suite (Phase B) *)
(* ====================================================================== *)
(* Extend the extensible variant from sx_vm_extension.ml so the test
extensions below can carry their own private state. *)
type Sx_vm_extension.extension_state += TestRegState of int ref
(* ====================================================================== *)
(* Build evaluator environment with test platform functions *)
(* ====================================================================== *)
@@ -1287,830 +1279,10 @@ let run_foundation_tests () =
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None; l_call_count = 0; l_uid = Sx_types.next_lambda_uid () } in
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l));
Printf.printf "\nSuite: crypto-sha2\n";
(* NIST FIPS 180-4 published vectors. *)
assert_eq "sha256 empty"
(String "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
(call "crypto-sha256" [String ""]);
assert_eq "sha256 abc"
(String "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")
(call "crypto-sha256" [String "abc"]);
assert_eq "sha256 896-bit"
(String "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1")
(call "crypto-sha256"
[String "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"]);
assert_eq "sha256 1M 'a'"
(String "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0")
(call "crypto-sha256" [String (String.make 1000000 'a')]);
assert_eq "sha512 empty"
(String "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")
(call "crypto-sha512" [String ""]);
assert_eq "sha512 abc"
(String "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a2192992a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f")
(call "crypto-sha512" [String "abc"]);
assert_eq "sha512 896-bit"
(String "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909")
(call "crypto-sha512"
[String ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn"
^ "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu")]);
Printf.printf "\nSuite: crypto-sha3\n";
(* NIST FIPS 202 published vectors. *)
assert_eq "sha3-256 empty"
(String "a7ffc6f8bf1ed76651c14756a061d662f580ff4de43b49fa82d80a4b80f8434a")
(call "crypto-sha3-256" [String ""]);
assert_eq "sha3-256 abc"
(String "3a985da74fe225b2045c172d6bd390bd855f086e3e9d525b46bfe24511431532")
(call "crypto-sha3-256" [String "abc"]);
assert_eq "sha3-256 896-bit"
(String "41c0dba2a9d6240849100376a8235e2c82e1b9998a999e21db32dd97496d3376")
(call "crypto-sha3-256"
[String "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"]);
(* 1600-bit message: 0xa3 * 200 — exercises multi-block absorb (>136B). *)
assert_eq "sha3-256 1600-bit 0xa3"
(String "79f38adec5c20307a98ef76e8324afbfd46cfd81b22e3973c65fa1bd9de31787")
(call "crypto-sha3-256" [String (String.make 200 '\xa3')]);
Printf.printf "\nSuite: dag-cbor\n";
let mkdict pairs =
let d = Sx_types.make_dict () in
List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs;
Dict d
in
let enc v = call "cbor-encode" [v] in
(* RFC 8949 Appendix A — minimal-length deterministic encoding. *)
assert_eq "cbor 0" (String "\x00") (enc (Integer 0));
assert_eq "cbor 23" (String "\x17") (enc (Integer 23));
assert_eq "cbor 24" (String "\x18\x18") (enc (Integer 24));
assert_eq "cbor 100" (String "\x18\x64") (enc (Integer 100));
assert_eq "cbor 1000" (String "\x19\x03\xe8") (enc (Integer 1000));
assert_eq "cbor 1000000"
(String "\x1a\x00\x0f\x42\x40") (enc (Integer 1000000));
assert_eq "cbor -1" (String "\x20") (enc (Integer (-1)));
assert_eq "cbor -100" (String "\x38\x63") (enc (Integer (-100)));
assert_eq "cbor -1000" (String "\x39\x03\xe7") (enc (Integer (-1000)));
assert_eq "cbor false" (String "\xf4") (enc (Bool false));
assert_eq "cbor true" (String "\xf5") (enc (Bool true));
assert_eq "cbor null" (String "\xf6") (enc Nil);
assert_eq "cbor \"\"" (String "\x60") (enc (String ""));
assert_eq "cbor \"a\"" (String "\x61\x61") (enc (String "a"));
assert_eq "cbor \"IETF\"" (String "\x64IETF") (enc (String "IETF"));
assert_eq "cbor []" (String "\x80") (enc (List []));
assert_eq "cbor [1,2,3]"
(String "\x83\x01\x02\x03")
(enc (List [Integer 1; Integer 2; Integer 3]));
assert_eq "cbor [1,[2,3],[4,5]]"
(String "\x83\x01\x82\x02\x03\x82\x04\x05")
(enc (List [Integer 1;
List [Integer 2; Integer 3];
List [Integer 4; Integer 5]]));
assert_eq "cbor {}" (String "\xa0") (enc (mkdict []));
assert_eq "cbor {a:1,b:[2,3]}"
(String "\xa2\x61\x61\x01\x61\x62\x82\x02\x03")
(enc (mkdict ["a", Integer 1; "b", List [Integer 2; Integer 3]]));
assert_eq "cbor {a..e:A..E}"
(String "\xa5\x61\x61\x61\x41\x61\x62\x61\x42\x61\x63\x61\x43\x61\x64\x61\x44\x61\x65\x61\x45")
(enc (mkdict ["a", String "A"; "b", String "B"; "c", String "C";
"d", String "D"; "e", String "E"]));
(* Determinism: insertion order + key length must not change bytes.
Sort is length-then-bytewise → a, c, bb. *)
let d1 = mkdict ["bb", Integer 2; "a", Integer 1; "c", Integer 3] in
let d2 = mkdict ["c", Integer 3; "bb", Integer 2; "a", Integer 1] in
assert_eq "cbor det order-invariant" (enc d1) (enc d2);
assert_eq "cbor det length-then-bytewise"
(String "\xa3\x61\x61\x01\x61\x63\x03\x62\x62\x62\x02")
(enc d1);
(* Round-trip: decode . encode = identity (structural). *)
let roundtrip name v =
assert_eq ("cbor rt " ^ name) v (call "cbor-decode" [enc v])
in
roundtrip "int" (Integer 42);
roundtrip "neg" (Integer (-99999));
roundtrip "str" (String "hello world");
roundtrip "bool" (Bool true);
roundtrip "nil" Nil;
roundtrip "nested"
(List [Integer 1; String "x"; List [Bool false; Nil]]);
roundtrip "dict"
(mkdict ["k", List [Integer 7]; "name", String "z"]);
Printf.printf "\nSuite: cid\n";
let mh_sha256 s = Sx_cid.multihash 0x12 (Sx_cid.unhex (Sx_sha2.sha256_hex s)) in
(* Authoritative vectors (independently derived; match well-known
IPFS CIDs). raw "abc" and raw "" — codec 0x55. *)
assert_eq "cid raw abc"
(String "bafkreif2pall7dybz7vecqka3zo24irdwabwdi4wc55jznaq75q7eaavvu")
(call "cid-from-bytes" [Integer 0x55; String (mh_sha256 "abc")]);
assert_eq "cid raw empty"
(String "bafkreihdwdcefgh4dqkjv67uzcmw7ojee6xedzdetojuzjevtenxquvyku")
(call "cid-from-bytes" [Integer 0x55; String (mh_sha256 "")]);
(* dag-cbor {} — canonical empty-map CID (sha2-256, codec 0x71). *)
assert_eq "cid dag-cbor {}"
(String "bafyreigbtj4x7ip5legnfznufuopl4sg4knzc2cof6duas4b3q2fy6swua")
(call "cid-from-sx" [mkdict []]);
(* Determinism: dict key insertion order must not change the CID. *)
let cda = call "cid-from-sx" [mkdict ["b", Integer 2; "a", Integer 1]] in
let cdb = call "cid-from-sx" [mkdict ["a", Integer 1; "b", Integer 2]] in
assert_eq "cid det order-invariant" cda cdb;
assert_true "cid multibase 'b' prefix"
(Bool (match call "cid-from-sx" [mkdict []] with
| String s -> String.length s > 1 && s.[0] = 'b'
| _ -> false));
Printf.printf "\nSuite: ed25519\n";
let hx = Sx_ed25519.unhex in
let edv pk msg sg = call "ed25519-verify"
[String (hx pk); String (hx msg); String (hx sg)] in
(* RFC 8032 §7.1 TEST 1-3 (deterministic; re-derived independently). *)
assert_eq "ed25519 RFC T1"
(Bool true)
(edv "d75a980182b10ab7d54bfed3c964073a0ee172f3daa62325af021a68f707511a"
""
"e5564300c360ac729086e2cc806e828a84877f1eb8e5d974d873e065224901555fb8821590a33bacc61e39701cf9b46bd25bf5f0595bbe24655141438e7a100b");
assert_eq "ed25519 RFC T2"
(Bool true)
(edv "3d4017c3e843895a92b70aa74d1b7ebc9c982ccf2ec4968cc0cd55f12af4660c"
"72"
"92a009a9f0d4cab8720e820b5f642540a2b27b5416503f8fb3762223ebdb69da085ac1e43e15996e458f3613d0f11d8c387b2eaeb4302aeeb00d291612bb0c00");
assert_eq "ed25519 RFC T3"
(Bool true)
(edv "fc51cd8e6218a1a38da47ed00230f0580816ed13ba3303ac5deb911548908025"
"af82"
"6291d657deec24024827e69c3abe01a30ce548a284743a445e3680d7db5ac3ac18ff9b538d16f290ae67f760984dc6594a7c15e9716ed28dc027beceea1ec40a");
(* Tampered message -> false. *)
assert_eq "ed25519 tampered msg"
(Bool false)
(edv "fc51cd8e6218a1a38da47ed00230f0580816ed13ba3303ac5deb911548908025"
"af83"
"6291d657deec24024827e69c3abe01a30ce548a284743a445e3680d7db5ac3ac18ff9b538d16f290ae67f760984dc6594a7c15e9716ed28dc027beceea1ec40a");
(* Tampered signature -> false. *)
assert_eq "ed25519 tampered sig"
(Bool false)
(edv "d75a980182b10ab7d54bfed3c964073a0ee172f3daa62325af021a68f707511a"
""
"f5564300c360ac729086e2cc806e828a84877f1eb8e5d974d873e065224901555fb8821590a33bacc61e39701cf9b46bd25bf5f0595bbe24655141438e7a100b");
(* Total: wrong-length pubkey / sig -> false, no exception. *)
assert_eq "ed25519 short pubkey"
(Bool false)
(call "ed25519-verify" [String "abc"; String ""; String (String.make 64 '\000')]);
assert_eq "ed25519 short sig"
(Bool false)
(call "ed25519-verify"
[String (hx "d75a980182b10ab7d54bfed3c964073a0ee172f3daa62325af021a68f707511a");
String ""; String "short"]);
assert_eq "ed25519 non-string args"
(Bool false)
(call "ed25519-verify" [Integer 1; Integer 2; Integer 3]);
Printf.printf "\nSuite: rsa-sha256\n";
(* Fixed RSA-2048 vector: one-off python-cryptography keygen +
PKCS1v15/SHA-256 sign of "fed-sx phase F rsa test". *)
let rhx = Sx_rsa.unhex in
let spki = rhx "30820122300d06092a864886f70d01010105000382010f003082010a0282010100a117b573480bce5a08b54a98384001df26d062e9173caaee2e3a2d0045c6d16f99b2a1e7fb60763f65f95f8c39ff82c18b8590338042914331db3440a06d2dbe65a2f82c82f37d293f67a8b57a1f9014b55150a093cfee90257ef3b4a215d5ab002579bd92b6fcb3536777d51b639347d01e307ddafb209073dd9b8d6a507157c44c624a19b3b9275931472462870ae02132630159132a85c1c889adfb358b6bbd3760ce3fffe6285964833a10ee436d5bc33dfab7f9ed630a74e9a32e5688f5a7797f7cc839ad2494dd1c4c4a8fab844cd26208794bf2602c16b9d12bde434066d8c0dd2d20489f4070f883bae2b4508ead4a1b80b44c576e9e37bdb5df69f10203010001" in
let rmsg = rhx "6665642d73782070686173652046207273612074657374" in
let rsig = rhx "5e1593d674ed15c0172546d38efdf1aebd252f4b0c0dfbe1f7996fd569d0bfd9f3e8689ea2b14aa45b5fc3f0a05d4f23c6b02b8820d71f6998ea3b5b0d071bb33142236e388b1226ece3ec447d33b38999f189c37564cf052cf038de94c67b2ddf9a97d5a73554bb88818f615824517209a4083258965adace55658f344104eaa0d5f2f44ea00cfac8754674aade87b40d955cccd1ccd9b7649a08b66ce3bc5dba2de96b3e859488ded3ef9fb3744a1e3495fd14841d8319b3cc08054c729d1c02739ee314eba2b20fac46e463f47eb67183d8455583eca73ba37448164612dd9cd77877135d30d12084c2843f986a5b8ad59c6600f9855b91d7cbdf7c6c4b0e" in
let rsav s m g = call "rsa-sha256-verify" [String s; String m; String g] in
assert_eq "rsa valid" (Bool true) (rsav spki rmsg rsig);
assert_eq "rsa tampered msg" (Bool false)
(rsav spki (rmsg ^ "x") rsig);
assert_eq "rsa tampered sig" (Bool false)
(rsav spki rmsg
(rhx "5f1593d674ed15c0172546d38efdf1aebd252f4b0c0dfbe1f7996fd569d0bfd9f3e8689ea2b14aa45b5fc3f0a05d4f23c6b02b8820d71f6998ea3b5b0d071bb33142236e388b1226ece3ec447d33b38999f189c37564cf052cf038de94c67b2ddf9a97d5a73554bb88818f615824517209a4083258965adace55658f344104eaa0d5f2f44ea00cfac8754674aade87b40d955cccd1ccd9b7649a08b66ce3bc5dba2de96b3e859488ded3ef9fb3744a1e3495fd14841d8319b3cc08054c729d1c02739ee314eba2b20fac46e463f47eb67183d8455583eca73ba37448164612dd9cd77877135d30d12084c2843f986a5b8ad59c6600f9855b91d7cbdf7c6c4b0e"));
assert_eq "rsa garbage spki" (Bool false)
(rsav "not der" rmsg rsig);
assert_eq "rsa non-string args" (Bool false)
(call "rsa-sha256-verify" [Integer 1; Integer 2; Integer 3]);
Printf.printf "\nSuite: file-list-dir\n";
let expect_err nm f =
(try ignore (f ());
incr fail_count; Printf.printf " FAIL: %s — no error\n" nm
with Eval_error _ ->
incr pass_count; Printf.printf " PASS: %s\n" nm
| _ ->
incr fail_count; Printf.printf " FAIL: %s — wrong exn\n" nm)
in
let tmp = Filename.temp_file "fld" "" in
Sys.remove tmp; Unix.mkdir tmp 0o755;
let touch n = let oc = open_out (Filename.concat tmp n) in close_out oc in
touch "b.txt"; touch "a.txt"; touch "c.txt";
assert_eq "file-list-dir sorted"
(List [String "a.txt"; String "b.txt"; String "c.txt"])
(call "file-list-dir" [String tmp]);
expect_err "file-list-dir missing"
(fun () -> call "file-list-dir" [String (Filename.concat tmp "nope")]);
expect_err "file-list-dir not-a-dir"
(fun () -> call "file-list-dir" [String (Filename.concat tmp "a.txt")]);
expect_err "file-list-dir arity"
(fun () -> call "file-list-dir" []);
(* best-effort cleanup *)
(try List.iter (fun n -> Sys.remove (Filename.concat tmp n))
["a.txt"; "b.txt"; "c.txt"]; Unix.rmdir tmp
with _ -> ());
Printf.printf "\nSuite: vm-extension-dispatch\n";
let make_bc op = ({
vc_arity = 0; vc_rest_arity = -1; vc_locals = 0;
vc_bytecode = [| op |]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None;
} : Sx_types.vm_code) in
let expect_invalid_opcode label op =
let globals = Hashtbl.create 1 in
try
let _ = Sx_vm.execute_module (make_bc op) globals in
incr fail_count;
Printf.printf " FAIL: %s — expected Invalid_opcode, got a result\n" label
with
| Sx_vm.Invalid_opcode n when n = op ->
incr pass_count;
Printf.printf " PASS: %s\n" label
| exn ->
incr fail_count;
Printf.printf " FAIL: %s — unexpected: %s\n" label (Printexc.to_string exn)
in
expect_invalid_opcode "opcode 200 raises Invalid_opcode 200" 200;
expect_invalid_opcode "opcode 224 raises Invalid_opcode 224" 224;
expect_invalid_opcode "opcode 247 raises Invalid_opcode 247" 247;
(* Opcode 199 sits just below the extension threshold — should fall to the
catch-all (Eval_error), proving the threshold is at 200, not 199. *)
let globals = Hashtbl.create 1 in
(try
let _ = Sx_vm.execute_module (make_bc 199) globals in
incr fail_count;
Printf.printf " FAIL: opcode 199 — expected Eval_error, got a result\n"
with
| Sx_vm.Invalid_opcode _ ->
incr fail_count;
Printf.printf " FAIL: opcode 199 routed to extension dispatch (threshold wrong)\n"
| Sx_types.Eval_error _ ->
incr pass_count;
Printf.printf " PASS: opcode 199 stays in core (catch-all)\n"
| exn ->
incr fail_count;
Printf.printf " FAIL: opcode 199 — unexpected: %s\n" (Printexc.to_string exn));
Printf.printf "\nSuite: vm-extension-registry\n";
(* Sx_vm_extensions self-installs its dispatcher at module init. Reset
the registry so prior loaded extensions don't interfere with this
test. *)
Sx_vm_extensions._reset_for_tests ();
let module TestExt : Sx_vm_extension.EXTENSION = struct
let name = "test_reg"
let init () = TestRegState (ref 0)
let opcodes _st = [
(210, "test_reg.OP_PUSH_42", (fun vm _frame ->
Sx_vm.push vm (Sx_types.Integer 42)));
(211, "test_reg.OP_DOUBLE_TOS", (fun vm _frame ->
let v = Sx_vm.pop vm in
match v with
| Sx_types.Integer n -> Sx_vm.push vm (Sx_types.Integer (n * 2))
| _ -> failwith "OP_DOUBLE_TOS: not an integer"));
]
end in
Sx_vm_extensions.register (module TestExt);
(match Sx_vm_extensions.id_of_name "test_reg.OP_PUSH_42" with
| Some 210 ->
incr pass_count;
Printf.printf " PASS: id_of_name resolves opcode\n"
| other ->
incr fail_count;
Printf.printf " FAIL: id_of_name: got %s\n"
(match other with Some n -> string_of_int n | None -> "None"));
(match Sx_vm_extensions.id_of_name "nonexistent.OP" with
| None ->
incr pass_count;
Printf.printf " PASS: id_of_name returns None for unknown\n"
| Some _ ->
incr fail_count;
Printf.printf " FAIL: id_of_name should return None for unknown\n");
(match Sx_vm_extensions.state_of_extension "test_reg" with
| Some (TestRegState _) ->
incr pass_count;
Printf.printf " PASS: state_of_extension returns extension state\n"
| _ ->
incr fail_count;
Printf.printf " FAIL: state_of_extension lookup\n");
(match Sx_vm_extensions.state_of_extension "nonexistent" with
| None ->
incr pass_count;
Printf.printf " PASS: state_of_extension None for unknown\n"
| Some _ ->
incr fail_count;
Printf.printf " FAIL: state_of_extension should be None\n");
(* End-to-end dispatch through the VM. Bytecode runs OP_PUSH_42 then
OP_RETURN (50); execute_module pops the result. *)
let make_bc_seq bytes = ({
vc_arity = 0; vc_rest_arity = -1; vc_locals = 0;
vc_bytecode = bytes; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None;
} : Sx_types.vm_code) in
(let globals = Hashtbl.create 1 in
try
match Sx_vm.execute_module (make_bc_seq [| 210; 50 |]) globals with
| Integer 42 ->
incr pass_count;
Printf.printf " PASS: dispatch routes opcode 210 -> push 42\n"
| other ->
incr fail_count;
Printf.printf " FAIL: dispatch opcode 210: got %s\n"
(Sx_types.inspect other)
with exn ->
incr fail_count;
Printf.printf " FAIL: dispatch opcode 210 raised: %s\n"
(Printexc.to_string exn));
(* Compose two extension opcodes: PUSH_42 then DOUBLE_TOS then RETURN.
Verifies that successive extension dispatches share VM state. *)
(let globals = Hashtbl.create 1 in
try
match Sx_vm.execute_module (make_bc_seq [| 210; 211; 50 |]) globals with
| Integer 84 ->
incr pass_count;
Printf.printf " PASS: extension opcodes compose (42 -> 84)\n"
| other ->
incr fail_count;
Printf.printf " FAIL: composed opcodes: got %s\n"
(Sx_types.inspect other)
with exn ->
incr fail_count;
Printf.printf " FAIL: composed opcodes raised: %s\n"
(Printexc.to_string exn));
(* Duplicate opcode-id detection. *)
let module DupExt : Sx_vm_extension.EXTENSION = struct
let name = "dup_check"
let init () = TestRegState (ref 0)
let opcodes _st = [
(210, "dup_check.OP_X", (fun _vm _frame -> ()));
]
end in
(try
Sx_vm_extensions.register (module DupExt);
incr fail_count;
Printf.printf " FAIL: duplicate opcode id should have raised\n"
with Failure _ ->
incr pass_count;
Printf.printf " PASS: duplicate opcode id rejected\n");
(* Out-of-range opcode-id detection. *)
let module OutExt : Sx_vm_extension.EXTENSION = struct
let name = "out_of_range"
let init () = TestRegState (ref 0)
let opcodes _st = [
(300, "out_of_range.OP_X", (fun _vm _frame -> ()));
]
end in
(try
Sx_vm_extensions.register (module OutExt);
incr fail_count;
Printf.printf " FAIL: out-of-range opcode should have raised\n"
with Failure _ ->
incr pass_count;
Printf.printf " PASS: out-of-range opcode rejected\n");
(* Duplicate extension-name detection. *)
let module SameNameExt : Sx_vm_extension.EXTENSION = struct
let name = "test_reg" (* same as TestExt above *)
let init () = TestRegState (ref 0)
let opcodes _st = []
end in
(try
Sx_vm_extensions.register (module SameNameExt);
incr fail_count;
Printf.printf " FAIL: duplicate extension name should have raised\n"
with Failure _ ->
incr pass_count;
Printf.printf " PASS: duplicate extension name rejected\n");
Printf.printf "\nSuite: extension-opcode-id primitive\n";
let prim = Hashtbl.find Sx_primitives.primitives "extension-opcode-id" in
(* Known opcode (registered by TestExt above). *)
(match prim [String "test_reg.OP_PUSH_42"] with
| Integer 210 ->
incr pass_count;
Printf.printf " PASS: primitive returns Integer for registered opcode\n"
| other ->
incr fail_count;
Printf.printf " FAIL: registered opcode lookup: got %s\n"
(Sx_types.inspect other));
(* Unknown opcode → Nil. *)
(match prim [String "nonexistent.OP_X"] with
| Nil ->
incr pass_count;
Printf.printf " PASS: primitive returns nil for unknown opcode\n"
| other ->
incr fail_count;
Printf.printf " FAIL: unknown opcode lookup: got %s\n"
(Sx_types.inspect other));
(* Symbol arg also accepted (compilers may pass quoted symbols). *)
(match prim [Symbol "test_reg.OP_DOUBLE_TOS"] with
| Integer 211 ->
incr pass_count;
Printf.printf " PASS: primitive accepts Symbol args\n"
| other ->
incr fail_count;
Printf.printf " FAIL: symbol arg: got %s\n" (Sx_types.inspect other));
(* Wrong arity / type raises Eval_error. *)
(try
let _ = prim [] in
incr fail_count;
Printf.printf " FAIL: zero args should have raised\n"
with Sx_types.Eval_error _ ->
incr pass_count;
Printf.printf " PASS: zero args rejected\n");
(try
let _ = prim [Integer 42] in
incr fail_count;
Printf.printf " FAIL: integer arg should have raised\n"
with Sx_types.Eval_error _ ->
incr pass_count;
Printf.printf " PASS: integer arg rejected\n");
Printf.printf "\nSuite: extensions/test_ext (canonical extension)\n";
(* Phase D: the real test extension lives at lib/extensions/test_ext.ml.
Register it on top of the inline test_reg from earlier suites — the
two use disjoint opcode IDs (210/211 vs 220/221) so they coexist. *)
Test_ext.register ();
(* Lookup via the public primitive should now find OP_TEST_PUSH_42. *)
(match prim [String "test_ext.OP_TEST_PUSH_42"] with
| Integer 220 ->
incr pass_count;
Printf.printf " PASS: extension-opcode-id finds test_ext.OP_TEST_PUSH_42\n"
| other ->
incr fail_count;
Printf.printf " FAIL: opcode lookup: got %s\n" (Sx_types.inspect other));
(* End-to-end: PUSH_42 + DOUBLE_TOS + RETURN. *)
(let globals = Hashtbl.create 1 in
try
match Sx_vm.execute_module (make_bc_seq [| 220; 221; 50 |]) globals with
| Integer 84 ->
incr pass_count;
Printf.printf " PASS: extensions/test_ext bytecode executes (84)\n"
| other ->
incr fail_count;
Printf.printf " FAIL: test_ext bytecode result: got %s\n"
(Sx_types.inspect other)
with exn ->
incr fail_count;
Printf.printf " FAIL: test_ext bytecode raised: %s\n"
(Printexc.to_string exn));
(* Disassembly: opcode_name should resolve 220/221 via the registry,
not fall back to UNKNOWN_220 / UNKNOWN_221. disassemble returns a
Dict; the instruction list lives at key "bytecode". *)
(let code = make_bc_seq [| 220; 221; 50 |] in
let dis = Sx_vm.disassemble code in
let entries = match dis with
| Dict d -> (match Hashtbl.find_opt d "bytecode" with
| Some (List es) -> es
| _ -> [])
| _ -> []
in
let names = List.filter_map (fun entry -> match entry with
| Dict d ->
(match Hashtbl.find_opt d "opcode" with
| Some (String name) -> Some name
| _ -> None)
| _ -> None) entries
in
let has name = List.mem name names in
if has "test_ext.OP_TEST_PUSH_42" && has "test_ext.OP_TEST_DOUBLE_TOS" then begin
incr pass_count;
Printf.printf " PASS: disassemble shows extension opcode names\n"
end else begin
incr fail_count;
Printf.printf " FAIL: disassemble names: [%s]\n" (String.concat ", " names)
end);
(* Sanity: opcode_name on an unregistered extension opcode still
returns UNKNOWN_n. Pick 230 — out of test_ext's range. *)
(match Sx_vm.opcode_name 230 with
| "UNKNOWN_230" ->
incr pass_count;
Printf.printf " PASS: unregistered ext opcode falls back to UNKNOWN_n\n"
| other ->
incr fail_count;
Printf.printf " FAIL: opcode_name 230: got %s\n" other);
(* Per-extension state: invocation_count should reflect the two opcodes
that ran in the dispatch test above. *)
(match Test_ext.invocation_count () with
| Some n when n >= 2 ->
incr pass_count;
Printf.printf " PASS: extension state recorded %d invocations\n" n
| other ->
incr fail_count;
Printf.printf " FAIL: invocation_count: %s\n"
(match other with Some n -> string_of_int n | None -> "None"));
Printf.printf "\nSuite: extensions/erlang_ext (Phase 9h)\n";
(* Register the Erlang opcode namespace. Disjoint id range (200-217)
from test_ext (220/221) so they coexist. *)
Erlang_ext.register ();
(match prim [String "erlang.OP_PATTERN_TUPLE"] with
| Integer 222 ->
incr pass_count;
Printf.printf " PASS: extension-opcode-id erlang.OP_PATTERN_TUPLE = 222\n"
| other ->
incr fail_count;
Printf.printf " FAIL: erlang.OP_PATTERN_TUPLE: got %s\n"
(Sx_types.inspect other));
(match prim [String "erlang.OP_BIF_IS_TUPLE"] with
| Integer 239 ->
incr pass_count;
Printf.printf " PASS: extension-opcode-id erlang.OP_BIF_IS_TUPLE = 239\n"
| other ->
incr fail_count;
Printf.printf " FAIL: erlang.OP_BIF_IS_TUPLE: got %s\n"
(Sx_types.inspect other));
(match prim [String "erlang.OP_NONEXISTENT"] with
| Nil ->
incr pass_count;
Printf.printf " PASS: unknown erlang opcode -> nil\n"
| other ->
incr fail_count;
Printf.printf " FAIL: unknown erlang opcode: got %s\n"
(Sx_types.inspect other));
(* Phase 10b vertical slice: erlang.OP_BIF_LENGTH (230) is a REAL
handler. Build [CONST 0; OP_BIF_LENGTH; RETURN] with an Erlang
list [1,2,3] in the constant pool; expect Integer 3. Proves the
full path: bytecode -> Sx_vm extension fallthrough -> erlang_ext
handler -> correct stack result. *)
(let mk_dict kvs =
let h = Hashtbl.create 4 in
List.iter (fun (k, v) -> Hashtbl.replace h k v) kvs;
Sx_types.Dict h in
let er_nil = mk_dict [("tag", Sx_types.String "nil")] in
let er_cons hd tl =
mk_dict [("tag", Sx_types.String "cons");
("head", hd); ("tail", tl)] in
let lst = er_cons (Sx_types.Integer 1)
(er_cons (Sx_types.Integer 2)
(er_cons (Sx_types.Integer 3) er_nil)) in
let code = ({
vc_arity = 0; vc_rest_arity = -1; vc_locals = 0;
vc_bytecode = [| 1; 0; 0; 230; 50 |];
vc_constants = [| lst |];
vc_bytecode_list = None; vc_constants_list = None;
} : Sx_types.vm_code) in
let globals = Hashtbl.create 1 in
try
match Sx_vm.execute_module code globals with
| Integer 3 ->
incr pass_count;
Printf.printf " PASS: erlang.OP_BIF_LENGTH [1,2,3] -> 3 (real handler, end-to-end)\n"
| other ->
incr fail_count;
Printf.printf " FAIL: OP_BIF_LENGTH result: got %s\n"
(Sx_types.inspect other)
with exn ->
incr fail_count;
Printf.printf " FAIL: OP_BIF_LENGTH raised: %s\n"
(Printexc.to_string exn));
(* More real handlers (Phase 10b batch): build a list/tuple constant
and exercise HD/TL/TUPLE_SIZE/IS_* end-to-end through the VM. *)
(let mk_dict kvs =
let h = Hashtbl.create 4 in
List.iter (fun (k, v) -> Hashtbl.replace h k v) kvs;
Sx_types.Dict h in
let er_nil = mk_dict [("tag", Sx_types.String "nil")] in
let er_cons hd tl = mk_dict [("tag", Sx_types.String "cons");
("head", hd); ("tail", tl)] in
let er_tuple es = mk_dict [("tag", Sx_types.String "tuple");
("elements", Sx_types.List es)] in
let er_atom nm = mk_dict [("tag", Sx_types.String "atom");
("name", Sx_types.String nm)] in
let lst3 = er_cons (Sx_types.Integer 7)
(er_cons (Sx_types.Integer 8)
(er_cons (Sx_types.Integer 9) er_nil)) in
let tup3 = er_tuple [Sx_types.Integer 1; Sx_types.Integer 2;
Sx_types.Integer 3] in
let run consts bc =
let code = ({
vc_arity = 0; vc_rest_arity = -1; vc_locals = 0;
vc_bytecode = bc; vc_constants = consts;
vc_bytecode_list = None; vc_constants_list = None;
} : Sx_types.vm_code) in
Sx_vm.execute_module code (Hashtbl.create 1) in
let nm = function
| Sx_types.Dict d ->
(match Hashtbl.find_opt d "name" with
| Some (Sx_types.String s) -> s | _ -> "?")
| _ -> "?" in
let check label want got =
if got = want then begin
incr pass_count;
Printf.printf " PASS: %s\n" label
end else begin
incr fail_count;
Printf.printf " FAIL: %s: got %s\n" label (Sx_types.inspect got)
end in
(* HD [7,8,9] -> 7 *)
check "OP_BIF_HD [7,8,9] -> 7" (Sx_types.Integer 7)
(run [| lst3 |] [| 1;0;0; 231; 50 |]);
(* TL [7,8,9] -> [8,9], check its HD = 8 *)
check "OP_BIF_TL then HD -> 8" (Sx_types.Integer 8)
(run [| lst3 |] [| 1;0;0; 232; 231; 50 |]);
(* TUPLE_SIZE {1,2,3} -> 3 *)
check "OP_BIF_TUPLE_SIZE {1,2,3} -> 3" (Sx_types.Integer 3)
(run [| tup3 |] [| 1;0;0; 234; 50 |]);
(* IS_INTEGER 42 -> true ; IS_INTEGER [..] -> false *)
(match run [| Sx_types.Integer 42 |] [| 1;0;0; 236; 50 |] with
| v when nm v = "true" ->
incr pass_count; Printf.printf " PASS: OP_BIF_IS_INTEGER 42 -> true\n"
| v -> incr fail_count;
Printf.printf " FAIL: IS_INTEGER 42: got %s\n" (Sx_types.inspect v));
(match run [| lst3 |] [| 1;0;0; 236; 50 |] with
| v when nm v = "false" ->
incr pass_count; Printf.printf " PASS: OP_BIF_IS_INTEGER list -> false\n"
| v -> incr fail_count;
Printf.printf " FAIL: IS_INTEGER list: got %s\n" (Sx_types.inspect v));
(* IS_ATOM atom -> true ; IS_LIST nil -> true ; IS_TUPLE tuple -> true *)
(match run [| er_atom "ok" |] [| 1;0;0; 237; 50 |] with
| v when nm v = "true" ->
incr pass_count; Printf.printf " PASS: OP_BIF_IS_ATOM ok -> true\n"
| v -> incr fail_count;
Printf.printf " FAIL: IS_ATOM: got %s\n" (Sx_types.inspect v));
(match run [| er_nil |] [| 1;0;0; 238; 50 |] with
| v when nm v = "true" ->
incr pass_count; Printf.printf " PASS: OP_BIF_IS_LIST nil -> true\n"
| v -> incr fail_count;
Printf.printf " FAIL: IS_LIST nil: got %s\n" (Sx_types.inspect v));
(match run [| tup3 |] [| 1;0;0; 239; 50 |] with
| v when nm v = "true" ->
incr pass_count; Printf.printf " PASS: OP_BIF_IS_TUPLE {..} -> true\n"
| v -> incr fail_count;
Printf.printf " FAIL: IS_TUPLE: got %s\n" (Sx_types.inspect v));
(match run [| tup3 |] [| 1;0;0; 238; 50 |] with
| v when nm v = "false" ->
incr pass_count; Printf.printf " PASS: OP_BIF_IS_LIST tuple -> false\n"
| v -> incr fail_count;
Printf.printf " FAIL: IS_LIST tuple: got %s\n" (Sx_types.inspect v));
(* ELEMENT: element(2, {1,2,3}) -> 2. Calling convention: push
Index then Tuple; opcode pops Tuple (TOS) then Index. *)
check "OP_BIF_ELEMENT element(2,{1,2,3}) -> 2" (Sx_types.Integer 2)
(run [| Sx_types.Integer 2; tup3 |] [| 1;0;0; 1;1;0; 233; 50 |]);
check "OP_BIF_ELEMENT element(1,{1,2,3}) -> 1" (Sx_types.Integer 1)
(run [| Sx_types.Integer 1; tup3 |] [| 1;0;0; 1;1;0; 233; 50 |]);
(* ELEMENT out of range raises *)
(let raised =
(try ignore (run [| Sx_types.Integer 9; tup3 |]
[| 1;0;0; 1;1;0; 233; 50 |]); false
with Sx_types.Eval_error _ -> true) in
if raised then begin
incr pass_count;
Printf.printf " PASS: OP_BIF_ELEMENT out-of-range raises\n"
end else begin
incr fail_count;
Printf.printf " FAIL: OP_BIF_ELEMENT out-of-range should raise\n"
end);
(* LISTS_REVERSE [7,8,9] -> [9,8,7]; verify HD = 9 then HD of TL = 8 *)
check "OP_BIF_LISTS_REVERSE then HD -> 9" (Sx_types.Integer 9)
(run [| lst3 |] [| 1;0;0; 235; 231; 50 |]);
check "OP_BIF_LISTS_REVERSE then TL,HD -> 8" (Sx_types.Integer 8)
(run [| lst3 |] [| 1;0;0; 235; 232; 231; 50 |]);
(* reverse preserves length *)
check "OP_BIF_LISTS_REVERSE then LENGTH -> 3" (Sx_types.Integer 3)
(run [| lst3 |] [| 1;0;0; 235; 230; 50 |]));
(* A still-stubbed opcode (222 = erlang.OP_PATTERN_TUPLE) raises the
not-wired Eval_error — confirms the honest-failure path remains
for opcodes whose real handlers haven't landed. *)
(let globals = Hashtbl.create 1 in
try
ignore (Sx_vm.execute_module (make_bc_seq [| 222; 50 |]) globals);
incr fail_count;
Printf.printf " FAIL: erlang.OP_PATTERN_TUPLE dispatch should have raised\n"
with
| Sx_types.Eval_error msg
when (let needle = "not yet wired" in
let nl = String.length needle and ml = String.length msg in
let rec scan i =
if i + nl > ml then false
else if String.sub msg i nl = needle then true
else scan (i + 1)
in scan 0) ->
incr pass_count;
Printf.printf " PASS: erlang opcode dispatch raises not-wired error\n"
| exn ->
incr fail_count;
Printf.printf " FAIL: unexpected exn: %s\n" (Printexc.to_string exn));
(match Erlang_ext.dispatch_count () with
| Some n when n >= 1 ->
incr pass_count;
Printf.printf " PASS: erlang_ext state recorded %d dispatch(es)\n" n
| other ->
incr fail_count;
Printf.printf " FAIL: dispatch_count: %s\n"
(match other with Some n -> string_of_int n | None -> "None"));
Printf.printf "\nSuite: jit extension-opcode awareness\n";
let scan = Sx_vm.bytecode_uses_extension_opcodes in
let no_consts = [||] in
(* Pure core ops: scan reports false. *)
(* OP_TRUE OP_RETURN *)
if not (scan [| 3; 50 |] no_consts) then begin
incr pass_count;
Printf.printf " PASS: pure core bytecode is JIT-eligible\n"
end else begin
incr fail_count;
Printf.printf " FAIL: pure core bytecode flagged as extension\n"
end;
(* Extension opcode anywhere → true. *)
if scan [| 220; 50 |] no_consts then begin
incr pass_count;
Printf.printf " PASS: extension opcode detected at head\n"
end else begin
incr fail_count;
Printf.printf " FAIL: extension opcode at head missed\n"
end;
(* Mixed: core + extension → true. *)
if scan [| 3; 220; 50 |] no_consts then begin
incr pass_count;
Printf.printf " PASS: extension opcode detected after core ops\n"
end else begin
incr fail_count;
Printf.printf " FAIL: extension opcode after core ops missed\n"
end;
(* Operand bytes ≥200 must NOT trigger. CONST u16 with index 220
into a synthetic constant pool — the operand is 220 (lo) 0 (hi),
not an opcode. The pool entry at 220 is irrelevant for the scan. *)
let big_consts = Array.make 256 Nil in
if not (scan [| 1; 220; 0; 50 |] big_consts) then begin
incr pass_count;
Printf.printf " PASS: CONST operand ≥200 not a false positive\n"
end else begin
incr fail_count;
Printf.printf " FAIL: CONST operand ≥200 false-positives as ext op\n"
end;
(* CALL_PRIM has 3 operand bytes (u16 + u8); all ≥200 should not
trigger. *)
if not (scan [| 52; 220; 200; 200; 50 |] big_consts) then begin
incr pass_count;
Printf.printf " PASS: CALL_PRIM operands ≥200 not a false positive\n"
end else begin
incr fail_count;
Printf.printf " FAIL: CALL_PRIM operands ≥200 false-positive\n"
end;
(* CLOSURE with upvalue descriptors: scan must skip the 2 + 2*n
dynamic operand bytes. Build a synthetic constant pool with a
Dict at index 0 declaring upvalue-count 1, descriptors that are
≥200 — the scan should skip them and not trigger.
Bytecode layout: CLOSURE 0 0 desc_is_local desc_index RETURN
op lo hi 210 220 50
With upvalue-count = 1, scan must advance past the 2-byte CLOSURE
operand AND the 2 descriptor bytes (210, 220), landing on RETURN. *)
let cl_consts = Array.make 1 Nil in
let dict = Hashtbl.create 1 in
Hashtbl.replace dict "upvalue-count" (Integer 1);
cl_consts.(0) <- Dict dict;
if not (scan [| 51; 0; 0; 210; 220; 50 |] cl_consts) then begin
incr pass_count;
Printf.printf " PASS: CLOSURE upvalue descriptors ≥200 skipped\n"
end else begin
incr fail_count;
Printf.printf " FAIL: CLOSURE upvalue descriptors false-positive\n"
end;
(* Sanity: opcode after CLOSURE+descriptors that IS an extension
opcode triggers correctly. *)
if scan [| 51; 0; 0; 210; 220; 221; 50 |] cl_consts then begin
incr pass_count;
Printf.printf " PASS: extension opcode after CLOSURE detected\n"
end else begin
incr fail_count;
Printf.printf " FAIL: extension opcode after CLOSURE missed\n"
end
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))
(* ====================================================================== *)
@@ -3727,9 +2899,6 @@ let run_spec_tests env test_files =
load_module "parser.sx" hs_dir;
load_module "compiler.sx" hs_dir;
load_module "runtime.sx" hs_dir;
let hs_plugins_dir = Filename.concat hs_dir "plugins" in
load_module "worker.sx" hs_plugins_dir;
load_module "prolog.sx" hs_plugins_dir;
load_module "integration.sx" hs_dir;
load_module "htmx.sx" hs_dir;
(* Override console-log to avoid str on circular mock DOM refs *)

358
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 *)
(* ====================================================================== *)
@@ -571,12 +557,9 @@ and cek_run_with_io state =
Hashtbl.replace d "descent" (Number desc);
Dict d
| _ ->
let argsv = Sx_runtime.get_val request (String "args") in
(match Sx_persist_store.handle_op op argsv with
| Some resp -> resp
| None ->
let args = (match argsv with List l -> l | _ -> [argsv]) in
io_request op args)
let args = let a = Sx_runtime.get_val request (String "args") in
(match a with List l -> l | _ -> [a]) in
io_request op args
in
s := Sx_ref.cek_resume !s response;
loop ()
@@ -720,302 +703,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)"));
(* fed-sx Milestone 1 client direction (Phase J). NATIVE ONLY —
Unix sockets + DNS; absent from the WASM kernel. HTTP/1.1
request: TCP connect, write request line + headers + body,
read status + headers + body, return {:status :headers :body}.
URL must be http://...; HTTPS is a later phase (needs TLS).
Body read: Content-Length first, else read to EOF (we send
Connection: close). Transfer-Encoding: chunked is rejected —
fed-sx Phase 8 wires this for inter-server POSTs which will
all carry Content-Length. *)
Sx_primitives.register "http-request" (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
| [String meth; String url; headers_v; body_v] ->
let body = match body_v with
| String s -> s
| Nil -> ""
| v -> Sx_types.value_to_string v in
let prefix = "http://" in
let plen = String.length prefix in
let ulen = String.length url in
if ulen < plen || String.sub url 0 plen <> prefix
then raise (Eval_error "http-request: URL must start with http://");
let rest = String.sub url plen (ulen - plen) in
let host_port, path =
match String.index_opt rest '/' with
| Some i ->
String.sub rest 0 i,
String.sub rest i (String.length rest - i)
| None -> rest, "/" in
if host_port = "" then
raise (Eval_error "http-request: missing host");
let host, port =
match String.index_opt host_port ':' with
| Some i ->
let h = String.sub host_port 0 i in
let ps = String.sub host_port (i + 1)
(String.length host_port - i - 1) in
(h,
(try int_of_string ps with _ ->
raise (Eval_error "http-request: bad port")))
| None -> host_port, 80 in
let addr =
(try (Unix.gethostbyname host).h_addr_list.(0)
with Not_found ->
raise (Eval_error ("http-request: dns: " ^ host))) in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
let cleanup () = try Unix.close sock with _ -> () in
let result =
(try
(try Unix.connect sock (Unix.ADDR_INET (addr, port))
with Unix.Unix_error (e, _, _) ->
raise (Eval_error
("http-request: connect: " ^ Unix.error_message e)));
let oc = Unix.out_channel_of_descr sock in
let ic = Unix.in_channel_of_descr sock in
let buf = Buffer.create 256 in
Buffer.add_string buf
(Printf.sprintf "%s %s HTTP/1.1\r\n" meth path);
let host_hdr_sent = ref false in
let clen_sent = ref false in
let conn_sent = ref false in
(match headers_v with
| Dict h ->
Hashtbl.iter (fun k v ->
let kl = String.lowercase_ascii k in
if kl = "host" then host_hdr_sent := true;
if kl = "content-length" then clen_sent := true;
if kl = "connection" then conn_sent := true;
let vs = match v with
| String s -> s
| x -> Sx_types.value_to_string x in
Buffer.add_string buf
(Printf.sprintf "%s: %s\r\n" k vs)) h
| Nil -> ()
| _ -> raise (Eval_error "http-request: headers must be dict"));
if not !host_hdr_sent then
Buffer.add_string buf
(Printf.sprintf "Host: %s\r\n" host_port);
if not !clen_sent then
Buffer.add_string buf
(Printf.sprintf "Content-Length: %d\r\n"
(String.length body));
if not !conn_sent then
Buffer.add_string buf "Connection: close\r\n";
Buffer.add_string buf "\r\n";
Buffer.add_string buf body;
output_string oc (Buffer.contents buf);
flush oc;
let sl =
(try strip_cr (input_line ic)
with End_of_file ->
raise (Eval_error
"http-request: connection closed before status")) in
let status =
match String.split_on_char ' ' sl with
| _ver :: code :: _ ->
(try int_of_string code with _ ->
raise (Eval_error "http-request: bad status code"))
| _ -> raise (Eval_error "http-request: bad status line") in
let rhdrs = Sx_types.make_dict () in
let clen = ref (-1) in
let chunked = ref false in
let rec rdh () =
let h =
(try strip_cr (input_line ic)
with End_of_file -> "") 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 rhdrs name (String value);
if name = "content-length" then
(try clen := int_of_string value with _ -> ())
else if name = "transfer-encoding" &&
String.lowercase_ascii value = "chunked"
then chunked := true
| None -> ());
rdh ()
end in
rdh ();
if !chunked then
raise (Eval_error
"http-request: chunked transfer-encoding not supported");
let rbody =
if !clen >= 0 then begin
let b = Bytes.create !clen in
really_input ic b 0 !clen;
Bytes.unsafe_to_string b
end else begin
let b = Buffer.create 256 in
(try
while true do
Buffer.add_channel b ic 4096
done; assert false
with End_of_file -> ());
Buffer.contents b
end in
let resp = Sx_types.make_dict () in
Hashtbl.replace resp "status" (Integer status);
Hashtbl.replace resp "headers" (Dict rhdrs);
Hashtbl.replace resp "body" (String rbody);
Dict resp
with e -> cleanup (); raise e) in
cleanup ();
result
| _ -> raise (Eval_error "http-request: (method url headers body)"));
bind "trampoline" (fun args ->
match args with
| [v] ->
@@ -1077,13 +764,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 =
@@ -1269,24 +950,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) ---- *)
@@ -1701,12 +1365,7 @@ let rec dispatch env cmd =
| Some path -> load_library_file path | None -> ());
Nil
end
end else
(* durable-storage ops: service against on-disk store *)
let args = Sx_runtime.get_val request (String "args") in
(match Sx_persist_store.handle_op op args with
| Some resp -> resp
| None -> Nil (* non-import IO: resume with nil *)) in
end else Nil (* non-import IO: resume with nil *) in
s := Sx_ref.cek_resume !s response
done;
Sx_ref.cek_value !s
@@ -4059,10 +3718,7 @@ let http_mode port =
Dict d
| "io-sleep" | "sleep" -> Nil
| "import" -> Nil
| _ ->
(match Sx_persist_store.handle_op op args with
| Some resp -> resp
| None -> Nil));
| _ -> Nil);
(* Response cache — path → full HTTP response string.
Populated during pre-warm, serves cached responses in <0.1ms.
Thread-safe: reads are lock-free (Hashtbl.find_opt is atomic for

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 ]

80
hosts/ocaml/bin/test_http_client.sh
View File

@@ -1,80 +0,0 @@
#!/usr/bin/env bash
# Phase J test — native-only http-request client primitive.
# Reuses Phase H's http-listen to spin up an echo server, then drives
# a separate sx_server via the epoch protocol to issue http-request
# calls and assert response shape + headers + body.
set -u
cd "$(dirname "$0")/.."
SRV=_build/default/bin/sx_server.exe
PORT=${HTTP_CLIENT_TEST_PORT:-8921}
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
# /echo echoes method/path/query/body and reflects request X-Custom
# back as response X-Got; /missing-test → 404.
H='(begin (define (h req) (if (= (get req "path") "/echo") {:status 200 :headers {"X-Echo" (get req "method") "X-Got" (get (get req "headers") "x-custom")} :body (str "M=" (get req "method") " P=" (get req "path") " Q=" (get req "query") " B=" (get req "body"))} (if (= (get req "path") "/missing-test") {:status 404 :body "nope"} {:status 500 :body "err"}))) (http-listen '"$PORT"' h))'
ESC=${H//\"/\\\"}
{ printf '(epoch 1)\n(eval "%s")\n' "$ESC"; sleep 60; } | "$SRV" >/tmp/test_http_client_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_client_srv.out; exit 1; }
emit() {
# $1 = epoch num, $2 = raw SX form. Wraps in (eval "...") with quotes escaped.
local esc=${2//\"/\\\"}
printf '(epoch %s)\n(eval "%s")\n' "$1" "$esc"
}
DRV_OUT=/tmp/test_http_client_drv.out
{
emit 1 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo?x=1" {} ""))) (str "S=" (get r "status") " E=" (get (get r "headers") "x-echo") " B=" (get r "body")))'
emit 2 '(let ((r (http-request "POST" "http://127.0.0.1:'"$PORT"'/echo" {} "hello"))) (str "S=" (get r "status") " B=" (get r "body")))'
emit 3 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/missing-test" {} ""))) (str "S=" (get r "status") " B=" (get r "body")))'
emit 4 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {"X-Custom" "myval"} ""))) (get (get r "headers") "x-got"))'
emit 5 '(http-request "GET" "ftp://nope" {} "")'
emit 6 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {} ""))) (get r "status"))'
} | "$SRV" >"$DRV_OUT" 2>&1
# eval results come back as (ok-len N L)\n<body>\n — grep the body content.
grep -q '^"S=200 E=GET B=M=GET P=/echo Q=x=1 B="$' "$DRV_OUT" \
&& ok "GET status + echo header + body" \
|| bad "GET" "$(grep -A1 '^(ok-len 1 ' "$DRV_OUT" | tail -1)"
grep -q '^"S=200 B=M=POST P=/echo Q= B=hello"$' "$DRV_OUT" \
&& ok "POST body roundtrip" \
|| bad "POST" "$(grep -A1 '^(ok-len 2 ' "$DRV_OUT" | tail -1)"
grep -q '^"S=404 B=nope"$' "$DRV_OUT" \
&& ok "404 status + body" \
|| bad "404" "$(grep -A1 '^(ok-len 3 ' "$DRV_OUT" | tail -1)"
grep -q '^"myval"$' "$DRV_OUT" \
&& ok "custom request header reaches server" \
|| bad "custom-header" "$(grep -A1 '^(ok-len 4 ' "$DRV_OUT" | tail -1)"
R5=$(grep '^(error 5 ' "$DRV_OUT" | head -1)
echo "$R5" | grep -q 'URL must start with http' \
&& ok "non-http scheme rejected" \
|| bad "bad-url" "$R5"
# Status is an Integer (200), serialized bare without quotes.
grep -q '^200$' "$DRV_OUT" \
&& ok "response status is integer 200" \
|| bad "status-integer" "$(grep -A1 '^(ok-len 6 ' "$DRV_OUT" | tail -1)"
echo "Results: $PASS passed, $FAIL failed"
[ "$FAIL" = 0 ]

22
hosts/ocaml/bootstrap.py
View File

@@ -82,10 +82,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;
@@ -311,23 +308,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)

293
hosts/ocaml/lib/sx_persist_store.ml
View File

@@ -1,293 +0,0 @@
(* sx_persist_store — host durable-storage adapter for lib/persist.
Production twin of `persist/serve` (lib/persist/durable.sx): it answers the
same `persist/...` IO ops, but backs them with real on-disk storage so writes
survive a process restart. Stateless-on-disk: every op reads/writes the
filesystem directly, so a fresh process recovers state with no warm-up — the
log on disk IS the state.
On-disk layout under the root dir (default ./persist-data, or $SX_PERSIST_DIR):
streams/<hex(stream)>.log append-only, one SX-serialized event per line
streams/<hex(stream)>.seq per-stream monotonic high-water counter (int)
kv/<hex(key)> one SX-serialized value per key
Invariants honoured (see plans/persist-on-sx.md Blocker spec):
1. last-seq is a per-stream monotonic counter stored in .seq, SEPARATE from
the rows — it keeps climbing across truncate, so a compacted stream never
reassigns a seq.
2. append never renumbers — the event already carries its :seq (log.sx does
last-seq+1); the host only bumps the high-water mark to max(hw, seq).
3. read returns surviving events in append order with :seq intact.
4. streams is the set of streams that ever had an append — keyed off the .seq
file, which truncate never deletes, so it survives full compaction.
5. values round-trip structurally via the SX serializer/parser. *)
open Sx_types
(* ---- root dir ---------------------------------------------------------- *)
let _root : string option ref = ref None
let set_root dir = _root := Some dir
let root_dir () =
match !_root with
| Some d -> d
| None -> (try Sys.getenv "SX_PERSIST_DIR" with Not_found -> "persist-data")
(* ---- filesystem helpers ------------------------------------------------ *)
let rec ensure_dir dir =
if dir = "" || dir = "." || dir = "/" || Sys.file_exists dir then ()
else begin
ensure_dir (Filename.dirname dir);
(try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
end
let streams_dir () = Filename.concat (root_dir ()) "streams"
let kv_dir () = Filename.concat (root_dir ()) "kv"
let blobs_dir () = Filename.concat (root_dir ()) "blobs"
let read_file path =
let ic = open_in_bin path in
let n = in_channel_length ic in
let s = really_input_string ic n in
close_in ic;
s
(* Atomic write: temp file in the same dir then rename over the target. *)
let write_file_atomic path contents =
ensure_dir (Filename.dirname path);
let tmp = path ^ ".tmp" in
let oc = open_out_bin tmp in
output_string oc contents;
flush oc;
close_out oc;
Sys.rename tmp path
let append_line path line =
ensure_dir (Filename.dirname path);
let oc = open_out_gen [Open_append; Open_creat; Open_wronly] 0o644 path in
output_string oc line;
output_char oc '\n';
close_out oc
(* ---- name <-> filename (hex, reversible, fs-safe) ---------------------- *)
let hex_encode s =
let b = Buffer.create (String.length s * 2) in
String.iter (fun c -> Buffer.add_string b (Printf.sprintf "%02x" (Char.code c))) s;
Buffer.contents b
let hex_decode s =
let n = String.length s / 2 in
String.init n (fun i -> Char.chr (int_of_string ("0x" ^ String.sub s (i * 2) 2)))
let stream_log stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".log")
let stream_seq stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".seq")
let kv_path key = Filename.concat (kv_dir ()) (hex_encode key)
(* ---- value <-> SX text (round-trips through Sx_parser) ----------------- *)
let escape_str s =
let len = String.length s in
let buf = Buffer.create (len + 16) in
for i = 0 to len - 1 do
match s.[i] with
| '"' -> Buffer.add_string buf "\\\""
| '\\' -> Buffer.add_string buf "\\\\"
| '\n' -> Buffer.add_string buf "\\n"
| '\r' -> Buffer.add_string buf "\\r"
| '\t' -> Buffer.add_string buf "\\t"
| c -> Buffer.add_char buf c
done;
Buffer.contents buf
let rec serialize = function
| Nil -> "nil"
| Bool true -> "true"
| Bool false -> "false"
| Integer n -> string_of_int n
| Number n -> format_number n
| String s -> "\"" ^ escape_str s ^ "\""
| Symbol s -> "(quote " ^ s ^ ")"
| Keyword k -> ":" ^ k
| List items | ListRef { contents = items } ->
"(list" ^ (List.fold_left (fun acc v -> acc ^ " " ^ serialize v) "" items) ^ ")"
| Dict d ->
let pairs = Hashtbl.fold (fun k v acc ->
(Printf.sprintf ":%s %s" k (serialize v)) :: acc) d [] in
"{" ^ String.concat " " (List.sort String.compare pairs) ^ "}"
| _ -> "nil"
(* Parse one serialized value back. Empty / blank -> Nil. *)
let rec deserialize line =
let line = String.trim line in
if line = "" then Nil
else match Sx_parser.parse_all line with
| v :: _ -> eval_quote_lists v
| [] -> Nil
(* serialize emits lists as `(list ...)` and symbols as `(quote s)` so the
parser yields data, not a call — but the parser leaves those as AST. Walk
the parsed AST and collapse `(list ...)`/`(quote s)` back to values. *)
and eval_quote_lists v =
match v with
| List (Symbol "quote" :: x :: []) -> x
| List (Symbol "list" :: rest) -> List (List.map eval_quote_lists rest)
| List items -> List (List.map eval_quote_lists items)
| ListRef { contents = items } -> List (List.map eval_quote_lists items)
| Dict d ->
let d' = Hashtbl.create (Hashtbl.length d) in
Hashtbl.iter (fun k v -> Hashtbl.replace d' k (eval_quote_lists v)) d;
Dict d'
| other -> other
(* ---- seq counter ------------------------------------------------------- *)
let read_seq stream =
let p = stream_seq stream in
if Sys.file_exists p then (try int_of_string (String.trim (read_file p)) with _ -> 0)
else 0
let write_seq stream n = write_file_atomic (stream_seq stream) (string_of_int n)
let value_to_int = function
| Integer n -> n
| Number n -> int_of_float n
| _ -> 0
let event_seq ev =
match ev with
| Dict d -> (match Hashtbl.find_opt d "seq" with Some v -> value_to_int v | None -> 0)
| _ -> 0
(* ---- ops --------------------------------------------------------------- *)
let do_append stream ev =
ensure_dir (streams_dir ());
(* bump the monotonic high-water mark; create .seq on first append so the
stream shows up in `streams` and survives later truncation. *)
let hw = read_seq stream in
let s = event_seq ev in
write_seq stream (max hw s);
append_line (stream_log stream) (serialize ev)
let do_read stream =
let p = stream_log stream in
if not (Sys.file_exists p) then List []
else begin
let content = read_file p in
let lines = String.split_on_char '\n' content in
let evs = List.filter_map (fun l ->
if String.trim l = "" then None else Some (deserialize l)) lines in
List evs
end
let do_last_seq stream = Number (float_of_int (read_seq stream))
let list_dir_suffix dir suffix =
if not (Sys.file_exists dir) then []
else
Array.to_list (Sys.readdir dir)
|> List.filter (fun f -> Filename.check_suffix f suffix)
|> List.map (fun f -> hex_decode (Filename.chop_suffix f suffix))
|> List.sort String.compare
let do_streams () = List (List.map (fun s -> String s) (list_dir_suffix (streams_dir ()) ".seq"))
(* drop events with seq <= n; the .seq high-water counter is untouched. *)
let do_truncate stream n =
let p = stream_log stream in
if Sys.file_exists p then begin
let evs = match do_read stream with List l -> l | _ -> [] in
let kept = List.filter (fun ev -> event_seq ev > n) evs in
let body = String.concat "" (List.map (fun ev -> serialize ev ^ "\n") kept) in
write_file_atomic p body
end
let do_kv_get key =
let p = kv_path key in
if Sys.file_exists p then deserialize (read_file p) else Nil
let do_kv_put key v =
ensure_dir (kv_dir ());
write_file_atomic (kv_path key) (serialize v)
let do_kv_delete key =
let p = kv_path key in
if Sys.file_exists p then (try Sys.remove p with _ -> ())
let do_kv_has key = Bool (Sys.file_exists (kv_path key))
let do_kv_keys () =
if not (Sys.file_exists (kv_dir ())) then List []
else
List (
Array.to_list (Sys.readdir (kv_dir ()))
|> List.map hex_decode
|> List.sort String.compare
|> List.map (fun s -> String s))
(* ---- blob store (content-addressed) ------------------------------------ *)
(* Same pattern as the persist ops, but a SEPARATE adapter: large objects live
in a content-addressed directory keyed by a CIDv1 (raw codec, sha2-256).
persist only ever stores the returned ref ({:cid :size :mime}), never bytes.
blob/put is idempotent — identical bytes hash to the same cid + same file. *)
let codec_raw = 0x55
let blob_cid bytes =
let digest = Sx_cid.unhex (Sx_sha2.sha256_hex bytes) in
Sx_cid.cidv1 codec_raw (Sx_cid.multihash Sx_cid.mh_sha2_256 digest)
let blob_path cid = Filename.concat (blobs_dir ()) cid
let do_blob_put bytes =
let cid = blob_cid bytes in
let p = blob_path cid in
if not (Sys.file_exists p) then write_file_atomic p bytes;
String cid
let do_blob_get cid =
let p = blob_path cid in
if Sys.file_exists p then String (read_file p) else Nil
let do_blob_has cid = Bool (Sys.file_exists (blob_path cid))
(* ---- dispatch ---------------------------------------------------------- *)
let arglist = function
| List l | ListRef { contents = l } -> l
| Nil -> []
| v -> [v]
(* Returns Some response if op is a persist op this store owns, None otherwise. *)
let handle_op op args =
let a = arglist args in
let str = function String s -> s | v -> value_to_string v in
match op with
| "persist/append" ->
(match a with stream :: ev :: _ -> do_append (str stream) ev | _ -> ()); Some Nil
| "persist/read" ->
(match a with stream :: _ -> Some (do_read (str stream)) | _ -> Some (List []))
| "persist/last-seq" ->
(match a with stream :: _ -> Some (do_last_seq (str stream)) | _ -> Some (Number 0.0))
| "persist/streams" -> Some (do_streams ())
| "persist/truncate" ->
(match a with stream :: n :: _ -> do_truncate (str stream) (value_to_int n) | _ -> ()); Some Nil
| "persist/kv-get" ->
(match a with key :: _ -> Some (do_kv_get (str key)) | _ -> Some Nil)
| "persist/kv-put" ->
(match a with key :: v :: _ -> do_kv_put (str key) v | _ -> ()); Some Nil
| "persist/kv-delete" ->
(match a with key :: _ -> do_kv_delete (str key) | _ -> ()); Some Nil
| "persist/kv-has?" ->
(match a with key :: _ -> Some (do_kv_has (str key)) | _ -> Some (Bool false))
| "persist/kv-keys" -> Some (do_kv_keys ())
| "blob/put" ->
(match a with bytes :: _ -> Some (do_blob_put (str bytes)) | _ -> Some Nil)
| "blob/get" ->
(match a with cid :: _ -> Some (do_blob_get (str cid)) | _ -> Some Nil)
| "blob/has?" ->
(match a with cid :: _ -> Some (do_blob_has (str cid)) | _ -> Some (Bool false))
| _ -> None

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

File diff suppressed because it is too large Load Diff

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

@@ -614,7 +614,7 @@ and cek_step_loop state =
(* cek-run *)
and cek_run state =
(let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (match !_cek_io_suspend_hook with Some hook -> hook final | None -> (raise (Eval_error (value_to_str (String "IO suspension in non-IO context"))))) else (cek_value (final))))
(let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) else (cek_value (final))))
(* cek-resume *)
and cek_resume suspended_state result' =
@@ -759,78 +759,7 @@ and match_pattern pattern value env =
(* step-sf-match *)
and step_sf_match args env kont =
(let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let () = ignore (match_check_exhaustiveness val' clauses env) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))))
(* match-check-exhaustiveness — Step 8 hand-patched into sx_ref.ml *)
and match_check_exhaustiveness val' clauses env =
let is_else_pat p =
match p with
| Symbol "_" | Symbol "else" -> true
| Keyword "else" -> true
| _ -> false
in
let clause_is_else c =
match c with
| List (p :: _) -> is_else_pat p
| _ -> false
in
let clause_ctor_name c =
match c with
| List (List (Symbol n :: _) :: _) -> Some n
| _ -> None
in
let type_name_opt = match val' with
| AdtValue a -> Some a.av_type
| Dict d ->
(match Hashtbl.find_opt d "_adt" with
| Some (Bool true) ->
(match Hashtbl.find_opt d "_type" with
| Some (String s) -> Some s
| _ -> None)
| _ -> None)
| _ -> None
in
match type_name_opt with
| None -> Nil
| Some type_name ->
if not (sx_truthy (env_has env (String "*adt-registry*"))) then Nil
else
let registry = env_get env (String "*adt-registry*") in
let registered = match registry with
| Dict r ->
(match Hashtbl.find_opt r type_name with
| Some (List ctors) -> Some ctors
| _ -> None)
| _ -> None in
(match registered with
| None -> Nil
| Some ctor_vals ->
let clauses_list = match clauses with List xs -> xs | _ -> [] in
if List.exists clause_is_else clauses_list then Nil
else
let clause_ctors = List.filter_map clause_ctor_name clauses_list in
let registered_names = List.filter_map (function
| String s -> Some s | _ -> None) ctor_vals in
let missing = List.filter (fun c -> not (List.mem c clause_ctors)) registered_names in
if missing = [] then Nil
else begin
if not (sx_truthy (env_has env (String "*adt-warned*"))) then
ignore (env_bind env (String "*adt-warned*") (Dict (Hashtbl.create 4)));
let warned = env_get env (String "*adt-warned*") in
let key = type_name ^ "|" ^ String.concat "," missing in
let already = match warned with
| Dict w -> (match Hashtbl.find_opt w key with Some (Bool true) -> true | _ -> false)
| _ -> false in
if already then Nil
else begin
(match warned with
| Dict w -> Hashtbl.replace w key (Bool true)
| _ -> ());
let msg = "[sx] match: non-exhaustive — " ^ type_name ^ ": missing " ^ String.concat ", " missing in
ignore (host_warn (String msg));
Nil
end
end)
(let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont)))))
(* step-sf-handler-bind *)
and step_sf_handler_bind args env kont =
@@ -1052,14 +981,7 @@ let cek_run_iterative state =
s := cek_step !s
done;
(match cek_suspended_p !s with
| Bool true ->
(* Propagate suspension via the OCaml-side hook so it converts to
VmSuspended and flows to the outer driver (value_to_js / resume
callback). Without the hook (pure CEK harness), keep the legacy
error so test runners surface the misuse. *)
(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;
@@ -1132,7 +1054,8 @@ let sf_define_type args env_val =
(match pargs with
| [v] ->
(match v with
| AdtValue a -> Bool (a.av_type = type_name)
| 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 ->
@@ -1146,18 +1069,21 @@ let sf_define_type args env_val =
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
AdtValue {
av_type = type_name;
av_ctor = cn;
av_fields = Array.of_list 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
| AdtValue a -> Bool (a.av_ctor = cn)
| 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 ->
@@ -1166,10 +1092,13 @@ let sf_define_type args env_val =
(match pargs with
| [v] ->
(match v with
| AdtValue a ->
if idx < Array.length a.av_fields then a.av_fields.(idx)
else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
| 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
| _ -> ())

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

81
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
@@ -270,13 +209,6 @@ 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 ->
@@ -472,10 +404,6 @@ let callcc_continuation_winders_len v = match v with
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 +539,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

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

@@ -82,16 +82,6 @@ and value =
| 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 =
@@ -138,8 +128,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 = {
@@ -446,60 +434,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
@@ -580,7 +520,6 @@ let type_of = function
| 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
@@ -867,15 +806,14 @@ 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"
| Integer n -> string_of_int n
| 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 +822,66 @@ 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))
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)
| StringBuffer buf -> Printf.sprintf "<string-buffer:%d>" (Buffer.length buf)
| HashTable ht -> 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"
let name = match n with
| 32 -> "space" | 10 -> "newline" | 9 -> "tab"
| 13 -> "return" | 0 -> "nul" | 27 -> "escape"
| 127 -> "delete" | 8 -> "backspace"
| _ -> let buf = Buffer.create 1 in
Buffer.add_utf_8_uchar buf (Uchar.of_int n);
Buffer.contents buf
in "#\\" ^ name
| Eof -> "#!eof"
| Port { sp_kind = PortInput (_, pos); sp_closed } ->
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
Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else "")
| Port { sp_kind = PortOutput buf; sp_closed } ->
Printf.sprintf "<output-port:len=%d%s>" (Buffer.length buf) (if sp_closed then ":closed" else "")
| Rational (n, d) -> Printf.sprintf "%d/%d" n d
| SxSet ht -> Printf.sprintf "<set:%d>" (Hashtbl.length ht)
| SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags
| SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i)))))

197
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 = {
@@ -350,18 +327,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 +353,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 +631,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,57 +731,38 @@ 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))
push vm ((Hashtbl.find Sx_primitives.primitives "=") [a; b])
| 165 (* OP_LT *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| 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)))
@@ -895,15 +824,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 +885,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 +968,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 +1030,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 +1141,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 +1269,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 +1390,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 _ ->

144
hosts/ocaml/test/persist_durable_test.sh
View File

@@ -1,144 +0,0 @@
#!/usr/bin/env bash
# hosts/ocaml/test/persist_durable_test.sh
# Acceptance test for the host durable-storage adapter (Sx_persist_store).
#
# Exercises `persist/durable-backend` (REAL `perform`, not the mock) under the
# WORKTREE-built sx_server.exe, and asserts:
# 1. durable: writes land on disk and read back (the silent-data-loss repro
# from plans/persist-on-sx.md now returns correct values).
# 2. last-seq is monotonic across truncate (compaction never reassigns a seq).
# 3. kv ops round-trip and delete.
# 4. recovery: a REAL process restart (write, exit, fresh process, replay)
# recovers state from disk.
#
# Run from repo root or anywhere; locates the worktree binary relative to itself.
set -uo pipefail
HERE="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
ROOT="$(cd "$HERE/../../.." && pwd)" # repo/worktree root
cd "$ROOT"
SX="hosts/ocaml/_build/default/bin/sx_server.exe"
if [ ! -x "$SX" ]; then
echo "ERROR: worktree binary not found at $SX — build it first:" >&2
echo " (cd hosts/ocaml && dune build bin/sx_server.exe)" >&2
exit 1
fi
DATADIR="$(mktemp -d)"
trap 'rm -rf "$DATADIR"' EXIT
PASS=0
FAIL=0
check() { # check <label> <got> <expected>
if [ "$2" = "$3" ]; then
PASS=$((PASS + 1)); printf ' ok %-40s => %s\n' "$1" "$2"
else
FAIL=$((FAIL + 1)); printf ' FAIL %-40s got [%s] want [%s]\n' "$1" "$2" "$3"
fi
}
PRELUDE='(epoch 1)
(load "spec/stdlib.sx")
(load "lib/r7rs.sx")
(load "lib/persist/event.sx")
(load "lib/persist/backend.sx")
(load "lib/persist/log.sx")
(load "lib/persist/kv.sx")
(load "lib/persist/durable.sx")
(load "lib/persist/blob.sx")
(epoch 2)'
# run_eval <sx-expr-string>: prints the final (ok-len 2 ...) payload line.
run_eval() {
local expr="$1"
printf '%s\n(eval %s)\n' "$PRELUDE" "$expr" \
| SX_PERSIST_DIR="$DATADIR" timeout 60 "$SX" 2>/dev/null \
| awk '/^\(ok-len 2 / {getline; print; exit}'
}
# escape an SX program into a single-line double-quoted SX string literal for
# (eval "..."). The REPL reads one command per physical line, so newlines in the
# program are collapsed to spaces.
q() { printf '"%s"' "$(printf '%s' "$1" | tr '\n' ' ' | sed 's/\\/\\\\/g; s/"/\\"/g')"; }
echo "== durable: append/read/last-seq round-trip on disk =="
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
(begin
(persist/append b "s" "x" 0 {:v 1})
(persist/append b "s" "x" 0 {:v 2})
(list (persist/event-seq (persist/append b "s" "x" 0 {:v 3}))
(persist/count b "s")
(len (persist/read b "s")))))')")
check "append/count/read" "$GOT" "(3 3 3)"
echo "== last-seq monotonic across truncate =="
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
(begin
(persist/append b "t" "x" 0 {})
(persist/append b "t" "x" 0 {})
(persist/append b "t" "x" 0 {})
(persist/truncate b "t" 2)
(list (persist/last-seq b "t") (persist/count b "t"))))')")
check "last-seq survives truncate" "$GOT" "(3 1)"
echo "== streams set survives compaction =="
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
(sort ((get b "streams"))))')")
check "streams" "$GOT" '("s" "t")'
echo "== kv round-trip + delete =="
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
(begin
(persist/kv-put b "k" {:a 1 :b "two"})
(persist/kv-put b "gone" 9)
(persist/kv-delete b "gone")
(list (get (persist/kv-get b "k") :b)
(persist/kv-has? b "k")
(persist/kv-has? b "gone"))))')")
check "kv get/has/delete" "$GOT" '("two" true false)'
echo "== recovery: state survives a REAL process restart =="
# write in process A then let it exit; the next run is a brand-new process.
run_eval "$(q '(let ((b (persist/durable-backend)))
(begin
(persist/append b "r" "ev" 0 {:n 1})
(persist/append b "r" "ev" 0 {:n 2})
(persist/kv-put b "survive" "yes")
(persist/count b "r")))')" >/dev/null
# fresh process, same SX_PERSIST_DIR — must replay from disk.
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
(list (persist/count b "r")
(persist/last-seq b "r")
(get (get (nth (persist/read b "r") 1) :data) :n)
(persist/kv-get b "survive")))')")
check "recovered after restart" "$GOT" '(2 2 2 "yes")'
echo "== blob: content-addressed put/get/has? round-trip =="
GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
(let ((r (persist/blob-store bs "hello world" "text/plain")))
(list (persist/blob-size r)
(persist/blob-mime r)
(persist/blob-fetch bs r)
(persist/blob-exists? bs r))))')")
check "blob size/mime/fetch/exists" "$GOT" '(11 "text/plain" "hello world" true)'
echo "== blob: put is content-addressed (idempotent cid) =="
GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
(equal? (persist/blob-cid (persist/blob-store bs "same bytes" "x"))
(persist/blob-cid (persist/blob-store bs "same bytes" "x"))))')")
check "same bytes -> same cid" "$GOT" "true"
echo "== blob: bytes + ref-in-kv survive a REAL restart =="
# process A: store a blob, keep only its ref in the durable kv.
run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
(begin (persist/kv-put b "logo" (persist/blob-store bs "PNGDATA" "image/png")) nil))')" >/dev/null
# fresh process: read the ref from kv, fetch the bytes from the blob store.
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
(let ((r (persist/kv-get b "logo")))
(list (persist/blob-fetch bs r) (persist/blob-exists? bs r) (persist/blob-mime r))))')")
check "blob recovered via ref after restart" "$GOT" '("PNGDATA" true "image/png")'
echo
echo "durable adapter: $PASS passed, $FAIL failed"
[ "$FAIL" -eq 0 ]

45
lib/acl/api.sx
View File

@@ -1,45 +0,0 @@
;; lib/acl/api.sx — public ACL surface over an implicit current db.
;;
;; Callers load a fact set once, then issue decisions without threading the db
;; through every call. The current db is module state; (acl/load! facts) rebuilds
;; it. This is the boundary the rest of rose-ash imports.
(define acl-current-db nil)
;; Replace the current fact base. Rebuilds the Datalog db under the active
;; ruleset (see lib/acl/engine.sx).
(define
acl/load!
(fn
(facts)
(do (set! acl-current-db (acl-build-db facts)) acl-current-db)))
;; Ensure a db exists, building an empty one on first use.
(define
acl-ensure-db!
(fn
()
(do
(when
(= acl-current-db nil)
(set! acl-current-db (acl-build-db (list))))
acl-current-db)))
;; Public decision against the current db (pure, no logging).
(define
acl/permit?
(fn (subj act res) (acl-permit? (acl-ensure-db!) subj act res)))
;; Decision-with-proof against the current db. See lib/acl/explain.sx.
(define
acl/explain
(fn (subj act res) (acl-explain (acl-ensure-db!) subj act res)))
;; Audited decision: logs the outcome to the append-only audit log and returns
;; the boolean. See lib/acl/audit.sx.
(define
acl/audit
(fn (subj act res) (acl-audit-decide! (acl-ensure-db!) subj act res)))
;; Recent audited decisions (chronological).
(define acl/audit-tail (fn (n) (acl-audit-tail n)))

110
lib/acl/audit.sx
View File

@@ -1,110 +0,0 @@
;; lib/acl/audit.sx — append-only decision log.
;;
;; Every decision routed through acl-audit-decide! is appended to an in-memory
;; log with a monotonic sequence number (no wall-clock — deterministic and
;; testable; a host can stamp time at the serializer boundary). The log is
;; append-only: there is no mutate or delete, only append, tail, clear,
;; snapshot/restore, and serialize-for-disk.
(define acl-audit-log (list))
(define acl-audit-seq 0)
;; Copy a list into a fresh, append!-able list. `map`/`rest`-derived lists are
;; NOT extensible by append! in this runtime (it silently no-ops), so the live
;; log must always be a list built with `list` + `append!`.
(define
acl-audit-copy
(fn
(xs)
(let
((fresh (list)))
(do (for-each (fn (e) (append! fresh e)) xs) fresh))))
(define
acl-audit-clear!
(fn
()
(do (set! acl-audit-log (list)) (set! acl-audit-seq 0) nil)))
;; Append a decision record. Returns the record.
(define
acl-audit-record!
(fn
(subj act res allowed?)
(let
((entry {:allowed? allowed? :act act :subj subj :res res :seq acl-audit-seq}))
(do
(set! acl-audit-seq (+ acl-audit-seq 1))
(append! acl-audit-log entry)
entry))))
;; Decide against db, log the outcome, and return the boolean. This is the
;; audited path; acl-permit? remains the pure, side-effect-free decision.
(define
acl-audit-decide!
(fn
(db subj act res)
(let
((allowed? (acl-permit? db subj act res)))
(do (acl-audit-record! subj act res allowed?) allowed?))))
(define acl-audit-count (fn () (len acl-audit-log)))
;; Most recent n entries (in chronological order). n >= log size returns all.
(define
acl-audit-tail
(fn
(n)
(let
((total (len acl-audit-log)))
(if
(<= total n)
acl-audit-log
(acl-audit-drop acl-audit-log (- total n))))))
(define
acl-audit-drop
(fn
(xs k)
(if (<= k 0) xs (acl-audit-drop (rest xs) (- k 1)))))
;; Structured snapshot for save/restore — a {:seq :entries} value carrying a
;; copy of the log (so later appends don't mutate a held snapshot).
(define acl-audit-snapshot (fn () {:seq acl-audit-seq :entries (acl-audit-copy acl-audit-log)}))
;; Replace the live log from a snapshot. Restores both entries and the seq
;; counter so subsequent records continue numbering correctly. The log is
;; rebuilt as a fresh append!-able list (see acl-audit-copy).
(define
acl-audit-restore!
(fn
(snap)
(do
(set! acl-audit-log (acl-audit-copy (get snap :entries)))
(set! acl-audit-seq (get snap :seq))
nil)))
;; Serialize the whole log to a disk-ready string: one record per line,
;; "seq\tsubj\tact\tres\tallowed?". A host writes this; structured reload is via
;; snapshot/restore.
(define
acl-audit-serialize
(fn
()
(reduce
(fn
(acc e)
(str
acc
(get e :seq)
"\t"
(get e :subj)
"\t"
(get e :act)
"\t"
(get e :res)
"\t"
(get e :allowed?)
"\n"))
""
acl-audit-log)))

32
lib/acl/conformance.conf
View File

@@ -1,32 +0,0 @@
# ACL conformance config — sourced by lib/guest/conformance.sh.
LANG_NAME=acl
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/acl/schema.sx
lib/acl/facts.sx
lib/acl/engine.sx
lib/acl/explain.sx
lib/acl/audit.sx
lib/acl/federation.sx
lib/acl/api.sx
)
SUITES=(
"direct:lib/acl/tests/direct.sx:(acl-direct-tests-run!)"
"inherit:lib/acl/tests/inherit.sx:(acl-inherit-tests-run!)"
"explain:lib/acl/tests/explain.sx:(acl-explain-tests-run!)"
"fed:lib/acl/tests/fed.sx:(acl-fed-tests-run!)"
"harden:lib/acl/tests/harden.sx:(acl-harden-tests-run!)"
)

3
lib/acl/conformance.sh
View File

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

72
lib/acl/engine.sx
View File

@@ -1,72 +0,0 @@
;; lib/acl/engine.sx — ACL ruleset + decision reducer over lib/datalog/.
;;
;; The engine is a thin layer: it owns the permit ruleset (SX data rules) and
;; reduces a (subject, action, resource) decision to a Datalog query against a
;; db built from EDB facts. The rule engine itself is Datalog's.
;;
;; Policy — inheritance + federation with deny-overrides:
;;
;; eff_grant(S,A,R) :- grant(S,A,R). ; direct
;; eff_grant(S,A,R) :- member_of(S,G), eff_grant(G,A,R). ; group/role chain
;; eff_grant(S,A,R) :- child_of(R,P), eff_grant(S,A,P). ; resource tree
;; eff_grant(S,A,R) :- member_of(S,Role), role_grant(Role,A,R). ; role expansion
;; eff_grant(S,A,R) :- delegate(Peer,S,A,R), ; federated grant
;; trust(Peer,L), level_covers(L,A).
;;
;; eff_deny(S,A,R) :- deny(S,A,R). ; direct
;; eff_deny(S,A,R) :- member_of(S,G), eff_deny(G,A,R). ; group chain
;; eff_deny(S,A,R) :- child_of(R,P), eff_deny(S,A,P). ; resource tree
;;
;; permit(S,A,R) :- eff_grant(S,A,R), not eff_deny(S,A,R).
;;
;; DENY-OVERRIDES: an effective deny anywhere in the inheritance closure of
;; (S,A,R) defeats any effective grant — including federated grants. Deny
;; inherits through the *same* group and resource chains as grant, so a
;; group-level or ancestor-resource deny is authoritative for members/
;; descendants. This is the principled, fail-safe reading of "deny wins".
;;
;; FEDERATION — non-transitive trust: a peer's `delegate` fact only grants if a
;; *local* `trust(Peer, L)` exists AND that level `level_covers` the action.
;; Trust is re-checked on every query (it is a body literal), never baked in at
;; fact-ingestion time, so revoking trust or narrowing a level takes effect
;; immediately on the next decision.
;;
;; Termination & stratification:
;; - eff_grant/eff_deny recurse only over member_of and child_of, which are
;; EDB relations with no function symbols, so the closure is finite (cyclic
;; membership/containment just reaches a fixpoint, never loops). The
;; federation rule is non-recursive.
;; - permit negates eff_deny; neither eff_grant nor eff_deny depends on
;; permit, so the program is stratifiable (permit sits in a higher stratum).
(define
acl-rules
(quote
((eff_grant S A R <- (grant S A R))
(eff_grant S A R <- (member_of S G) (eff_grant G A R))
(eff_grant S A R <- (child_of R P) (eff_grant S A P))
(eff_grant S A R <- (member_of S Role) (role_grant Role A R))
(eff_grant
S
A
R
<-
(delegate Peer S A R)
(trust Peer L)
(level_covers L A))
(eff_deny S A R <- (deny S A R))
(eff_deny S A R <- (member_of S G) (eff_deny G A R))
(eff_deny S A R <- (child_of R P) (eff_deny S A P))
(permit S A R <- (eff_grant S A R) {:neg (eff_deny S A R)}))))
;; Build a Datalog db from a list of EDB facts under the ACL ruleset.
(define acl-build-db (fn (facts) (dl-program-data facts acl-rules)))
;; Core decision: does the db permit subject S to perform action A on
;; resource R? Reduces to a ground Datalog query on the derived `permit`
;; relation — non-empty result means permitted.
(define
acl-permit?
(fn
(db subj act res)
(> (len (dl-query db (list (quote permit) subj act res))) 0)))

125
lib/acl/explain.sx
View File

@@ -1,125 +0,0 @@
;; lib/acl/explain.sx — proof-tree reconstruction over the saturated db.
;;
;; lib/datalog/ records derived facts but not their provenance, so the proof is
;; reconstructed here by goal-directed search over the *saturated* db: for a
;; ground goal we find the first ACL rule (in rule order) whose body holds, take
;; the first solution binding its remaining variables, and recurse on each body
;; literal. Negated literals are recorded as verified `:neg-ok` leaves.
;;
;; CANONICAL DERIVATION: the Datalog derivation graph is a DAG (a fact may hold
;; many ways). We pick ONE canonical proof — first matching rule, first solution
;; — matching the rule order in lib/acl/engine.sx (direct/EDB rules first). A
;; depth cap guards against pathological cyclic data producing unbounded search.
;;
;; A proof node is one of:
;; {:fact <lit> :via "edb"} — base EDB fact
;; {:fact <lit> :rule <head> :body (<node|negleaf> ...)} — derived
;; {:neg-ok <lit>} — negation verified to fail
;; {:fact <lit> :truncated true} — depth cap hit
(define acl-proof-max-depth 64)
;; Substitute a body literal, descending into {:neg ...} dicts (dl-apply-subst
;; does not recurse into dicts, which would leak the neg's free vars).
(define
acl-subst-lit
(fn
(lit s)
(if
(and (dict? lit) (has-key? lit :neg))
{:neg (dl-apply-subst (get lit :neg) s)}
(dl-apply-subst lit s))))
(define
acl-lit-edb?
(fn
(lit)
(and
(list? lit)
(> (len lit) 0)
(symbol? (first lit))
(has-key? acl-edb-arity (symbol->string (first lit))))))
(define
acl-subst-zip!
(fn
(d ks vs)
(when
(> (len ks) 0)
(do
(dict-set! d (symbol->string (first ks)) (first vs))
(acl-subst-zip! d (rest ks) (rest vs))))))
;; Bind a rule head's variables to a ground goal's arguments (positional).
(define
acl-bind-head
(fn
(head goal)
(let
((d {}))
(do (acl-subst-zip! d (rest head) (rest goal)) d))))
(define
acl-subst-union
(fn
(a b)
(let
((d {}))
(do
(for-each (fn (k) (dict-set! d k (get a k))) (keys a))
(for-each (fn (k) (dict-set! d k (get b k))) (keys b))
d))))
(define acl-prove (fn (db goal) (acl-prove-d db goal 0)))
(define
acl-prove-d
(fn
(db goal depth)
(cond
((> depth acl-proof-max-depth) {:truncated true :fact goal})
((acl-lit-edb? goal)
(if (> (len (dl-query db goal)) 0) {:via "edb" :fact goal} nil))
(else (acl-prove-rules db goal acl-rules depth)))))
(define
acl-prove-rules
(fn
(db goal rules depth)
(if
(= (len rules) 0)
nil
(let
((p (dl-rule-from-list (first rules))))
(if
(= (first (get p :head)) (first goal))
(let
((hs (acl-bind-head (get p :head) goal)))
(let
((qbody (map (fn (l) (acl-subst-lit l hs)) (get p :body))))
(let
((sols (dl-query db qbody)))
(if
(> (len sols) 0)
(acl-prove-build db goal p hs (first sols) depth)
(acl-prove-rules db goal (rest rules) depth)))))
(acl-prove-rules db goal (rest rules) depth))))))
(define
acl-prove-build
(fn
(db goal p hs sol depth)
(let ((full (acl-subst-union hs sol))) {:body (map (fn (l) (let ((g (acl-subst-lit l full))) (if (and (dict? g) (has-key? g :neg)) {:neg-ok (get g :neg)} (acl-prove-d db g (+ depth 1))))) (get p :body)) :rule (get p :head) :fact goal})))
;; Public decision-with-proof. Returns:
;; {:allowed? <bool> :proof <node|nil> :reason <eff_deny proof|nil>}
;; When permitted, :proof is the permit derivation. When denied, :proof is nil
;; and :reason carries the blocking eff_deny proof if one exists (an explicit or
;; inherited deny), else nil (simply no grant).
(define
acl-explain
(fn
(db subj act res)
(let
((proof (acl-prove db (list (quote permit) subj act res))))
(if (= proof nil) {:allowed? false :proof nil :reason (acl-prove db (list (quote eff_deny) subj act res))} {:allowed? true :proof proof :reason nil}))))

47
lib/acl/facts.sx
View File

@@ -1,47 +0,0 @@
;; lib/acl/facts.sx — EDB fact constructors.
;;
;; Each constructor returns a Datalog fact tuple (a list whose head is the
;; predicate symbol). These are the only shapes lib/acl/engine.sx feeds to
;; lib/datalog/.
;; Phase 1: actor/resource/grant/deny.
;; Phase 2: member_of (subject -> group/role), child_of (resource -> parent),
;; role_grant (role -> action,resource capability).
;; Phase 4: peer/trust/delegate/level_covers (federation).
(define acl-actor (fn (id kind) (list (quote actor) id kind)))
(define acl-resource-fact (fn (id kind) (list (quote resource) id kind)))
(define acl-grant (fn (subj act res) (list (quote grant) subj act res)))
(define acl-deny (fn (subj act res) (list (quote deny) subj act res)))
;; subject S is a member of group/role G (one hop; transitivity is derived).
(define acl-member-of (fn (subj grp) (list (quote member_of) subj grp)))
;; resource R is a child of parent P (one hop; transitivity is derived).
(define acl-child-of (fn (res parent) (list (quote child_of) res parent)))
;; role confers capability (act on res) to every member of the role.
(define
acl-role-grant
(fn (role act res) (list (quote role_grant) role act res)))
;; --- federation ---
;; a known peer instance at addr, of some kind (e.g. peer).
(define acl-peer (fn (addr kind) (list (quote peer) addr kind)))
;; local trust in a peer at a named level. Gates delegated grants at query time.
(define acl-trust (fn (peer level) (list (quote trust) peer level)))
;; a peer asserts that subject S may A on R. Only takes effect if local trust in
;; that peer covers action A (see level_covers).
(define
acl-delegate
(fn (peer subj act res) (list (quote delegate) peer subj act res)))
;; local policy: trust `level` authorises delegated grants for action `act`.
(define
acl-level-covers
(fn (level act) (list (quote level_covers) level act)))

61
lib/acl/federation.sx
View File

@@ -1,61 +0,0 @@
;; lib/acl/federation.sx — cross-instance ACL facts + revocation.
;;
;; fed-sx replicates ACL facts between instances; this module models the local
;; side. A peer's authority arrives as `delegate(Peer, S, A, R)` facts, which
;; only take effect when a local `trust(Peer, L)` and `level_covers(L, A)`
;; authorise them (enforced by the engine rule, re-checked every query). The
;; actual network transport is fed-sx's job and is mocked in tests as a dict.
;;
;; Trust is NOT transitive: trusting peer α does not extend to peers α trusts.
;; Only delegate facts that α itself asserts, and that local trust covers, flow.
;; Mock fed-sx pull: `transport` is a dict mapping a peer address (its string
;; name) to the list of delegate facts that peer asserts. Returns the facts for
;; `addr`, or an empty list if the peer is unknown / unreachable.
(define
acl-fed-fetch
(fn
(transport addr)
(let
((k (if (symbol? addr) (symbol->string addr) addr)))
(if (has-key? transport k) (get transport k) (list)))))
;; Gather delegate facts from every peer in `addrs` via the transport.
(define
acl-fed-collect
(fn
(transport addrs)
(let
((acc (list)))
(do
(for-each
(fn
(addr)
(for-each
(fn (f) (append! acc f))
(acl-fed-fetch transport addr)))
addrs)
acc))))
;; Build a db from local facts plus delegate facts pulled from `peers`. Local
;; facts must include the `trust`/`level_covers` policy; replicated delegate
;; facts are gated against it by the engine rule at query time.
(define
acl-fed-build-db
(fn
(local-facts transport peers)
(let
((all (list)))
(do
(for-each (fn (f) (append! all f)) local-facts)
(for-each
(fn (f) (append! all f))
(acl-fed-collect transport peers))
(acl-build-db all)))))
;; Propagated revocation: retract a replicated fact (e.g. a peer's delegate, or
;; local trust) from a live db. The next decision re-saturates and reflects it.
(define acl-revoke! (fn (db fact) (do (dl-retract! db fact) db)))
;; Propagated assertion: ingest a newly replicated fact into a live db.
(define acl-fed-assert! (fn (db fact) (do (dl-assert! db fact) db)))

71
lib/acl/schema.sx
View File

@@ -1,71 +0,0 @@
;; lib/acl/schema.sx — ACL sorts and EDB predicate vocabulary.
;;
;; Datalog is untyped; this module is the schema-as-data layer. It declares
;; the subject/resource/action sorts and the arity of every EDB predicate the
;; ACL engine recognises, plus light validators. Facts that pass these checks
;; are well-formed inputs to lib/acl/engine.sx.
(define acl-subject-kinds (quote (user group role service)))
(define acl-resource-kinds (quote (page post thread peer)))
;; Actions are open-ended (a grant may name any action symbol), but these are
;; the platform's well-known verbs.
(define acl-actions (quote (read edit comment moderate federate)))
;; EDB predicate name -> arity.
;; Phase 1: actor/resource/grant/deny.
;; Phase 2: member_of (subject->group/role), child_of (resource->parent),
;; role_grant (role->action,resource).
;; Phase 4: peer (addr->kind), trust (peer->level),
;; delegate (peer->subj,action,resource), level_covers (level->action).
(define acl-edb-arity {:role_grant 3 :child_of 2 :trust 2 :peer 2 :actor 2 :level_covers 2 :delegate 4 :member_of 2 :deny 3 :grant 3 :resource 2})
(define
acl-member?
(fn
(x xs)
(cond
((= (len xs) 0) false)
((= (first xs) x) true)
(else (acl-member? x (rest xs))))))
(define acl-subject-kind? (fn (k) (acl-member? k acl-subject-kinds)))
(define acl-resource-kind? (fn (k) (acl-member? k acl-resource-kinds)))
(define acl-known-action? (fn (a) (acl-member? a acl-actions)))
;; A fact is a list whose head is a predicate symbol. Valid when the predicate
;; is known and the argument count matches the declared arity.
(define
acl-fact-valid?
(fn
(f)
(and
(list? f)
(> (len f) 0)
(symbol? (first f))
(let
((pred (symbol->string (first f))))
(and
(has-key? acl-edb-arity pred)
(= (- (len f) 1) (get acl-edb-arity pred)))))))
;; Return the sublist of facts that fail acl-fact-valid?. Empty list means the
;; whole set is well-formed. acl-build-db stays lenient (Datalog accepts any
;; tuple, and custom action symbols are allowed); callers opt in to checking.
(define
acl-validate-facts
(fn
(facts)
(let
((bad (list)))
(do
(for-each
(fn (f) (when (not (acl-fact-valid? f)) (append! bad f)))
facts)
bad))))
(define
acl-facts-valid?
(fn (facts) (= (len (acl-validate-facts facts)) 0)))

14
lib/acl/scoreboard.json
View File

@@ -1,14 +0,0 @@
{
"lang": "acl",
"total_passed": 145,
"total_failed": 0,
"total": 145,
"suites": [
{"name":"direct","passed":24,"failed":0,"total":24},
{"name":"inherit","passed":30,"failed":0,"total":30},
{"name":"explain","passed":35,"failed":0,"total":35},
{"name":"fed","passed":31,"failed":0,"total":31},
{"name":"harden","passed":25,"failed":0,"total":25}
],
"generated": "2026-06-06T22:43:27+00:00"
}

11
lib/acl/scoreboard.md
View File

@@ -1,11 +0,0 @@
# acl scoreboard
**145 / 145 passing** (0 failure(s)).
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
| direct | 24 | 24 | ok |
| inherit | 30 | 30 | ok |
| explain | 35 | 35 | ok |
| fed | 31 | 31 | ok |
| harden | 25 | 25 | ok |

170
lib/acl/tests/direct.sx
View File

@@ -1,170 +0,0 @@
;; lib/acl/tests/direct.sx — Phase 1: direct grants + deny-overrides.
(define acl-dt-pass 0)
(define acl-dt-fail 0)
(define acl-dt-failures (list))
(define
acl-dt-check!
(fn
(name got expected)
(if
(= got expected)
(set! acl-dt-pass (+ acl-dt-pass 1))
(do
(set! acl-dt-fail (+ acl-dt-fail 1))
(append!
acl-dt-failures
(str name "\n expected: " expected "\n got: " got))))))
;; A small fixture used by most cases: alice can read page1, is denied edit on
;; page1, and a service may federate peer1.
(define
acl-dt-fixture
(fn
()
(acl-build-db
(list
(acl-actor (quote alice) (quote user))
(acl-actor (quote svc1) (quote service))
(acl-resource-fact (quote page1) (quote page))
(acl-resource-fact (quote peer1) (quote peer))
(acl-grant (quote alice) (quote read) (quote page1))
(acl-grant (quote alice) (quote edit) (quote page1))
(acl-deny (quote alice) (quote edit) (quote page1))
(acl-grant (quote svc1) (quote federate) (quote peer1))))))
(define
acl-dt-run-all!
(fn
()
(let
((db (acl-dt-fixture)))
(do
(acl-dt-check!
"direct grant permits"
(acl-permit? db (quote alice) (quote read) (quote page1))
true)
(acl-dt-check!
"service grant permits federate"
(acl-permit? db (quote svc1) (quote federate) (quote peer1))
true)
(acl-dt-check!
"missing action denied"
(acl-permit? db (quote alice) (quote comment) (quote page1))
false)
(acl-dt-check!
"missing resource denied"
(acl-permit? db (quote alice) (quote read) (quote page2))
false)
(acl-dt-check!
"missing subject denied"
(acl-permit? db (quote bob) (quote read) (quote page1))
false)
(acl-dt-check!
"wrong subject for service grant denied"
(acl-permit? db (quote alice) (quote federate) (quote peer1))
false)
(acl-dt-check!
"grant plus deny -> deny wins"
(acl-permit? db (quote alice) (quote edit) (quote page1))
false)
(acl-dt-check!
"deny alone still denies"
(acl-permit?
(acl-build-db
(list (acl-deny (quote alice) (quote read) (quote page1))))
(quote alice)
(quote read)
(quote page1))
false)
(acl-dt-check!
"deny on edit does not block read"
(acl-permit? db (quote alice) (quote read) (quote page1))
true)
(acl-dt-check!
"empty db denies"
(acl-permit?
(acl-build-db (list))
(quote alice)
(quote read)
(quote page1))
false)
(let
((db2 (acl-build-db (list (acl-grant (quote a) (quote read) (quote r)) (acl-grant (quote b) (quote read) (quote r)) (acl-deny (quote b) (quote read) (quote r))))))
(do
(acl-dt-check!
"subject a allowed"
(acl-permit? db2 (quote a) (quote read) (quote r))
true)
(acl-dt-check!
"subject b denied by override"
(acl-permit? db2 (quote b) (quote read) (quote r))
false)))
(let
((db3 (acl-build-db (list (acl-actor (quote editors) (quote role)) (acl-grant (quote editors) (quote edit) (quote post1))))))
(acl-dt-check!
"role subject direct grant"
(acl-permit? db3 (quote editors) (quote edit) (quote post1))
true))
(do
(acl/load!
(list
(acl-grant (quote carol) (quote moderate) (quote thread1))))
(acl-dt-check!
"api permit via current db"
(acl/permit? (quote carol) (quote moderate) (quote thread1))
true)
(acl-dt-check!
"api deny via current db"
(acl/permit? (quote carol) (quote read) (quote thread1))
false))
(do
(acl/load! (list))
(acl-dt-check!
"api reload clears prior grants"
(acl/permit? (quote carol) (quote moderate) (quote thread1))
false))
(acl-dt-check!
"schema grant arity valid"
(acl-fact-valid? (acl-grant (quote x) (quote read) (quote y)))
true)
(acl-dt-check!
"schema bad arity invalid"
(acl-fact-valid? (list (quote grant) (quote x)))
false)
(acl-dt-check!
"schema unknown predicate invalid"
(acl-fact-valid? (list (quote frobnicate) (quote x)))
false)
(acl-dt-check!
"schema subject kind known"
(acl-subject-kind? (quote service))
true)
(acl-dt-check!
"schema resource kind unknown"
(acl-resource-kind? (quote galaxy))
false)
(acl-dt-check!
"schema known action"
(acl-known-action? (quote moderate))
true)
(acl-dt-check!
"grant constructor shape"
(acl-grant (quote u) (quote read) (quote p))
(list (quote grant) (quote u) (quote read) (quote p)))
(acl-dt-check!
"actor constructor shape"
(acl-actor (quote u) (quote user))
(list (quote actor) (quote u) (quote user)))))))
(define
acl-direct-tests-run!
(fn
()
(do
(set! acl-dt-pass 0)
(set! acl-dt-fail 0)
(set! acl-dt-failures (list))
(acl-dt-run-all!)
{:failures acl-dt-failures :total (+ acl-dt-pass acl-dt-fail) :passed acl-dt-pass :failed acl-dt-fail})))

316
lib/acl/tests/explain.sx
View File

@@ -1,316 +0,0 @@
;; lib/acl/tests/explain.sx — Phase 3: proof correctness + audit completeness.
(define acl-et-pass 0)
(define acl-et-fail 0)
(define acl-et-failures (list))
;; Name-based deep equality. The host `=` compares symbols by interned
;; identity, which is unstable across substitution/saturation; comparing by
;; name (as the datalog suite does) makes structural assertions deterministic.
(define
acl-et-eq?
(fn
(a b)
(cond
((and (list? a) (list? b))
(and (= (len a) (len b)) (acl-et-eq-l? a b 0)))
((and (dict? a) (dict? b))
(let
((ka (keys a)) (kb (keys b)))
(and (= (len ka) (len kb)) (acl-et-eq-d? a b ka 0))))
((and (symbol? a) (symbol? b))
(= (symbol->string a) (symbol->string b)))
(else (= a b)))))
(define
acl-et-eq-l?
(fn
(a b i)
(cond
((>= i (len a)) true)
((not (acl-et-eq? (nth a i) (nth b i))) false)
(else (acl-et-eq-l? a b (+ i 1))))))
(define
acl-et-eq-d?
(fn
(a b ka i)
(cond
((>= i (len ka)) true)
((let ((k (nth ka i))) (not (acl-et-eq? (get a k) (get b k))))
false)
(else (acl-et-eq-d? a b ka (+ i 1))))))
(define
acl-et-check!
(fn
(name got expected)
(if
(acl-et-eq? got expected)
(set! acl-et-pass (+ acl-et-pass 1))
(do
(set! acl-et-fail (+ acl-et-fail 1))
(append!
acl-et-failures
(str name "\n expected: " expected "\n got: " got))))))
;; --- proof-tree walkers ---
;; True if EDB fact `target` appears as a base leaf anywhere in the proof.
(define
acl-et-has-leaf?
(fn
(node target)
(cond
((= node nil) false)
((and (dict? node) (has-key? node :via))
(acl-et-eq? (get node :fact) target))
((and (dict? node) (has-key? node :body))
(acl-et-any-leaf? (get node :body) target))
(else false))))
(define
acl-et-any-leaf?
(fn
(nodes target)
(cond
((= (len nodes) 0) false)
((acl-et-has-leaf? (first nodes) target) true)
(else (acl-et-any-leaf? (rest nodes) target)))))
;; True if the proof records a verified negation (deny did not fire).
(define
acl-et-has-negok?
(fn
(node)
(cond
((= node nil) false)
((and (dict? node) (has-key? node :neg-ok)) true)
((and (dict? node) (has-key? node :body))
(acl-et-any-negok? (get node :body)))
(else false))))
(define
acl-et-any-negok?
(fn
(nodes)
(cond
((= (len nodes) 0) false)
((acl-et-has-negok? (first nodes)) true)
(else (acl-et-any-negok? (rest nodes))))))
(define
acl-et-run-all!
(fn
()
(do
(let
((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p))))))
(let
((e (acl-explain db (quote u) (quote read) (quote p))))
(do
(acl-et-check! "direct: allowed?" (get e :allowed?) true)
(acl-et-check!
"direct: proof root fact"
(get (get e :proof) :fact)
(list (quote permit) (quote u) (quote read) (quote p)))
(acl-et-check!
"direct: grant leaf present"
(acl-et-has-leaf?
(get e :proof)
(list (quote grant) (quote u) (quote read) (quote p)))
true)
(acl-et-check!
"direct: negation verified"
(acl-et-has-negok? (get e :proof))
true)
(acl-et-check!
"direct: reason nil when allowed"
(get e :reason)
nil))))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-grant (quote org) (quote read) (quote doc))))))
(let
((e (acl-explain db (quote alice) (quote read) (quote doc))))
(do
(acl-et-check! "group: allowed?" (get e :allowed?) true)
(acl-et-check!
"group: member_of alice leaf"
(acl-et-has-leaf?
(get e :proof)
(list (quote member_of) (quote alice) (quote team)))
true)
(acl-et-check!
"group: member_of team leaf"
(acl-et-has-leaf?
(get e :proof)
(list (quote member_of) (quote team) (quote org)))
true)
(acl-et-check!
"group: grant org leaf at base"
(acl-et-has-leaf?
(get e :proof)
(list (quote grant) (quote org) (quote read) (quote doc)))
true))))
(let
((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
(let
((e (acl-explain db (quote u) (quote read) (quote sec))))
(do
(acl-et-check! "resource: allowed?" (get e :allowed?) true)
(acl-et-check!
"resource: child_of leaf"
(acl-et-has-leaf?
(get e :proof)
(list (quote child_of) (quote sec) (quote book)))
true)
(acl-et-check!
"resource: grant on parent leaf"
(acl-et-has-leaf?
(get e :proof)
(list (quote grant) (quote u) (quote read) (quote book)))
true))))
(let
((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
(let
((e (acl-explain db (quote bob) (quote edit) (quote page1))))
(do
(acl-et-check! "role: allowed?" (get e :allowed?) true)
(acl-et-check!
"role: member_of leaf"
(acl-et-has-leaf?
(get e :proof)
(list (quote member_of) (quote bob) (quote editor)))
true)
(acl-et-check!
"role: role_grant leaf"
(acl-et-has-leaf?
(get e :proof)
(list
(quote role_grant)
(quote editor)
(quote edit)
(quote page1)))
true))))
(let
((db (acl-build-db (list (acl-grant (quote u) (quote edit) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
(let
((e (acl-explain db (quote u) (quote edit) (quote p))))
(do
(acl-et-check! "deny: not allowed" (get e :allowed?) false)
(acl-et-check! "deny: no proof" (get e :proof) nil)
(acl-et-check!
"deny: reason root is eff_deny"
(get (get e :reason) :fact)
(list (quote eff_deny) (quote u) (quote edit) (quote p)))
(acl-et-check!
"deny: reason has deny leaf"
(acl-et-has-leaf?
(get e :reason)
(list (quote deny) (quote u) (quote edit) (quote p)))
true))))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
(let
((e (acl-explain db (quote alice) (quote read) (quote doc))))
(do
(acl-et-check!
"inherited deny: not allowed"
(get e :allowed?)
false)
(acl-et-check!
"inherited deny: reason has member_of leaf"
(acl-et-has-leaf?
(get e :reason)
(list (quote member_of) (quote alice) (quote team)))
true)
(acl-et-check!
"inherited deny: reason has group deny leaf"
(acl-et-has-leaf?
(get e :reason)
(list (quote deny) (quote team) (quote read) (quote doc)))
true))))
(let
((db (acl-build-db (list))))
(let
((e (acl-explain db (quote u) (quote read) (quote p))))
(do
(acl-et-check! "no grant: not allowed" (get e :allowed?) false)
(acl-et-check! "no grant: proof nil" (get e :proof) nil)
(acl-et-check! "no grant: reason nil" (get e :reason) nil))))
(let
((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
(do
(acl-audit-clear!)
(acl-et-check! "audit: starts empty" (acl-audit-count) 0)
(acl-et-check!
"audit decide allowed returns true"
(acl-audit-decide! db (quote u) (quote read) (quote p))
true)
(acl-et-check!
"audit decide denied returns false"
(acl-audit-decide! db (quote u) (quote edit) (quote p))
false)
(acl-audit-decide! db (quote u) (quote comment) (quote p))
(acl-et-check!
"audit: count after three decisions"
(acl-audit-count)
3)
(acl-et-check!
"audit: tail size respects n"
(len (acl-audit-tail 2))
2)
(acl-et-check!
"audit: tail returns most recent"
(get (first (acl-audit-tail 1)) :act)
(quote comment))
(acl-et-check!
"audit: first record seq is 0"
(get (first (acl-audit-tail 3)) :seq)
0)
(acl-et-check!
"audit: allowed flag recorded"
(get (first (acl-audit-tail 3)) :allowed?)
true)
(acl-et-check!
"audit: serialize line count"
(len (acl-et-lines (acl-audit-serialize)))
3)
(acl-audit-clear!)
(acl-et-check!
"audit: clear resets count"
(acl-audit-count)
0))))))
;; count newline-terminated lines in a serialized log
(define acl-et-lines (fn (s) (acl-et-count-nl s 0 0)))
(define
acl-et-count-nl
(fn
(s i n)
(if
(>= i (len s))
(if (= n 0) (list) (acl-et-rangelist n))
(acl-et-count-nl
s
(+ i 1)
(if (= (slice s i (+ i 1)) "\n") (+ n 1) n)))))
(define
acl-et-rangelist
(fn
(n)
(if
(<= n 0)
(list)
(cons n (acl-et-rangelist (- n 1))))))
(define
acl-explain-tests-run!
(fn
()
(do
(set! acl-et-pass 0)
(set! acl-et-fail 0)
(set! acl-et-failures (list))
(acl-et-run-all!)
{:failures acl-et-failures :total (+ acl-et-pass acl-et-fail) :passed acl-et-pass :failed acl-et-fail})))

273
lib/acl/tests/fed.sx
View File

@@ -1,273 +0,0 @@
;; lib/acl/tests/fed.sx — Phase 4: federation (peer trust, delegation,
;; cross-instance chains, revocation). fed-sx transport is mocked as a dict.
(define acl-ft-pass 0)
(define acl-ft-fail 0)
(define acl-ft-failures (list))
;; Name-based deep equality (host `=` compares symbols by unstable interned
;; identity; see lib/acl/tests/explain.sx).
(define
acl-ft-eq?
(fn
(a b)
(cond
((and (list? a) (list? b))
(and (= (len a) (len b)) (acl-ft-eq-l? a b 0)))
((and (symbol? a) (symbol? b))
(= (symbol->string a) (symbol->string b)))
(else (= a b)))))
(define
acl-ft-eq-l?
(fn
(a b i)
(cond
((>= i (len a)) true)
((not (acl-ft-eq? (nth a i) (nth b i))) false)
(else (acl-ft-eq-l? a b (+ i 1))))))
(define
acl-ft-check!
(fn
(name got expected)
(if
(acl-ft-eq? got expected)
(set! acl-ft-pass (+ acl-ft-pass 1))
(do
(set! acl-ft-fail (+ acl-ft-fail 1))
(append!
acl-ft-failures
(str name "\n expected: " expected "\n got: " got))))))
;; proof leaf walker (federated proofs reconstruct through the engine rule).
(define
acl-ft-has-leaf?
(fn
(node target)
(cond
((= node nil) false)
((and (dict? node) (has-key? node :via))
(acl-ft-eq? (get node :fact) target))
((and (dict? node) (has-key? node :body))
(acl-ft-any-leaf? (get node :body) target))
(else false))))
(define
acl-ft-any-leaf?
(fn
(nodes target)
(cond
((= (len nodes) 0) false)
((acl-ft-has-leaf? (first nodes) target) true)
(else (acl-ft-any-leaf? (rest nodes) target)))))
(define acl-ft-p? (fn (db s a r) (acl-permit? db s a r)))
;; A standard federation fixture: local trusts peer alpha at "readonly", which
;; covers read+comment. alpha delegates several capabilities to alice.
(define
acl-ft-fixture
(fn
()
(acl-build-db
(list
(acl-trust (quote alpha) (quote readonly))
(acl-level-covers (quote readonly) (quote read))
(acl-level-covers (quote readonly) (quote comment))
(acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))
(acl-delegate (quote alpha) (quote alice) (quote edit) (quote doc))))))
(define
acl-ft-run-all!
(fn
()
(do
(let
((db (acl-ft-fixture)))
(do
(acl-ft-check!
"trusted delegate, level covers action -> permit"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
true)
(acl-ft-check!
"trusted delegate, level does NOT cover action -> deny"
(acl-ft-p? db (quote alice) (quote edit) (quote doc))
false)
(acl-ft-check!
"delegated but action class uncovered (comment has no delegate)"
(acl-ft-p? db (quote alice) (quote comment) (quote doc))
false)))
(let
((db (acl-build-db (list (acl-level-covers (quote readonly) (quote read)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
(acl-ft-check!
"untrusted peer delegate -> deny"
(acl-ft-p? db (quote bob) (quote read) (quote doc))
false))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
(acl-ft-check!
"trust but no level_covers -> deny"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
false))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
(do
(acl-ft-check!
"trust is per-peer: alpha's delegate applies"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
true)
(acl-ft-check!
"trust not transitive: beta's delegate does not apply"
(acl-ft-p? db (quote bob) (quote read) (quote doc))
false)))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
(acl-ft-check!
"local deny overrides federated grant"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
false))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc))))))
(acl-ft-check!
"federated grant to group reaches member"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
true))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-child-of (quote sec) (quote book)) (acl-delegate (quote alpha) (quote u) (quote read) (quote book))))))
(acl-ft-check!
"federated grant on parent resource reaches child"
(acl-ft-p? db (quote u) (quote read) (quote sec))
true))
(let
((transport {:gamma (list (acl-delegate (quote gamma) (quote carol) (quote read) (quote post))) :alpha (list (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)))}))
(do
(acl-ft-check!
"fetch known peer returns its delegates"
(len (acl-fed-fetch transport (quote alpha)))
1)
(acl-ft-check!
"fetch unknown peer returns empty"
(len (acl-fed-fetch transport (quote delta)))
0)
(acl-ft-check!
"collect across peers"
(len
(acl-fed-collect transport (list (quote alpha) (quote gamma))))
2)
(let
((db (acl-fed-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-trust (quote gamma) (quote readonly)) (acl-level-covers (quote readonly) (quote read))) transport (list (quote alpha) (quote gamma)))))
(do
(acl-ft-check!
"fed-build-db: alpha delegate permits"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
true)
(acl-ft-check!
"fed-build-db: gamma delegate permits"
(acl-ft-p? db (quote carol) (quote read) (quote post))
true)
(acl-ft-check!
"fed-build-db: untrusted action still denied"
(acl-ft-p? db (quote alice) (quote edit) (quote doc))
false)))))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
(do
(acl-ft-check!
"before revoke: permitted"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
true)
(acl-revoke!
db
(acl-delegate
(quote alpha)
(quote alice)
(quote read)
(quote doc)))
(acl-ft-check!
"after delegate revoked: denied"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
false)))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
(do
(acl-ft-check!
"before trust revoke: permitted"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
true)
(acl-revoke! db (acl-trust (quote alpha) (quote full)))
(acl-ft-check!
"after trust revoked: denied"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
false)))
(let
((db (acl-build-db (list (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
(do
(acl-ft-check!
"delegate without trust: denied"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
false)
(acl-fed-assert! db (acl-trust (quote alpha) (quote full)))
(acl-ft-check!
"trust ingested then re-checked: permitted"
(acl-ft-p? db (quote alice) (quote read) (quote doc))
true)))
(let
((db (acl-ft-fixture)))
(let
((e (acl-explain db (quote alice) (quote read) (quote doc))))
(do
(acl-ft-check! "federated proof allowed?" (get e :allowed?) true)
(acl-ft-check!
"federated proof has delegate leaf"
(acl-ft-has-leaf?
(get e :proof)
(list
(quote delegate)
(quote alpha)
(quote alice)
(quote read)
(quote doc)))
true)
(acl-ft-check!
"federated proof has trust leaf"
(acl-ft-has-leaf?
(get e :proof)
(list (quote trust) (quote alpha) (quote readonly)))
true)
(acl-ft-check!
"federated proof has level_covers leaf"
(acl-ft-has-leaf?
(get e :proof)
(list (quote level_covers) (quote readonly) (quote read)))
true))))
(acl-ft-check!
"schema delegate arity valid"
(acl-fact-valid?
(acl-delegate (quote p) (quote s) (quote a) (quote r)))
true)
(acl-ft-check!
"schema trust arity valid"
(acl-fact-valid? (acl-trust (quote p) (quote l)))
true)
(acl-ft-check!
"schema peer arity valid"
(acl-fact-valid? (acl-peer (quote p) (quote peer)))
true)
(acl-ft-check!
"schema level_covers arity valid"
(acl-fact-valid? (acl-level-covers (quote l) (quote read)))
true)
(acl-ft-check!
"schema delegate bad arity invalid"
(acl-fact-valid? (list (quote delegate) (quote p) (quote s)))
false))))
(define
acl-fed-tests-run!
(fn
()
(do
(set! acl-ft-pass 0)
(set! acl-ft-fail 0)
(set! acl-ft-failures (list))
(acl-ft-run-all!)
{:failures acl-ft-failures :total (+ acl-ft-pass acl-ft-fail) :passed acl-ft-pass :failed acl-ft-fail})))

228
lib/acl/tests/harden.sx
View File

@@ -1,228 +0,0 @@
;; lib/acl/tests/harden.sx — adversarial / cross-phase hardening.
;;
;; Diamond hierarchies, conflict resolution where deny must win through every
;; path, chain inheritance, cycle termination, multi-peer delegation, fact
;; validation, and audit save/restore.
;;
;; PROVER-FREE BY DESIGN: this suite calls only acl-permit? (which runs in
;; compiled Datalog, safe at any depth) plus pure data ops — never acl-explain /
;; acl-prove-d. The SX-side proof reconstructor recurses, and once the kernel
;; JIT-compiles it (after the explain/fed suites warm the process) it loops on
;; chains deeper than ~3 (substrate JIT bug — see plan Blockers). Proof
;; reconstruction is covered by tests/explain.sx (and federated proofs by
;; tests/fed.sx), both of which stay under the warm-process depth threshold.
(define acl-hd-pass 0)
(define acl-hd-fail 0)
(define acl-hd-failures (list))
(define
acl-hd-check!
(fn
(name got expected)
(if
(= got expected)
(set! acl-hd-pass (+ acl-hd-pass 1))
(do
(set! acl-hd-fail (+ acl-hd-fail 1))
(append!
acl-hd-failures
(str name "\n expected: " expected "\n got: " got))))))
(define acl-hd-p? (fn (db s a r) (acl-permit? db s a r)))
(define
acl-hd-run-all!
(fn
()
(do
(let
((grant-deny (acl-build-db (list (acl-child-of (quote r) (quote p1)) (acl-child-of (quote r) (quote p2)) (acl-grant (quote u) (quote read) (quote p1)) (acl-deny (quote u) (quote read) (quote p2)))))
(both-grant
(acl-build-db
(list
(acl-child-of (quote r) (quote p1))
(acl-child-of (quote r) (quote p2))
(acl-grant (quote u) (quote read) (quote p1))
(acl-grant (quote u) (quote read) (quote p2))))))
(do
(acl-hd-check!
"diamond resource: grant+deny parents -> deny wins"
(acl-hd-p? grant-deny (quote u) (quote read) (quote r))
false)
(acl-hd-check!
"diamond resource: both grant -> permit"
(acl-hd-p? both-grant (quote u) (quote read) (quote r))
true)
(acl-hd-check!
"diamond resource: deny does not leak to other parent"
(acl-hd-p? grant-deny (quote u) (quote read) (quote p1))
true)))
(let
((grant-deny (acl-build-db (list (acl-member-of (quote alice) (quote g1)) (acl-member-of (quote alice) (quote g2)) (acl-grant (quote g1) (quote read) (quote doc)) (acl-deny (quote g2) (quote read) (quote doc)))))
(both-grant
(acl-build-db
(list
(acl-member-of (quote alice) (quote g1))
(acl-member-of (quote alice) (quote g2))
(acl-grant (quote g1) (quote read) (quote doc))
(acl-grant (quote g2) (quote read) (quote doc))))))
(do
(acl-hd-check!
"diamond group: grant+deny groups -> deny wins"
(acl-hd-p? grant-deny (quote alice) (quote read) (quote doc))
false)
(acl-hd-check!
"diamond group: both grant -> permit"
(acl-hd-p? both-grant (quote alice) (quote read) (quote doc))
true)))
(let
((chain (acl-build-db (list (acl-member-of (quote a0) (quote a1)) (acl-member-of (quote a1) (quote a2)) (acl-member-of (quote a2) (quote a3)) (acl-member-of (quote a3) (quote a4)) (acl-grant (quote a4) (quote read) (quote res)))))
(chain-deny
(acl-build-db
(list
(acl-member-of (quote a0) (quote a1))
(acl-member-of (quote a1) (quote a2))
(acl-member-of (quote a2) (quote a3))
(acl-member-of (quote a3) (quote a4))
(acl-grant (quote a4) (quote read) (quote res))
(acl-deny (quote a0) (quote read) (quote res))))))
(do
(acl-hd-check!
"chain: top-group grant reaches leaf member"
(acl-hd-p? chain (quote a0) (quote read) (quote res))
true)
(acl-hd-check!
"chain: intermediate also covered"
(acl-hd-p? chain (quote a2) (quote read) (quote res))
true)
(acl-hd-check!
"chain: leaf-member deny overrides top grant"
(acl-hd-p? chain-deny (quote a0) (quote read) (quote res))
false)
(acl-hd-check!
"chain: deny on leaf does not block sibling level"
(acl-hd-p? chain-deny (quote a1) (quote read) (quote res))
true)))
(let
((self-member (acl-build-db (list (acl-member-of (quote a) (quote a)) (acl-grant (quote a) (quote read) (quote r)))))
(self-child
(acl-build-db
(list
(acl-child-of (quote r) (quote r))
(acl-grant (quote u) (quote read) (quote r)))))
(two-cycle
(acl-build-db
(list
(acl-member-of (quote x) (quote y))
(acl-member-of (quote y) (quote x))
(acl-grant (quote y) (quote read) (quote r))))))
(do
(acl-hd-check!
"self-membership cycle terminates and grants"
(acl-hd-p? self-member (quote a) (quote read) (quote r))
true)
(acl-hd-check!
"self-child cycle terminates and grants"
(acl-hd-p? self-child (quote u) (quote read) (quote r))
true)
(acl-hd-check!
"two-node membership cycle terminates"
(acl-hd-p? two-cycle (quote x) (quote read) (quote r))
true)))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
(acl-hd-check!
"federated group grant, local member deny -> deny wins"
(acl-hd-p? db (quote alice) (quote read) (quote doc))
false))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
(acl-hd-check!
"two peers delegate, one trusted -> permit"
(acl-hd-p? db (quote bob) (quote read) (quote doc))
true))
(let
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-trust (quote beta) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
(acl-hd-check!
"two peers both trusted -> permit"
(acl-hd-p? db (quote bob) (quote read) (quote doc))
true))
(let
((empty (acl-build-db (list))))
(acl-hd-check!
"empty db: nothing permitted"
(acl-hd-p? empty (quote u) (quote read) (quote r))
false))
(do
(acl-hd-check!
"validate: clean set has no bad facts"
(len
(acl-validate-facts
(list
(acl-grant (quote u) (quote read) (quote p))
(acl-member-of (quote u) (quote g))
(acl-delegate (quote pe) (quote u) (quote read) (quote p)))))
0)
(acl-hd-check!
"validate: facts-valid? true on clean set"
(acl-facts-valid?
(list (acl-grant (quote u) (quote read) (quote p))))
true)
(acl-hd-check!
"validate: surfaces wrong-arity and unknown predicate"
(len
(acl-validate-facts
(list
(acl-grant (quote u) (quote read) (quote p))
(list (quote grant) (quote u))
(list (quote bogus) (quote x) (quote y)))))
2)
(acl-hd-check!
"validate: empty set is valid"
(acl-facts-valid? (list))
true))
(let
((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
(do
(acl-audit-clear!)
(acl-audit-decide! db (quote u) (quote read) (quote p))
(acl-audit-decide! db (quote u) (quote edit) (quote p))
(let
((snap (acl-audit-snapshot)))
(do
(acl-audit-clear!)
(acl-hd-check!
"audit: cleared count is 0"
(acl-audit-count)
0)
(acl-audit-restore! snap)
(acl-hd-check!
"audit: restored count"
(acl-audit-count)
2)
(acl-hd-check!
"audit: restored last act"
(get (first (acl-audit-tail 1)) :act)
(quote edit))
(acl-audit-decide! db (quote u) (quote comment) (quote p))
(acl-hd-check!
"audit: seq continues after restore"
(get (first (acl-audit-tail 1)) :seq)
2)
(acl-hd-check!
"audit: snapshot is an immutable copy"
(len (get snap :entries))
2)
(acl-audit-clear!))))))))
(define
acl-harden-tests-run!
(fn
()
(do
(set! acl-hd-pass 0)
(set! acl-hd-fail 0)
(set! acl-hd-failures (list))
(acl-hd-run-all!)
{:failures acl-hd-failures :total (+ acl-hd-pass acl-hd-fail) :passed acl-hd-pass :failed acl-hd-fail})))

202
lib/acl/tests/inherit.sx
View File

@@ -1,202 +0,0 @@
;; lib/acl/tests/inherit.sx — Phase 2: inheritance (groups, resource trees,
;; role expansion) with deny-overrides.
(define acl-it-pass 0)
(define acl-it-fail 0)
(define acl-it-failures (list))
(define
acl-it-check!
(fn
(name got expected)
(if
(= got expected)
(set! acl-it-pass (+ acl-it-pass 1))
(do
(set! acl-it-fail (+ acl-it-fail 1))
(append!
acl-it-failures
(str name "\n expected: " expected "\n got: " got))))))
(define acl-it-p? (fn (db s a r) (acl-permit? db s a r)))
(define
acl-it-run-all!
(fn
()
(do
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc))))))
(do
(acl-it-check!
"group grant reaches member"
(acl-it-p? db (quote alice) (quote read) (quote doc))
true)
(acl-it-check!
"group grant: non-member excluded"
(acl-it-p? db (quote bob) (quote read) (quote doc))
false)
(acl-it-check!
"group grant: wrong action"
(acl-it-p? db (quote alice) (quote edit) (quote doc))
false)))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-member-of (quote org) (quote company)) (acl-grant (quote company) (quote read) (quote doc))))))
(do
(acl-it-check!
"deep nested group grant reaches leaf member"
(acl-it-p? db (quote alice) (quote read) (quote doc))
true)
(acl-it-check!
"intermediate group also covered"
(acl-it-p? db (quote team) (quote read) (quote doc))
true)
(acl-it-check!
"mid group org covered"
(acl-it-p? db (quote org) (quote read) (quote doc))
true)))
(let
((db (acl-build-db (list (acl-member-of (quote a) (quote b)) (acl-member-of (quote b) (quote a)) (acl-grant (quote b) (quote read) (quote r))))))
(do
(acl-it-check!
"cyclic membership terminates and grants"
(acl-it-p? db (quote a) (quote read) (quote r))
true)
(acl-it-check!
"cyclic membership covers both"
(acl-it-p? db (quote b) (quote read) (quote r))
true)))
(let
((db (acl-build-db (list (acl-child-of (quote sec) (quote chap)) (acl-child-of (quote chap) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
(do
(acl-it-check!
"parent grant reaches direct child"
(acl-it-p? db (quote u) (quote read) (quote chap))
true)
(acl-it-check!
"parent grant reaches deep descendant"
(acl-it-p? db (quote u) (quote read) (quote sec))
true)
(acl-it-check!
"parent grant covers parent itself"
(acl-it-p? db (quote u) (quote read) (quote book))
true)
(acl-it-check!
"child grant does not climb to parent"
(acl-it-p?
(acl-build-db
(list
(acl-child-of (quote sec) (quote book))
(acl-grant (quote u) (quote read) (quote sec))))
(quote u)
(quote read)
(quote book))
false)))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-child-of (quote post1) (quote board)) (acl-grant (quote team) (quote comment) (quote board))))))
(do
(acl-it-check!
"group + resource: member on child resource"
(acl-it-p? db (quote alice) (quote comment) (quote post1))
true)
(acl-it-check!
"group + resource: member on parent resource"
(acl-it-p? db (quote alice) (quote comment) (quote board))
true)))
(let
((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1)) (acl-role-grant (quote editor) (quote read) (quote page1))))))
(do
(acl-it-check!
"role confers edit to member"
(acl-it-p? db (quote bob) (quote edit) (quote page1))
true)
(acl-it-check!
"role confers read to member"
(acl-it-p? db (quote bob) (quote read) (quote page1))
true)
(acl-it-check!
"role: capability not in tuple denied"
(acl-it-p? db (quote bob) (quote moderate) (quote page1))
false)
(acl-it-check!
"role: non-member excluded"
(acl-it-p? db (quote eve) (quote edit) (quote page1))
false)))
(let
((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-child-of (quote draft) (quote page1)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
(acl-it-check!
"role grant flows to child resource"
(acl-it-p? db (quote bob) (quote edit) (quote draft))
true))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
(acl-it-check!
"explicit deny beats inherited group allow"
(acl-it-p? db (quote alice) (quote read) (quote doc))
false))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
(do
(acl-it-check!
"group deny inherits and overrides direct grant"
(acl-it-p? db (quote alice) (quote read) (quote doc))
false)
(acl-it-check!
"group deny: another member also blocked"
(acl-it-p? db (quote team) (quote read) (quote doc))
false)))
(let
((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote sec)) (acl-deny (quote u) (quote read) (quote book))))))
(acl-it-check!
"ancestor deny overrides descendant grant"
(acl-it-p? db (quote u) (quote read) (quote sec))
false))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-grant (quote team) (quote edit) (quote doc)) (acl-deny (quote alice) (quote edit) (quote doc))))))
(do
(acl-it-check!
"deny on edit leaves inherited read intact"
(acl-it-p? db (quote alice) (quote read) (quote doc))
true)
(acl-it-check!
"deny on edit blocks edit"
(acl-it-p? db (quote alice) (quote edit) (quote doc))
false)))
(let
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-deny (quote team) (quote read) (quote doc))))))
(acl-it-check!
"inherited deny, no grant: denied"
(acl-it-p? db (quote alice) (quote read) (quote doc))
false))
(let
((db (acl-build-db (list (acl-child-of (quote a) (quote root)) (acl-child-of (quote b) (quote root)) (acl-grant (quote u) (quote read) (quote root)) (acl-deny (quote u) (quote read) (quote a))))))
(do
(acl-it-check!
"deny on sibling a blocks a"
(acl-it-p? db (quote u) (quote read) (quote a))
false)
(acl-it-check!
"deny on sibling a leaves b permitted"
(acl-it-p? db (quote u) (quote read) (quote b))
true)
(acl-it-check!
"root itself still permitted"
(acl-it-p? db (quote u) (quote read) (quote root))
true)))
(let
((db (acl-build-db (list (acl-grant (quote x) (quote read) (quote y))))))
(acl-it-check!
"direct grant under inheritance ruleset"
(acl-it-p? db (quote x) (quote read) (quote y))
true)))))
(define
acl-inherit-tests-run!
(fn
()
(do
(set! acl-it-pass 0)
(set! acl-it-fail 0)
(set! acl-it-failures (list))
(acl-it-run-all!)
{:failures acl-it-failures :total (+ acl-it-pass acl-it-fail) :passed acl-it-pass :failed acl-it-fail})))

63
lib/apl/conformance.conf
View File

@@ -1,63 +0,0 @@
# APL conformance config — sourced by lib/guest/conformance.sh.
LANG_NAME=apl
MODE=counters
COUNTERS_PASS=apl-test-pass
COUNTERS_FAIL=apl-test-fail
TIMEOUT_PER_SUITE=300
PRELOADS=(
spec/stdlib.sx
lib/r7rs.sx
lib/apl/runtime.sx
lib/apl/tokenizer.sx
lib/apl/parser.sx
lib/apl/transpile.sx
lib/apl/test-harness.sx
)
SUITES=(
"structural:lib/apl/tests/structural.sx"
"operators:lib/apl/tests/operators.sx"
"dfn:lib/apl/tests/dfn.sx"
"tradfn:lib/apl/tests/tradfn.sx"
"valence:lib/apl/tests/valence.sx"
"programs:lib/apl/tests/programs.sx"
"system:lib/apl/tests/system.sx"
"idioms:lib/apl/tests/idioms.sx"
"eval-ops:lib/apl/tests/eval-ops.sx"
"pipeline:lib/apl/tests/pipeline.sx"
)
emit_scoreboard_json() {
local n=${#GC_NAMES[@]} i sep
printf '{\n'
printf ' "suites": {\n'
for ((i=0; i<n; i++)); do
sep=","; [ $i -eq $((n-1)) ] && sep=""
printf ' "%s": {"pass": %d, "fail": %d}%s\n' \
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "$sep"
done
printf ' },\n'
printf ' "total_pass": %d,\n' "$GC_TOTAL_PASS"
printf ' "total_fail": %d,\n' "$GC_TOTAL_FAIL"
printf ' "total": %d\n' "$GC_TOTAL"
printf '}\n'
}
emit_scoreboard_md() {
local n=${#GC_NAMES[@]} i
printf '# APL Conformance Scoreboard\n\n'
printf '_Generated by `lib/apl/conformance.sh`_\n\n'
printf '| Suite | Pass | Fail | Total |\n'
printf '|-------|-----:|-----:|------:|\n'
for ((i=0; i<n; i++)); do
printf '| %s | %d | %d | %d |\n' \
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "${GC_TOTAL_S[$i]}"
done
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$GC_TOTAL_PASS" "$GC_TOTAL_FAIL" "$GC_TOTAL"
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.'
}

5
lib/apl/conformance.sh
View File

@@ -1,5 +0,0 @@
#!/usr/bin/env bash
# lib/apl/conformance.sh — APL conformance via the shared guest driver.
# Config lives in lib/apl/conformance.conf (MODE=counters). Override the binary
# with SX_SERVER=path/to/sx_server.exe bash lib/apl/conformance.sh
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

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))))

1742
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": 152, "fail": 0}
},
"total_pass": 562,
"total_fail": 0,
"total": 562
}

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 | 152 | 0 | 152 |
| **Total** | **562** | **0** | **562** |
## 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.

15
lib/apl/test-harness.sx
View File

@@ -1,15 +0,0 @@
; lib/apl/test-harness.sx — counters + assertion fn for the shared conformance
; driver (lib/guest/conformance.sh, MODE=counters). Loaded as a PRELOAD so each
; suite starts from a fresh 0/0; suites call (apl-test name got expected).
(define apl-test-pass 0)
(define apl-test-fail 0)
(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)))))

33
lib/apl/test.sh
View File

@@ -4,9 +4,9 @@
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
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."
@@ -18,38 +18,19 @@ 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})))))))")
(load "lib/apl/tests/runtime.sx")
(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)
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {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/\)$//')
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
| sed -E 's/^\(ok 3 //; s/\)$//')
fi
if [ -z "$LINE" ]; then
echo "ERROR: could not extract summary"

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}

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))))

88
lib/artdag/analyze.sx
View File

@@ -1,88 +0,0 @@
; lib/artdag/analyze.sx — Phase 2: Analyze on Datalog.
; Project the DAG's edges into a Datalog db and answer dependency questions
; (deps, dependents, transitive reachability) plus dirty-closure propagation
; as recursive Datalog — the acl/relations reachability shape. Depends on
; lib/artdag/dag.sx and the lib/datalog/ public API.
; edge(input-id, node-id): data flows input -> node (input is a dependency).
(define
artdag/edge-facts
(fn
(dag)
(reduce
(fn
(acc id)
(concat
acc
(map
(fn (in) (list (quote edge) in id))
(artdag/node-inputs (artdag/dag-get dag id)))))
(list)
(keys (artdag/dag-nodes dag)))))
; reachable(X,Y): Y is a transitive dependent of X (forward, downstream).
(define
artdag/reach-rules
(quote
((reachable X Y <- (edge X Y))
(reachable X Z <- (edge X Y) (reachable Y Z)))))
(define
artdag/analyze
(fn (dag) (dl-program-data (artdag/edge-facts dag) artdag/reach-rules)))
; pull a single variable's bindings out of a subst list, sorted for determinism.
(define
artdag/-bindings
(fn
(substs var)
(artdag/sort-strings (map (fn (s) (get s var)) substs))))
; direct dependencies (inputs) of a node.
(define
artdag/deps-of
(fn
(db id)
(artdag/-bindings (dl-query db (list (quote edge) (quote X) id)) :X)))
; direct dependents of a node.
(define
artdag/dependents-of
(fn
(db id)
(artdag/-bindings (dl-query db (list (quote edge) id (quote Y))) :Y)))
; transitive dependents (everything downstream of a node).
(define
artdag/reachable-from
(fn
(db id)
(artdag/-bindings
(dl-query db (list (quote reachable) id (quote Y)))
:Y)))
; transitive dependencies (everything upstream of a node).
(define
artdag/ancestors-of
(fn
(db id)
(artdag/-bindings
(dl-query db (list (quote reachable) (quote X) id))
:X)))
; dirty propagation: dirty(Y) :- edge(X,Y), dirty(X). Seeds are changed nodes.
(define artdag/dirty-rules (quote ((dirty Y <- (edge X Y) (dirty X)))))
(define
artdag/dirty-seeds
(fn (changed) (map (fn (c) (list (quote dirty) c)) changed)))
; transitive dirty closure of a set of changed node-ids: the changed nodes plus
; every transitive dependent that must recompute. Sorted, deduplicated.
(define
artdag/dirty-closure
(fn
(dag changed)
(let
((db (dl-program-data (concat (artdag/edge-facts dag) (artdag/dirty-seeds changed)) artdag/dirty-rules)))
(artdag/-bindings (dl-query db (list (quote dirty) (quote X))) :X))))

91
lib/artdag/api.sx
View File

@@ -1,91 +0,0 @@
; lib/artdag/api.sx — public API index for the artdag content-addressed dataflow
; DAG engine. Reference-only: `load` is an epoch-protocol command, not an SX
; function, so this file cannot reload the modules from inside another `.sx`. To
; set up a session, issue these loads in order (after spec/stdlib.sx + lib/r7rs.sx,
; the lib/datalog/* modules, and the lib/persist/* modules):
;
; (load "lib/artdag/dag.sx")
; (load "lib/artdag/analyze.sx") ; requires lib/datalog/*
; (load "lib/artdag/plan.sx")
; (load "lib/artdag/execute.sx") ; requires lib/persist/*
; (load "lib/artdag/optimize.sx")
; (load "lib/artdag/federation.sx")
; (load "lib/artdag/cost.sx")
; (load "lib/artdag/serialize.sx")
; (load "lib/artdag/stats.sx")
; (load "lib/artdag/fault.sx")
;
; (lib/artdag/conformance.sh runs this load list automatically.)
;
; ── Public API surface ─────────────────────────────────────────────
;
; Model / content addressing (dag.sx):
; (artdag/node op inputs params) node spec (non-commutative)
; (artdag/cnode op inputs params) commutative node spec
; (artdag/content-id node) structural digest "node:..."
; (artdag/build entries) {:ok :nodes :names :order} | {:ok false :error}
; entry = (name op (input-names...) params [commutative?])
; (artdag/dag-id dag name) local name -> content-id
; (artdag/dag-get dag id) content-id -> node
; (artdag/dag-node-by-name dag name) name -> node
; (artdag/dag-order dag) topo-ordered content-ids
; (artdag/node-count dag) distinct node count
;
; Analyze on Datalog (analyze.sx):
; (artdag/analyze dag) -> datalog db
; (artdag/deps-of db id) direct dependencies
; (artdag/dependents-of db id) direct dependents
; (artdag/reachable-from db id) transitive dependents
; (artdag/ancestors-of db id) transitive dependencies
; (artdag/dirty-closure dag changed) changed nodes + all dependents
;
; Plan (plan.sx):
; (artdag/plan dag cap) topo batches under width cap (0 = unlimited)
; (artdag/plan-dirty dag changed cap) incremental plan over the dirty closure
; (artdag/plan-batches/-width/-size/-flatten plan)
;
; Execute (execute.sx):
; (artdag/op-table-runner table) runner from op-name -> (fn (params inputs))
; (artdag/run dag runner cache) full memoized run
; (artdag/run-dirty dag changed runner cache)
; (artdag/execute dag plan runner cache) -> {:results :recomputed :hits}
; (artdag/result-of/recompute-count/hit-count/recomputed exec)
; cache = a lib/persist kv backend (persist/open)
;
; Optimize (optimize.sx):
; (artdag/dce dag outputs) drop nodes not feeding the outputs
; (artdag/cse entries) == build (sharing is free from content ids)
; (artdag/fuse entries fusible?) collapse fusible unary chains -> pipeline nodes
; (artdag/fusing-runner base-runner) runner that replays pipeline stages
; (artdag/optimize entries outputs fusible?) fuse then dce
;
; Federation (federation.sx):
; (artdag/fed-open) {:cache :prov}
; (artdag/fed-run fed dag runner) run against the instance cache
; (artdag/fed-export fed peer-id) bundle of {:cid :result :peer}
; (artdag/fed-import fed bundle trusted?) trust-gated import + provenance
; (artdag/fed-pull fed fetch-fn peer-id trusted?) pull via injected transport
; (artdag/fed-invalidate fed peer-id) drop a peer's results (peer-scoped)
;
; Cost / scheduling (cost.sx):
; (artdag/const-cost) (artdag/op-cost table) cost-fn (op params) -> number
; (artdag/critical-path dag cost-fn) longest weighted path
; (artdag/makespan dag plan cost-fn) estimated wall-clock under a plan
; (artdag/total-work dag cost-fn) (artdag/speedup dag plan cost-fn)
;
; Serialize (serialize.sx):
; (artdag/dag->wire dag) (artdag/wire->dag records) portable record form
; (artdag/wire-verify records) content-id integrity check
; (artdag/dag->string dag) (artdag/string->dag s) text transport
;
; Stats (stats.sx):
; (artdag/hit-ratio exec)
; (artdag/work-recomputed/work-saved exec dag cost-fn)
; (artdag/savings-ratio exec dag cost-fn) (artdag/exec-summary exec dag cost-fn)
;
; Fault tolerance (fault.sx):
; (artdag/fail reason) (artdag/failed? v)
; (artdag/run-safe dag runner cache) -> {:results :recomputed :hits :failed}
; (artdag/failed-nodes/failure-count/all-ok? exec)
(define artdag/version "1.0")

131
lib/artdag/conformance.sh
View File

@@ -1,131 +0,0 @@
#!/usr/bin/env bash
# lib/artdag/conformance.sh — run artdag 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=(dag analyze plan execute optimize fed cost serialize stats fault)
OUT_JSON="lib/artdag/scoreboard.json"
OUT_MD="lib/artdag/scoreboard.md"
run_suite() {
local suite=$1
local file="lib/artdag/tests/${suite}.sx"
local TMP
TMP=$(mktemp)
cat > "$TMP" << EPOCHS
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/r7rs.sx")
(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/persist/event.sx")
(load "lib/persist/backend.sx")
(load "lib/persist/log.sx")
(load "lib/persist/kv.sx")
(load "lib/persist/api.sx")
(load "lib/artdag/dag.sx")
(load "lib/artdag/analyze.sx")
(load "lib/artdag/plan.sx")
(load "lib/artdag/execute.sx")
(load "lib/artdag/optimize.sx")
(load "lib/artdag/federation.sx")
(load "lib/artdag/cost.sx")
(load "lib/artdag/serialize.sx")
(load "lib/artdag/stats.sx")
(load "lib/artdag/fault.sx")
(load "lib/artdag/api.sx")
(epoch 2)
(eval "(define artdag-test-pass 0)")
(eval "(define artdag-test-fail 0)")
(eval "(define artdag-test (fn (name got expected) (if (= got expected) (set! artdag-test-pass (+ artdag-test-pass 1)) (set! artdag-test-fail (+ artdag-test-fail 1)))))")
(epoch 3)
(load "${file}")
(epoch 4)
(eval "(list artdag-test-pass artdag-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 artdag 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
{
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"
{
printf '# artdag Conformance Scoreboard\n\n'
printf '_Generated by `lib/artdag/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))"
} > "$OUT_MD"
echo "Wrote $OUT_JSON and $OUT_MD" >&2
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
[ "$TOTAL_FAIL" -eq 0 ]

66
lib/artdag/cost.sx
View File

@@ -1,66 +0,0 @@
; lib/artdag/cost.sx — cost model for the scheduler: per-node weights, critical
; path (min makespan with unlimited parallelism), plan makespan under batching/cap,
; total serial work, and the resulting speedup. Costs come from an injected
; cost-fn (op params) -> number so media-op costs stay opaque. Depends on dag.sx.
(define artdag/const-cost (fn (op params) 1))
(define
artdag/op-cost
(fn
(table)
(fn (op params) (if (has-key? table op) (get table op) 1))))
(define
artdag/-node-cost
(fn
(dag cost-fn id)
(let
((n (artdag/dag-get dag id)))
(cost-fn (artdag/node-op n) (artdag/node-params n)))))
(define
artdag/-max
(fn (xs) (reduce (fn (mx x) (if (> x mx) x mx)) 0 xs)))
; longest weighted path through the dag = makespan with unlimited workers.
(define
artdag/critical-path
(fn
(dag cost-fn)
(let
((ft (reduce (fn (m id) (let ((maxdep (artdag/-max (map (fn (d) (get m d)) (artdag/node-inputs (artdag/dag-get dag id)))))) (assoc m id (+ (artdag/-node-cost dag cost-fn id) maxdep)))) {} (artdag/dag-order dag))))
(artdag/-max (map (fn (id) (get ft id)) (keys ft))))))
; estimated wall-clock for a plan: each batch runs in parallel (costs its
; slowest node), batches run in sequence.
(define
artdag/makespan
(fn
(dag plan cost-fn)
(reduce
(fn
(total batch)
(+
total
(artdag/-max
(map (fn (id) (artdag/-node-cost dag cost-fn id)) batch))))
0
plan)))
; total serial work = sum of all node costs.
(define
artdag/total-work
(fn
(dag cost-fn)
(reduce
(fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
0
(keys (artdag/dag-nodes dag)))))
; speedup of a plan vs running everything serially.
(define
artdag/speedup
(fn
(dag plan cost-fn)
(/ (artdag/total-work dag cost-fn) (artdag/makespan dag plan cost-fn))))

226
lib/artdag/dag.sx
View File

@@ -1,226 +0,0 @@
; lib/artdag/dag.sx — DAG model + structural content addressing.
; A node = {:op :inputs :params :commutative}. inputs are content-ids of upstream
; nodes. The content-id is a deterministic structural digest so identical
; subgraphs collapse to one id (and one cache slot). No clock, no randomness.
; ---- string ordering (no host sort/string<?) ----
(define
artdag/str<?-at
(fn
(a b i la lb)
(cond
((and (>= i la) (>= i lb)) false)
((>= i la) true)
((>= i lb) false)
(else
(let
((ca (char-code (substring a i (+ i 1))))
(cb (char-code (substring b i (+ i 1)))))
(cond
((< ca cb) true)
((> ca cb) false)
(else (artdag/str<?-at a b (+ i 1) la lb))))))))
(define
artdag/str<?
(fn
(a b)
(artdag/str<?-at a b 0 (string-length a) (string-length b))))
(define
artdag/insert-string
(fn
(sorted x)
(cond
((empty? sorted) (list x))
((artdag/str<? x (first sorted)) (cons x sorted))
(else (cons (first sorted) (artdag/insert-string (rest sorted) x))))))
(define
artdag/sort-strings
(fn (xs) (reduce (fn (acc x) (artdag/insert-string acc x)) (list) xs)))
; ---- canonical serialization ----
(define
artdag/canon-list
(fn
(xs)
(if
(empty? xs)
""
(reduce
(fn (acc x) (str acc " " (artdag/canon x)))
(artdag/canon (first xs))
(rest xs)))))
(define
artdag/canon-dict
(fn
(d)
(str
"{"
(reduce
(fn (acc k) (str acc " " k "=" (artdag/canon (get d k))))
""
(artdag/sort-strings (keys d)))
"}")))
(define
artdag/canon
(fn
(v)
(let
((t (type-of v)))
(cond
((equal? t "nil") "nil")
((equal? t "boolean") (if v "#t" "#f"))
((equal? t "number") (number->string v))
((equal? t "string") (str "\"" v "\""))
((equal? t "keyword") (str ":" (keyword-name v)))
((equal? t "symbol") (str "'" (write-to-string v)))
((equal? t "list") (str "(" (artdag/canon-list v) ")"))
((equal? t "dict") (artdag/canon-dict v))
(else (str "<" t ">" (write-to-string v)))))))
; ---- node + content id ----
(define artdag/node (fn (op inputs params) {:inputs inputs :commutative false :op op :params params}))
(define artdag/cnode (fn (op inputs params) {:inputs inputs :commutative true :op op :params params}))
(define artdag/node-op (fn (n) (get n :op)))
(define artdag/node-inputs (fn (n) (get n :inputs)))
(define artdag/node-params (fn (n) (get n :params)))
(define
artdag/content-id
(fn
(node)
(let
((ins (if (get node :commutative) (artdag/sort-strings (get node :inputs)) (get node :inputs))))
(str
"node:"
(artdag/canon (list (get node :op) ins (get node :params)))))))
(define artdag/id-of artdag/content-id)
; ---- list helpers ----
(define artdag/member? (fn (x xs) (some (fn (y) (equal? y x)) xs)))
(define
artdag/all-in?
(fn (xs placed) (every? (fn (x) (artdag/member? x placed)) xs)))
; ---- build: entries -> validated, content-addressed dag ----
; entry = (local-name op (input-local-names...) params [commutative?])
(define artdag/entry-name (fn (e) (nth e 0)))
(define artdag/entry-op (fn (e) (nth e 1)))
(define artdag/entry-inputs (fn (e) (nth e 2)))
(define artdag/entry-params (fn (e) (nth e 3)))
(define
artdag/entry-commutative
(fn (e) (if (> (len e) 4) (nth e 4) false)))
(define
artdag/entries->map
(fn
(entries)
(reduce
(fn (m e) (assoc m (artdag/entry-name e) {:inputs (artdag/entry-inputs e) :commutative (artdag/entry-commutative e) :op (artdag/entry-op e) :params (artdag/entry-params e)}))
{}
entries)))
(define
artdag/dangling
(fn
(spec-map)
(reduce
(fn
(acc name)
(reduce
(fn (a in) (if (has-key? spec-map in) a (cons in a)))
acc
(get (get spec-map name) :inputs)))
(list)
(keys spec-map))))
(define
artdag/ready-names
(fn
(spec-map placed)
(filter
(fn
(name)
(and
(not (artdag/member? name placed))
(artdag/all-in? (get (get spec-map name) :inputs) placed)))
(artdag/sort-strings (keys spec-map)))))
(define
artdag/topo-loop
(fn
(spec-map placed)
(if
(= (len placed) (len (keys spec-map)))
{:order placed :ok true}
(let
((ready (artdag/ready-names spec-map placed)))
(if
(empty? ready)
{:error "cycle" :ok false}
(artdag/topo-loop spec-map (concat placed ready)))))))
(define artdag/topo (fn (spec-map) (artdag/topo-loop spec-map (list))))
(define
artdag/resolve-ids
(fn
(spec-map order)
(reduce
(fn
(dag name)
(let
((spec (get spec-map name)))
(let
((resolved (map (fn (in) (get (get dag :names) in)) (get spec :inputs))))
(let
((node {:inputs resolved :commutative (get spec :commutative) :op (get spec :op) :params (get spec :params)}))
(let ((id (artdag/content-id node))) {:names (assoc (get dag :names) name id) :order (if (artdag/member? id (get dag :order)) (get dag :order) (concat (get dag :order) (list id))) :nodes (assoc (get dag :nodes) id node)})))))
{:names {} :order (list) :nodes {}}
order)))
(define
artdag/build
(fn
(entries)
(let
((spec-map (artdag/entries->map entries)))
(let
((dang (artdag/dangling spec-map)))
(if
(not (empty? dang))
{:refs dang :error "dangling" :ok false}
(let
((topo (artdag/topo spec-map)))
(if
(not (get topo :ok))
{:error (get topo :error) :ok false}
(assoc
(artdag/resolve-ids spec-map (get topo :order))
:ok true))))))))
; ---- dag accessors ----
(define artdag/dag-nodes (fn (dag) (get dag :nodes)))
(define artdag/dag-names (fn (dag) (get dag :names)))
(define artdag/dag-order (fn (dag) (get dag :order)))
(define artdag/dag-id (fn (dag name) (get (get dag :names) name)))
(define artdag/dag-get (fn (dag id) (get (get dag :nodes) id)))
(define
artdag/dag-node-by-name
(fn (dag name) (artdag/dag-get dag (artdag/dag-id dag name))))
(define artdag/node-count (fn (dag) (len (keys (get dag :nodes)))))

82
lib/artdag/execute.sx
View File

@@ -1,82 +0,0 @@
; lib/artdag/execute.sx — Phase 4: interpret a plan with a content-addressed
; memo cache. A node's result is keyed by its content-id, so a node whose id is
; already in the cache is skipped (cache hit). Because changing a leaf changes
; the content-ids of its whole dirty closure, re-running recomputes exactly those
; nodes and cache-hits the rest — incremental recompute falls out of content
; addressing. Depends on dag.sx and plan.sx; the cache is a lib/persist/ backend.
; runner: (fn (op params input-results) -> result). The injected effect interface.
; In production this performs the op (perform -> JAX/IPFS adapter); in tests it
; dispatches a pure SX op over its already-computed input results.
; build a runner from a dict of op-name -> (fn (params inputs) -> result).
(define
artdag/op-table-runner
(fn (table) (fn (op params inputs) ((get table op) params inputs))))
; resolve an input id's result: this run's results first, then the warm cache.
(define
artdag/-input-result
(fn
(results cache in)
(if (has-key? results in) (get results in) (persist/kv-get cache in))))
(define
artdag/-exec-node
(fn
(dag runner cache acc id)
(let
((node (artdag/dag-get dag id)))
(if
(persist/kv-has? cache id)
(assoc
acc
:results (assoc (get acc :results) id (persist/kv-get cache id))
:hits (concat (get acc :hits) (list id)))
(let
((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) (artdag/node-inputs node))))
(let
((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
(begin
(persist/kv-put cache id result)
(assoc
acc
:results (assoc (get acc :results) id result)
:recomputed (concat (get acc :recomputed) (list id))))))))))
; execute a plan against a memo cache, returning {:results :recomputed :hits}.
(define
artdag/execute
(fn
(dag plan runner cache)
(reduce
(fn (acc id) (artdag/-exec-node dag runner cache acc id))
{:recomputed (list) :results {} :hits (list)}
(artdag/plan-flatten plan))))
; full run over every node, unlimited width.
(define
artdag/run
(fn
(dag runner cache)
(artdag/execute dag (artdag/plan dag 0) runner cache)))
; incremental run: schedule only the dirty closure of the changed nodes.
(define
artdag/run-dirty
(fn
(dag changed runner cache)
(artdag/execute
dag
(artdag/plan-dirty dag changed 0)
runner
cache)))
; ---- result inspection ----
(define artdag/result-of (fn (exec id) (get (get exec :results) id)))
(define
artdag/recomputed
(fn (exec) (artdag/sort-strings (get exec :recomputed))))
(define artdag/recompute-count (fn (exec) (len (get exec :recomputed))))
(define artdag/hit-count (fn (exec) (len (get exec :hits))))

56
lib/artdag/fault.sx
View File

@@ -1,56 +0,0 @@
; lib/artdag/fault.sx — fault-tolerant execution. A node op may fail by returning
; (artdag/fail reason); the failure is confined to that node and its transitive
; dependents (which cannot run without it), while independent branches still
; compute. Failed results are NEVER cached, so a later run with the fault fixed
; recomputes only the failed closure. Depends on execute.sx and plan.sx.
(define artdag/fail (fn (reason) {:artdag-fail true :reason reason}))
(define artdag/failed? (fn (v) (and (dict? v) (has-key? v :artdag-fail))))
(define
artdag/-exec-safe-node
(fn
(dag runner cache acc id)
(let
((node (artdag/dag-get dag id)))
(let
((ins (artdag/node-inputs node)))
(if
(some (fn (in) (artdag/member? in (get acc :failed))) ins)
(assoc acc :failed (concat (get acc :failed) (list id)))
(if
(persist/kv-has? cache id)
(assoc
acc
:results (assoc (get acc :results) id (persist/kv-get cache id))
:hits (concat (get acc :hits) (list id)))
(let
((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) ins)))
(let
((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
(if
(artdag/failed? result)
(assoc acc :failed (concat (get acc :failed) (list id)))
(begin
(persist/kv-put cache id result)
(assoc
acc
:results (assoc (get acc :results) id result)
:recomputed (concat (get acc :recomputed) (list id)))))))))))))
(define
artdag/run-safe
(fn
(dag runner cache)
(reduce
(fn (acc id) (artdag/-exec-safe-node dag runner cache acc id))
{:recomputed (list) :results {} :hits (list) :failed (list)}
(artdag/plan-flatten (artdag/plan dag 0)))))
(define
artdag/failed-nodes
(fn (exec) (artdag/sort-strings (get exec :failed))))
(define artdag/failure-count (fn (exec) (len (get exec :failed))))
(define
artdag/all-ok?
(fn (exec) (= (len (get exec :failed)) 0)))

75
lib/artdag/federation.sx
View File

@@ -1,75 +0,0 @@
; lib/artdag/federation.sx — Phase 6: shared content-addressed cache across
; instances (the L2-registry analog). Because content-ids are global, a result
; computed on one instance is reusable on another by id. Imports are trust-gated
; and carry provenance so a peer's results can be invalidated when trust is
; withdrawn. Transport is injected (mock in tests). Depends on dag.sx, execute.sx
; (the cache is a lib/persist/ kv backend) — federation tracks provenance beside it.
; an instance: a persist kv cache + a provenance map {cid -> origin-peer}.
(define artdag/fed-open (fn () {:cache (persist/open) :prov {}}))
(define artdag/fed-cache (fn (fed) (get fed :cache)))
(define artdag/fed-prov (fn (fed) (get fed :prov)))
(define
artdag/-dict-remove
(fn
(d key)
(reduce
(fn (acc k) (if (= k key) acc (assoc acc k (get d k))))
{}
(keys d))))
; export every cached result as a bundle of {:cid :result :peer}, tagged with
; the exporting instance's peer id (the result's origin/provenance).
(define
artdag/fed-export
(fn
(fed peer-id)
(map (fn (cid) {:peer peer-id :cid cid :result (persist/kv-get (get fed :cache) cid)}) (persist/kv-keys (get fed :cache)))))
; import a bundle, accepting only records from trusted peers (trust gating) and
; recording each accepted result's provenance. Returns the updated instance.
(define
artdag/fed-import
(fn
(fed bundle trusted?)
(reduce
(fn
(f rec)
(if
(trusted? (get rec :peer))
(begin
(persist/kv-put (get f :cache) (get rec :cid) (get rec :result))
{:cache (get f :cache) :prov (assoc (get f :prov) (get rec :cid) (get rec :peer))})
f))
fed
bundle)))
; pull from a peer through an injected transport (fetch-fn peer-id -> bundle).
(define
artdag/fed-pull
(fn
(fed fetch-fn peer-id trusted?)
(artdag/fed-import fed (fetch-fn peer-id) trusted?)))
; invalidate: drop every cached result provenanced to a peer (trust withdrawn),
; from both the cache and the provenance map. Locally-computed results (no
; provenance) are untouched. Returns the updated instance.
(define
artdag/fed-invalidate
(fn
(fed peer-id)
(reduce
(fn
(f cid)
(if
(= (get (get f :prov) cid) peer-id)
(begin (persist/kv-delete (get f :cache) cid) {:cache (get f :cache) :prov (artdag/-dict-remove (get f :prov) cid)})
f))
fed
(keys (get fed :prov)))))
; convenience: run a dag against an instance's cache.
(define
artdag/fed-run
(fn (fed dag runner) (artdag/run dag runner (artdag/fed-cache fed))))

202
lib/artdag/optimize.sx
View File

@@ -1,202 +0,0 @@
; lib/artdag/optimize.sx — Phase 5: result-preserving DAG rewrites.
; DCE — drop nodes not reachable upstream from the requested outputs.
; CSE — free from content addressing: structurally identical subexpressions
; already collapse to one node at build time (artdag/cse == build).
; Fusion — collapse a maximal 1-to-1 chain of fusible unary ops into a single
; "artdag/pipeline" node that replays the stages; output-equivalent.
; optimize — fuse then DCE in one pass.
; Depends on dag.sx and analyze.sx.
; ---- dict helper ----
(define
artdag/-dict-filter
(fn
(d keep?)
(reduce
(fn (acc k) (if (keep? k (get d k)) (assoc acc k (get d k)) acc))
{}
(keys d))))
(define
artdag/-union
(fn
(a b)
(reduce (fn (acc x) (if (artdag/member? x acc) acc (cons x acc))) a b)))
; ---- dead-node elimination ----
; keep only the outputs and their transitive dependencies; ids are preserved.
(define
artdag/dce
(fn
(dag outputs)
(let
((db (artdag/analyze dag)))
(let
((live (reduce (fn (acc out) (artdag/-union (artdag/-union acc (list out)) (artdag/ancestors-of db out))) (list) outputs)))
{:names (artdag/-dict-filter (artdag/dag-names dag) (fn (k v) (artdag/member? v live))) :order (filter (fn (id) (artdag/member? id live)) (artdag/dag-order dag)) :ok true :nodes (artdag/-dict-filter (artdag/dag-nodes dag) (fn (k v) (artdag/member? k live)))}))))
; ---- common-subexpression elimination ----
; structural sharing is inherent to content addressing: build already maps
; structurally identical specs to a single node/id.
(define artdag/cse artdag/build)
; ---- adjacent-op fusion (entry-level rewrite) ----
(define artdag/pipeline-op "artdag/pipeline")
(define
artdag/-name->entry
(fn
(entries)
(reduce
(fn (m e) (assoc m (artdag/entry-name e) e))
{}
entries)))
; name -> list of dependent names
(define
artdag/-deps-map
(fn
(entries)
(reduce
(fn
(m e)
(reduce
(fn
(mm i)
(assoc
mm
i
(cons
(artdag/entry-name e)
(if (has-key? mm i) (get mm i) (list)))))
m
(artdag/entry-inputs e)))
{}
entries)))
(define artdag/-stage (fn (e) {:op (artdag/entry-op e) :params (artdag/entry-params e)}))
; the single predecessor that `name` may absorb, or nil. Requires: name is a
; fusible unary op; its one input is a locally-defined fusible node whose ONLY
; dependent is name (so fusing cannot break sharing).
(define
artdag/-absorbs
(fn
(n->e deps fusible? name)
(let
((e (get n->e name)))
(let
((ins (artdag/entry-inputs e)))
(if
(= (len ins) 1)
(let
((x (first ins)))
(if
(and
(has-key? n->e x)
(fusible? (artdag/entry-op e))
(fusible? (artdag/entry-op (get n->e x)))
(= (get deps x) (list name)))
x
nil))
nil)))))
(define
artdag/-absorbed-set
(fn
(n->e deps fusible? names)
(reduce
(fn
(acc y)
(let
((p (artdag/-absorbs n->e deps fusible? y)))
(if (nil? p) acc (cons p acc))))
(list)
names)))
; walk predecessors from a tail, building stages head->tail.
(define
artdag/-fuse-chain
(fn
(n->e deps fusible? cur stages)
(let
((p (artdag/-absorbs n->e deps fusible? cur)))
(if
(nil? p)
{:stages (cons (artdag/-stage (get n->e cur)) stages) :head cur}
(artdag/-fuse-chain
n->e
deps
fusible?
p
(cons (artdag/-stage (get n->e cur)) stages))))))
(define
artdag/fuse-entries
(fn
(entries fusible?)
(let
((n->e (artdag/-name->entry entries))
(deps (artdag/-deps-map entries))
(names (map artdag/entry-name entries)))
(let
((absorbed (artdag/-absorbed-set n->e deps fusible? names)))
(map
(fn
(name)
(let
((c (artdag/-fuse-chain n->e deps fusible? name (list))))
(if
(> (len (get c :stages)) 1)
(list
name
artdag/pipeline-op
(artdag/entry-inputs (get n->e (get c :head)))
{:stages (get c :stages)})
(get n->e name))))
(filter (fn (name) (not (artdag/member? name absorbed))) names))))))
(define
artdag/fuse
(fn
(entries fusible?)
(artdag/build (artdag/fuse-entries entries fusible?))))
; runner that replays a fused pipeline over its single input, delegating each
; stage to a base runner; non-pipeline ops fall through unchanged.
(define
artdag/pipeline-run
(fn
(base-runner)
(fn
(params inputs)
(reduce
(fn
(val stage)
(base-runner (get stage :op) (get stage :params) (list val)))
(first inputs)
(get params :stages)))))
(define
artdag/fusing-runner
(fn
(base-runner)
(fn
(op params inputs)
(if
(= op artdag/pipeline-op)
((artdag/pipeline-run base-runner) params inputs)
(base-runner op params inputs)))))
; ---- full optimization pass ----
; fuse the entry list, then drop everything not feeding the requested output
; names. Output names survive fusion (sinks are never absorbed).
(define
artdag/optimize
(fn
(entries outputs fusible?)
(let
((fused (artdag/fuse entries fusible?)))
(artdag/dce fused (map (fn (nm) (artdag/dag-id fused nm)) outputs)))))

100
lib/artdag/plan.sx
View File

@@ -1,100 +0,0 @@
; lib/artdag/plan.sx — Phase 3: schedule a DAG (or its dirty subset) into
; topological batches under a max-parallelism cap. A batch is a set of nodes
; whose deps are all satisfied by earlier batches, so they run in parallel.
; cap <= 0 means unlimited width. Depends on dag.sx and analyze.sx.
; inputs of id that also lie inside the scheduled set (out-of-set deps are
; treated as already satisfied — e.g. clean cache hits in an incremental plan).
(define
artdag/-deps-in
(fn
(dag id sset)
(filter
(fn (in) (artdag/member? in sset))
(artdag/node-inputs (artdag/dag-get dag id)))))
(define
artdag/-ready-in
(fn
(dag sset placed)
(filter
(fn
(id)
(and
(not (artdag/member? id placed))
(artdag/all-in? (artdag/-deps-in dag id sset) placed)))
(artdag/sort-strings sset))))
(define
artdag/-batch-loop
(fn
(dag sset placed batches)
(if
(= (len placed) (len sset))
batches
(let
((wave (artdag/-ready-in dag sset placed)))
(artdag/-batch-loop
dag
sset
(concat placed wave)
(concat batches (list wave)))))))
; split a wave into consecutive chunks of at most n (sorted order preserved).
(define
artdag/-chunk
(fn
(xs n)
(if
(<= (len xs) n)
(list xs)
(cons
(slice xs 0 n)
(artdag/-chunk (slice xs n (len xs)) n)))))
(define
artdag/-cap-split
(fn
(batches cap)
(if
(<= cap 0)
batches
(reduce
(fn (acc b) (concat acc (artdag/-chunk b cap)))
(list)
batches))))
; schedule an explicit set of node-ids into capped topological batches.
(define
artdag/plan-subset
(fn
(dag node-ids cap)
(artdag/-cap-split (artdag/-batch-loop dag node-ids (list) (list)) cap)))
; full plan over every node in the dag.
(define
artdag/plan
(fn (dag cap) (artdag/plan-subset dag (keys (artdag/dag-nodes dag)) cap)))
; incremental plan: schedule only the dirty closure of the changed nodes.
(define
artdag/plan-dirty
(fn
(dag changed cap)
(artdag/plan-subset dag (artdag/dirty-closure dag changed) cap)))
; ---- plan inspection ----
(define artdag/plan-batches (fn (plan) (len plan)))
(define
artdag/plan-width
(fn
(plan)
(reduce (fn (m b) (if (> (len b) m) (len b) m)) 0 plan)))
(define
artdag/plan-flatten
(fn (plan) (reduce (fn (acc b) (concat acc b)) (list) plan)))
(define artdag/plan-size (fn (plan) (len (artdag/plan-flatten plan))))

17
lib/artdag/scoreboard.json
View File

@@ -1,17 +0,0 @@
{
"suites": {
"dag": {"pass": 20, "fail": 0},
"analyze": {"pass": 16, "fail": 0},
"plan": {"pass": 18, "fail": 0},
"execute": {"pass": 15, "fail": 0},
"optimize": {"pass": 22, "fail": 0},
"fed": {"pass": 15, "fail": 0},
"cost": {"pass": 13, "fail": 0},
"serialize": {"pass": 13, "fail": 0},
"stats": {"pass": 12, "fail": 0},
"fault": {"pass": 14, "fail": 0}
},
"total_pass": 158,
"total_fail": 0,
"total": 158
}

17
lib/artdag/scoreboard.md
View File

@@ -1,17 +0,0 @@
# artdag Conformance Scoreboard
_Generated by `lib/artdag/conformance.sh`_
| Suite | Pass | Fail | Total |
|-------|-----:|-----:|------:|
| dag | 20 | 0 | 20 |
| analyze | 16 | 0 | 16 |
| plan | 18 | 0 | 18 |
| execute | 15 | 0 | 15 |
| optimize | 22 | 0 | 22 |
| fed | 15 | 0 | 15 |
| cost | 13 | 0 | 13 |
| serialize | 13 | 0 | 13 |
| stats | 12 | 0 | 12 |
| fault | 14 | 0 | 14 |
| **Total** | **158** | **0** | **158** |

62
lib/artdag/serialize.sx
View File

@@ -1,62 +0,0 @@
; lib/artdag/serialize.sx — portable wire form for whole DAGs, so a peer can
; receive and run a graph it did not author. The form is a topo-ordered list of
; node records (id op inputs params commutative) — plain lists with keyword-keyed
; param dicts, which survive write/read (unlike string-keyed node dicts). The id
; is the content-id, so the form is self-verifying. Depends on dag.sx.
(define
artdag/node->record
(fn
(dag id)
(let
((n (artdag/dag-get dag id)))
(list
id
(artdag/node-op n)
(artdag/node-inputs n)
(artdag/node-params n)
(get n :commutative)))))
; dag -> list of records, in topological order.
(define
artdag/dag->wire
(fn
(dag)
(map (fn (id) (artdag/node->record dag id)) (artdag/dag-order dag))))
; an empty input list reads back as nil; normalize it.
(define
artdag/-rec-inputs
(fn (rec) (let ((i (nth rec 2))) (if (nil? i) (list) i))))
(define artdag/-rec->node (fn (rec) {:inputs (artdag/-rec-inputs rec) :commutative (nth rec 4) :op (nth rec 1) :params (nth rec 3)}))
; records -> dag. Local author names are not part of the wire form; the receiver
; works by content-id. :names is left empty.
(define
artdag/wire->dag
(fn
(records)
(reduce
(fn (dag rec) (let ((id (nth rec 0))) {:names (get dag :names) :order (concat (get dag :order) (list id)) :ok true :nodes (assoc (get dag :nodes) id (artdag/-rec->node rec))}))
{:names {} :order (list) :ok true :nodes {}}
records)))
; integrity: each record's id must equal the content-id recomputed from its spec.
(define
artdag/wire-verify
(fn
(records)
(every?
(fn
(rec)
(= (nth rec 0) (artdag/content-id (artdag/-rec->node rec))))
records)))
; string transport.
(define
artdag/dag->string
(fn (dag) (write-to-string (artdag/dag->wire dag))))
(define
artdag/string->dag
(fn (s) (artdag/wire->dag (read (open-input-string s)))))

51
lib/artdag/stats.sx
View File

@@ -1,51 +0,0 @@
; lib/artdag/stats.sx — observability over an execution: cache hit ratio and the
; compute work saved by memoization (weighted by the cost model). An exec is the
; {:results :recomputed :hits} record returned by artdag/execute. Depends on
; execute.sx (exec accessors) and cost.sx (artdag/-node-cost).
(define
artdag/exec-total
(fn (exec) (+ (artdag/recompute-count exec) (artdag/hit-count exec))))
; fraction of executed nodes served from cache (0 when nothing ran).
(define
artdag/hit-ratio
(fn
(exec)
(let
((n (artdag/exec-total exec)))
(if (= n 0) 0 (/ (artdag/hit-count exec) n)))))
(define
artdag/-sum-cost
(fn
(dag cost-fn ids)
(reduce
(fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
0
ids)))
; weighted compute work that actually ran this execution.
(define
artdag/work-recomputed
(fn
(exec dag cost-fn)
(artdag/-sum-cost dag cost-fn (get exec :recomputed))))
; weighted compute work avoided by cache hits.
(define
artdag/work-saved
(fn (exec dag cost-fn) (artdag/-sum-cost dag cost-fn (get exec :hits))))
; fraction of total weighted work that the cache saved (0 when no work at all).
(define
artdag/savings-ratio
(fn
(exec dag cost-fn)
(let
((saved (artdag/work-saved exec dag cost-fn))
(ran (artdag/work-recomputed exec dag cost-fn)))
(if (= (+ saved ran) 0) 0 (/ saved (+ saved ran))))))
; compact summary dict for logging.
(define artdag/exec-summary (fn (exec dag cost-fn) {:work-saved (artdag/work-saved exec dag cost-fn) :recomputed (artdag/recompute-count exec) :total (artdag/exec-total exec) :work-ran (artdag/work-recomputed exec dag cost-fn) :hits (artdag/hit-count exec)}))

119
lib/artdag/tests/analyze.sx
View File

@@ -1,119 +0,0 @@
; Phase 2 — Analyze on Datalog: deps/dependents/reachability + dirty closure.
; diamond: a -> b, a -> c, (b,c) -> d
(define
an-D
(artdag/build
(list
(list "a" "load" (list) {})
(list "b" "f" (list "a") {})
(list "c" "g" (list "a") {})
(list "d" "add" (list "b" "c") {} true))))
(define an-db (artdag/analyze an-D))
(define an-a (artdag/dag-id an-D "a"))
(define an-b (artdag/dag-id an-D "b"))
(define an-c (artdag/dag-id an-D "c"))
(define an-d (artdag/dag-id an-D "d"))
; ---- direct deps / dependents ----
(artdag-test
"deps-of: direct inputs"
(artdag/deps-of an-db an-d)
(artdag/sort-strings (list an-b an-c)))
(artdag-test "deps-of: leaf has none" (artdag/deps-of an-db an-a) (list))
(artdag-test
"dependents-of: direct consumers"
(artdag/dependents-of an-db an-a)
(artdag/sort-strings (list an-b an-c)))
(artdag-test
"dependents-of: output has none"
(artdag/dependents-of an-db an-d)
(list))
; ---- transitive reachability ----
(artdag-test
"reachable-from: all downstream"
(artdag/reachable-from an-db an-a)
(artdag/sort-strings (list an-b an-c an-d)))
(artdag-test
"reachable-from: mid node reaches output"
(artdag/reachable-from an-db an-b)
(list an-d))
(artdag-test
"ancestors-of: all upstream"
(artdag/ancestors-of an-db an-d)
(artdag/sort-strings (list an-a an-b an-c)))
(artdag-test
"ancestors-of: leaf has none"
(artdag/ancestors-of an-db an-a)
(list))
; ---- deep chain ----
(define
ch-D
(artdag/build
(list
(list "a" "load" (list) {})
(list "b" "f" (list "a") {})
(list "c" "f" (list "b") {})
(list "d" "f" (list "c") {}))))
(define ch-db (artdag/analyze ch-D))
(artdag-test
"deep chain: reachable-from leaf"
(artdag/reachable-from ch-db (artdag/dag-id ch-D "a"))
(artdag/sort-strings
(list
(artdag/dag-id ch-D "b")
(artdag/dag-id ch-D "c")
(artdag/dag-id ch-D "d"))))
(artdag-test
"deep chain: ancestors of tip"
(artdag/ancestors-of ch-db (artdag/dag-id ch-D "d"))
(artdag/sort-strings
(list
(artdag/dag-id ch-D "a")
(artdag/dag-id ch-D "b")
(artdag/dag-id ch-D "c"))))
; ---- dirty closure ----
(artdag-test
"dirty closure: change leaf dirties all"
(artdag/dirty-closure an-D (list an-a))
(artdag/sort-strings (list an-a an-b an-c an-d)))
(artdag-test
"dirty closure: change mid touches only downstream"
(artdag/dirty-closure an-D (list an-b))
(artdag/sort-strings (list an-b an-d)))
(artdag-test
"dirty closure: unaffected stay clean (count)"
(len (artdag/dirty-closure an-D (list an-b)))
2)
(artdag-test
"dirty closure: change output dirties only itself"
(artdag/dirty-closure an-D (list an-d))
(list an-d))
(artdag-test
"dirty closure: multiple seeds union"
(artdag/dirty-closure an-D (list an-b an-c))
(artdag/sort-strings (list an-b an-c an-d)))
(artdag-test
"dirty closure: empty seed set"
(artdag/dirty-closure an-D (list))
(list))

117
lib/artdag/tests/cost.sx
View File

@@ -1,117 +0,0 @@
; cost model: critical path, makespan under cap, total work, speedup.
(define
cost-CHAIN
(artdag/build
(list
(list "a" "in" (list) {})
(list "b" "f" (list "a") {})
(list "c" "f" (list "b") {})
(list "d" "f" (list "c") {}))))
(define
cost-DIA
(artdag/build
(list
(list "a" "in" (list) {})
(list "b" "f" (list "a") {})
(list "c" "g" (list "a") {})
(list "d" "add" (list "b" "c") {} true))))
(define cost-W (artdag/op-cost {:f 2 :add 5}))
; ---- unit cost ----
(artdag-test
"critical path: chain is its length"
(artdag/critical-path cost-CHAIN artdag/const-cost)
4)
(artdag-test
"critical path: diamond longest path"
(artdag/critical-path cost-DIA artdag/const-cost)
3)
(artdag-test
"total work: unit cost equals node count"
(artdag/total-work cost-DIA artdag/const-cost)
4)
(artdag-test
"single node critical path is its cost"
(artdag/critical-path
(artdag/build (list (list "a" "in" (list) {})))
artdag/const-cost)
1)
; ---- makespan vs cap ----
(artdag-test
"full plan makespan equals critical path"
(artdag/makespan
cost-DIA
(artdag/plan cost-DIA 0)
artdag/const-cost)
(artdag/critical-path cost-DIA artdag/const-cost))
(artdag-test
"serial plan makespan equals total work"
(artdag/makespan
cost-DIA
(artdag/plan cost-DIA 1)
artdag/const-cost)
(artdag/total-work cost-DIA artdag/const-cost))
(artdag-test
"capped makespan is never below the critical path"
(>=
(artdag/makespan
cost-DIA
(artdag/plan cost-DIA 1)
artdag/const-cost)
(artdag/critical-path cost-DIA artdag/const-cost))
true)
; ---- weighted costs ----
(artdag-test
"weighted critical path follows heavy ops"
(artdag/critical-path cost-DIA cost-W)
8)
(artdag-test
"weighted total work sums all node costs"
(artdag/total-work cost-DIA cost-W)
9)
(artdag-test
"op-cost defaults unknown ops to 1"
(artdag/total-work
(artdag/build (list (list "a" "in" (list) {})))
cost-W)
1)
(artdag-test
"weighted full-plan makespan equals critical path"
(artdag/makespan cost-DIA (artdag/plan cost-DIA 0) cost-W)
(artdag/critical-path cost-DIA cost-W))
; ---- speedup ----
(artdag-test
"serial plan has no speedup"
(artdag/speedup
cost-DIA
(artdag/plan cost-DIA 1)
artdag/const-cost)
1)
(artdag-test
"parallel plan beats serial"
(>
(artdag/speedup
cost-DIA
(artdag/plan cost-DIA 0)
artdag/const-cost)
1)
true)

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