Compare commits
1 Commits
loops/erla
...
loops/comm
| Author | SHA1 | Date | |
|---|---|---|---|
| 6d53d36495 |
@@ -1 +0,0 @@
|
||||
{"sessionId":"31c80255-eb92-43e4-8997-84ad84e27326","pid":90960,"procStart":"564684","acquiredAt":1777049890282}
|
||||
@@ -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)
|
||||
|
||||
@@ -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%!"
|
||||
@@ -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
|
||||
@@ -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%!"
|
||||
@@ -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
|
||||
|
||||
@@ -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")]);
|
||||
|
||||
@@ -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 *)
|
||||
|
||||
@@ -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 *)
|
||||
(* ====================================================================== *)
|
||||
@@ -717,144 +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)"));
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
@@ -916,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 =
|
||||
@@ -1108,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) ---- *)
|
||||
|
||||
@@ -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 ]
|
||||
@@ -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
|
||||
|
||||
|
||||
|
||||
@@ -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 _ ->
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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);
|
||||
}
|
||||
|
||||
@@ -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 ->
|
||||
|
||||
@@ -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);
|
||||
@@ -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))
|
||||
|
||||
@@ -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`).
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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)
|
||||
@@ -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 =
|
||||
|
||||
@@ -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)
|
||||
File diff suppressed because it is too large
Load Diff
@@ -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)
|
||||
| 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
|
||||
| _ -> ())
|
||||
|
||||
@@ -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
|
||||
@@ -6,69 +6,8 @@
|
||||
|
||||
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))
|
||||
@@ -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
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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"
|
||||
| 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;
|
||||
let name = match n with
|
||||
| 32 -> "space" | 10 -> "newline" | 9 -> "tab"
|
||||
| 13 -> "return" | 0 -> "nul" | 27 -> "escape"
|
||||
| 127 -> "delete" | 8 -> "backspace"
|
||||
| _ -> let buf = Buffer.create 1 in
|
||||
Buffer.add_utf_8_uchar buf (Uchar.of_int n);
|
||||
Buffer.contents buf
|
||||
in "#\\" ^ name
|
||||
| Eof -> "#!eof"
|
||||
| Port { sp_kind = PortInput (_, pos); sp_closed } ->
|
||||
Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else "")
|
||||
| Port { sp_kind = PortOutput buf; sp_closed } ->
|
||||
Printf.sprintf "<output-port:len=%d%s>" (Buffer.length buf) (if sp_closed then ":closed" else "")
|
||||
| Rational (n, d) -> Printf.sprintf "%d/%d" n d
|
||||
| SxSet ht -> Printf.sprintf "<set:%d>" (Hashtbl.length ht)
|
||||
| SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags
|
||||
| SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i)))))
|
||||
|
||||
@@ -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;
|
||||
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,16 +1030,6 @@ 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 }
|
||||
else begin
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
@@ -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"))
|
||||
@@ -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 _ ->
|
||||
|
||||
@@ -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 _ ->
|
||||
|
||||
@@ -1,116 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# lib/apl/conformance.sh — run APL test suites, emit scoreboard.json + scoreboard.md.
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found." >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
SUITES=(structural operators dfn tradfn valence programs system idioms eval-ops pipeline)
|
||||
|
||||
OUT_JSON="lib/apl/scoreboard.json"
|
||||
OUT_MD="lib/apl/scoreboard.md"
|
||||
|
||||
run_suite() {
|
||||
local suite=$1
|
||||
local file="lib/apl/tests/${suite}.sx"
|
||||
local TMP
|
||||
TMP=$(mktemp)
|
||||
cat > "$TMP" << EPOCHS
|
||||
(epoch 1)
|
||||
(load "spec/stdlib.sx")
|
||||
(load "lib/r7rs.sx")
|
||||
(load "lib/apl/runtime.sx")
|
||||
(load "lib/apl/tokenizer.sx")
|
||||
(load "lib/apl/parser.sx")
|
||||
(load "lib/apl/transpile.sx")
|
||||
(epoch 2)
|
||||
(eval "(define apl-test-pass 0)")
|
||||
(eval "(define apl-test-fail 0)")
|
||||
(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (set! apl-test-fail (+ apl-test-fail 1)))))")
|
||||
(epoch 3)
|
||||
(load "${file}")
|
||||
(epoch 4)
|
||||
(eval "(list apl-test-pass apl-test-fail)")
|
||||
EPOCHS
|
||||
|
||||
local OUTPUT
|
||||
OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
||||
rm -f "$TMP"
|
||||
|
||||
local LINE
|
||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
|
||||
if [ -z "$LINE" ]; then
|
||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||
| sed -E 's/^\(ok 4 //; s/\)$//')
|
||||
fi
|
||||
|
||||
local P F
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
|
||||
P=${P:-0}
|
||||
F=${F:-0}
|
||||
echo "${P} ${F}"
|
||||
}
|
||||
|
||||
declare -A SUITE_PASS
|
||||
declare -A SUITE_FAIL
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
|
||||
echo "Running APL conformance suite..." >&2
|
||||
for s in "${SUITES[@]}"; do
|
||||
read -r p f < <(run_suite "$s")
|
||||
SUITE_PASS[$s]=$p
|
||||
SUITE_FAIL[$s]=$f
|
||||
TOTAL_PASS=$((TOTAL_PASS + p))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + f))
|
||||
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
|
||||
done
|
||||
|
||||
# scoreboard.json
|
||||
{
|
||||
printf '{\n'
|
||||
printf ' "suites": {\n'
|
||||
first=1
|
||||
for s in "${SUITES[@]}"; do
|
||||
if [ $first -eq 0 ]; then printf ',\n'; fi
|
||||
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
|
||||
first=0
|
||||
done
|
||||
printf '\n },\n'
|
||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
printf '}\n'
|
||||
} > "$OUT_JSON"
|
||||
|
||||
# scoreboard.md
|
||||
{
|
||||
printf '# APL Conformance Scoreboard\n\n'
|
||||
printf '_Generated by `lib/apl/conformance.sh`_\n\n'
|
||||
printf '| Suite | Pass | Fail | Total |\n'
|
||||
printf '|-------|-----:|-----:|------:|\n'
|
||||
for s in "${SUITES[@]}"; do
|
||||
p=${SUITE_PASS[$s]}
|
||||
f=${SUITE_FAIL[$s]}
|
||||
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
|
||||
done
|
||||
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
printf '\n'
|
||||
printf '## Notes\n\n'
|
||||
printf '%s\n' '- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.'
|
||||
printf '%s\n' '- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.'
|
||||
} > "$OUT_MD"
|
||||
|
||||
echo "Wrote $OUT_JSON and $OUT_MD" >&2
|
||||
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
|
||||
|
||||
[ "$TOTAL_FAIL" -eq 0 ]
|
||||
@@ -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))))
|
||||
1752
lib/apl/runtime.sx
1752
lib/apl/runtime.sx
File diff suppressed because it is too large
Load Diff
@@ -1,17 +0,0 @@
|
||||
{
|
||||
"suites": {
|
||||
"structural": {"pass": 94, "fail": 0},
|
||||
"operators": {"pass": 117, "fail": 0},
|
||||
"dfn": {"pass": 24, "fail": 0},
|
||||
"tradfn": {"pass": 25, "fail": 0},
|
||||
"valence": {"pass": 14, "fail": 0},
|
||||
"programs": {"pass": 45, "fail": 0},
|
||||
"system": {"pass": 13, "fail": 0},
|
||||
"idioms": {"pass": 64, "fail": 0},
|
||||
"eval-ops": {"pass": 14, "fail": 0},
|
||||
"pipeline": {"pass": 40, "fail": 0}
|
||||
},
|
||||
"total_pass": 450,
|
||||
"total_fail": 0,
|
||||
"total": 450
|
||||
}
|
||||
@@ -1,22 +0,0 @@
|
||||
# APL Conformance Scoreboard
|
||||
|
||||
_Generated by `lib/apl/conformance.sh`_
|
||||
|
||||
| Suite | Pass | Fail | Total |
|
||||
|-------|-----:|-----:|------:|
|
||||
| structural | 94 | 0 | 94 |
|
||||
| operators | 117 | 0 | 117 |
|
||||
| dfn | 24 | 0 | 24 |
|
||||
| tradfn | 25 | 0 | 25 |
|
||||
| valence | 14 | 0 | 14 |
|
||||
| programs | 45 | 0 | 45 |
|
||||
| system | 13 | 0 | 13 |
|
||||
| idioms | 64 | 0 | 64 |
|
||||
| eval-ops | 14 | 0 | 14 |
|
||||
| pipeline | 40 | 0 | 40 |
|
||||
| **Total** | **450** | **0** | **450** |
|
||||
|
||||
## Notes
|
||||
|
||||
- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.
|
||||
- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.
|
||||
@@ -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"
|
||||
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))))
|
||||
@@ -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)))
|
||||
@@ -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)))
|
||||
@@ -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)
|
||||
@@ -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 ⌽¨ ⊂⍵}
|
||||
@@ -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}⍣⍺⊢⍵}
|
||||
@@ -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 ⍵)}
|
||||
@@ -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=⍵∘.|⍵)/⍵←⍳⍵}
|
||||
@@ -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}
|
||||
@@ -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))))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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)
|
||||
@@ -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)))
|
||||
@@ -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))))
|
||||
@@ -330,22 +330,37 @@
|
||||
false))))))
|
||||
(check-all 0)))))
|
||||
|
||||
;; CLOS-side adapter for lib/guest/reflective/class-chain.sx. Classes
|
||||
;; live in clos-class-registry; :parents is a list of parent class
|
||||
;; names (CLOS supports multiple inheritance).
|
||||
(define clos-class-cfg
|
||||
{:parents-of (fn (cn)
|
||||
(let ((rec (clos-find-class cn)))
|
||||
(cond ((nil? rec) (list))
|
||||
(:else (or (get rec "parents") (list))))))
|
||||
:class? (fn (n) (not (nil? (clos-find-class n))))})
|
||||
|
||||
;; Precedence distance: how far class-name is from spec-name up the
|
||||
;; hierarchy. Delegates to refl-class-chain-depth-with which handles
|
||||
;; the multi-parent DFS with min-depth selection.
|
||||
(define clos-specificity
|
||||
(fn (class-name spec-name)
|
||||
(refl-class-chain-depth-with clos-class-cfg class-name spec-name)))
|
||||
;; Precedence distance: how far class-name is from spec-name up the hierarchy.
|
||||
(define
|
||||
clos-specificity
|
||||
(let
|
||||
((registry clos-class-registry))
|
||||
(fn
|
||||
(class-name spec-name)
|
||||
(define
|
||||
walk
|
||||
(fn
|
||||
(cn depth)
|
||||
(if
|
||||
(= cn spec-name)
|
||||
depth
|
||||
(let
|
||||
((rec (get registry cn)))
|
||||
(if
|
||||
(nil? rec)
|
||||
nil
|
||||
(let
|
||||
((results (map (fn (p) (walk p (+ depth 1))) (get rec "parents"))))
|
||||
(let
|
||||
((non-nil (filter (fn (x) (not (nil? x))) results)))
|
||||
(if
|
||||
(empty? non-nil)
|
||||
nil
|
||||
(reduce
|
||||
(fn (a b) (if (< a b) a b))
|
||||
(first non-nil)
|
||||
(rest non-nil))))))))))
|
||||
(walk class-name 0))))
|
||||
|
||||
(define
|
||||
clos-method-more-specific?
|
||||
|
||||
@@ -30,7 +30,7 @@ run_suite() {
|
||||
local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
|
||||
local TMP; TMP=$(mktemp)
|
||||
{
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(load "lib/guest/prefix.sx")\n'
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n'
|
||||
local i=2
|
||||
for f in $load_files; do
|
||||
printf '(epoch %d)\n(load "%s")\n' "$i" "$f"
|
||||
|
||||
@@ -23,19 +23,13 @@
|
||||
(cl-numberp? x)
|
||||
(let ((t (type-of x))) (or (= t "number") (= t "rational"))))
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
(integerp? integer?)
|
||||
(floatp? float?)
|
||||
(rationalp? rational?)
|
||||
))
|
||||
(define cl-integerp? integer?)
|
||||
(define cl-floatp? float?)
|
||||
(define cl-rationalp? rational?)
|
||||
|
||||
(define (cl-realp? x) (or (integer? x) (float? x) (rational? x)))
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
(characterp? char?)
|
||||
))
|
||||
(define cl-characterp? char?)
|
||||
(define cl-stringp? (fn (x) (= (type-of x) "string")))
|
||||
(define cl-symbolp? (fn (x) (= (type-of x) "symbol")))
|
||||
(define cl-keywordp? (fn (x) (= (type-of x) "keyword")))
|
||||
@@ -50,11 +44,8 @@
|
||||
(= t "native-fn")
|
||||
(= t "component"))))
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
(vectorp? vector?)
|
||||
(arrayp? vector?)
|
||||
))
|
||||
(define cl-vectorp? vector?)
|
||||
(define cl-arrayp? vector?)
|
||||
|
||||
;; sx_server: (rest (list x)) returns () not nil — cl-empty? handles both
|
||||
(define
|
||||
@@ -65,25 +56,19 @@
|
||||
;; 2. Arithmetic — thin aliases to spec primitives
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
(mod modulo)
|
||||
(rem remainder)
|
||||
gcd
|
||||
lcm
|
||||
expt
|
||||
floor
|
||||
(ceiling ceil)
|
||||
truncate
|
||||
round
|
||||
))
|
||||
(define cl-mod modulo)
|
||||
(define cl-rem remainder)
|
||||
(define cl-gcd gcd)
|
||||
(define cl-lcm lcm)
|
||||
(define cl-expt expt)
|
||||
(define cl-floor floor)
|
||||
(define cl-ceiling ceil)
|
||||
(define cl-truncate truncate)
|
||||
(define cl-round round)
|
||||
(define cl-abs (fn (x) (if (< x 0) (- 0 x) x)))
|
||||
(define cl-min (fn (a b) (if (< a b) a b)))
|
||||
(define cl-max (fn (a b) (if (> a b) a b)))
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
quotient
|
||||
))
|
||||
(define cl-quotient quotient)
|
||||
|
||||
(define
|
||||
(cl-signum x)
|
||||
@@ -102,27 +87,21 @@
|
||||
;; 3. Character functions — alias spec char primitives + CL name mapping
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
char->integer
|
||||
integer->char
|
||||
char-upcase
|
||||
char-downcase
|
||||
(char-code char->integer)
|
||||
(code-char integer->char)
|
||||
))
|
||||
(define cl-char->integer char->integer)
|
||||
(define cl-integer->char integer->char)
|
||||
(define cl-char-upcase char-upcase)
|
||||
(define cl-char-downcase char-downcase)
|
||||
(define cl-char-code char->integer)
|
||||
(define cl-code-char integer->char)
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
char=?
|
||||
char<?
|
||||
char>?
|
||||
char<=?
|
||||
char>=?
|
||||
char-ci=?
|
||||
char-ci<?
|
||||
char-ci>?
|
||||
))
|
||||
(define cl-char=? char=?)
|
||||
(define cl-char<? char<?)
|
||||
(define cl-char>? char>?)
|
||||
(define cl-char<=? char<=?)
|
||||
(define cl-char>=? char>=?)
|
||||
(define cl-char-ci=? char-ci=?)
|
||||
(define cl-char-ci<? char-ci<?)
|
||||
(define cl-char-ci>? char-ci>?)
|
||||
|
||||
;; Inline predicates — char-alphabetic?/char-numeric? unreliable in sx_server
|
||||
(define
|
||||
@@ -173,11 +152,8 @@
|
||||
(cl-format dest template &rest args)
|
||||
(let ((s (apply format (cons template args)))) (if (= dest nil) s s)))
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
write-to-string
|
||||
(princ-to-string display-to-string)
|
||||
))
|
||||
(define cl-write-to-string write-to-string)
|
||||
(define cl-princ-to-string display-to-string)
|
||||
|
||||
;; CL read-from-string: parse value from a string using SX port
|
||||
(define
|
||||
@@ -185,27 +161,18 @@
|
||||
(let ((p (open-input-string s))) (read p)))
|
||||
|
||||
;; String stream (output)
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
(make-string-output-stream open-output-string)
|
||||
(get-output-stream-string get-output-string)
|
||||
))
|
||||
(define cl-make-string-output-stream open-output-string)
|
||||
(define cl-get-output-stream-string get-output-string)
|
||||
|
||||
;; String stream (input)
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
(make-string-input-stream open-input-string)
|
||||
))
|
||||
(define cl-make-string-input-stream open-input-string)
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; 5. Gensym
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
gensym
|
||||
(gentemp gensym)
|
||||
))
|
||||
(define cl-gensym gensym)
|
||||
(define cl-gentemp gensym)
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; 6. Multiple values (CL: values / nth-value)
|
||||
@@ -236,19 +203,16 @@
|
||||
;; 7. Sets (CL: adjoin / member / union / intersection / set-difference)
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(prefix-rename "cl-"
|
||||
'(
|
||||
make-set
|
||||
set?
|
||||
(set-add set-add!)
|
||||
(set-memberp set-member?)
|
||||
(set-remove set-remove!)
|
||||
set-union
|
||||
(set-intersect set-intersection)
|
||||
set-difference
|
||||
list->set
|
||||
set->list
|
||||
))
|
||||
(define cl-make-set make-set)
|
||||
(define cl-set? set?)
|
||||
(define cl-set-add set-add!)
|
||||
(define cl-set-memberp set-member?)
|
||||
(define cl-set-remove set-remove!)
|
||||
(define cl-set-union set-union)
|
||||
(define cl-set-intersect set-intersection)
|
||||
(define cl-set-difference set-difference)
|
||||
(define cl-list->set list->set)
|
||||
(define cl-set->list set->list)
|
||||
|
||||
;; CL: (member item list) — returns tail starting at item, or nil
|
||||
(define
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
{
|
||||
"generated": "2026-05-06T22:55:42Z",
|
||||
"generated": "2026-05-05T12:35:09Z",
|
||||
"total_pass": 518,
|
||||
"total_fail": 0,
|
||||
"suites": [
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
# Common Lisp on SX — Scoreboard
|
||||
|
||||
_Generated: 2026-05-06 22:55 UTC_
|
||||
_Generated: 2026-05-05 12:35 UTC_
|
||||
|
||||
| Suite | Pass | Fail | Status |
|
||||
|-------|------|------|--------|
|
||||
|
||||
@@ -368,7 +368,7 @@ run_program_suite \
|
||||
|
||||
# ── Phase 4: CLOS unit tests ─────────────────────────────────────────────────
|
||||
CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
|
||||
CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null)
|
||||
rm -f "$CLOS_FILE"
|
||||
CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
|
||||
@@ -389,7 +389,7 @@ fi
|
||||
run_clos_suite() {
|
||||
local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
|
||||
local PROG_FILE=$(mktemp)
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
|
||||
"$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
|
||||
local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
|
||||
rm -f "$PROG_FILE"
|
||||
|
||||
@@ -1,207 +0,0 @@
|
||||
;; lib/common-lisp/tests/runtime.sx — tests for CL runtime layer
|
||||
|
||||
(load "lib/common-lisp/runtime.sx")
|
||||
|
||||
(defsuite
|
||||
"cl-types"
|
||||
(deftest "cl-null? nil" (assert= true (cl-null? nil)))
|
||||
(deftest "cl-null? false" (assert= false (cl-null? false)))
|
||||
(deftest
|
||||
"cl-consp? pair"
|
||||
(assert= true (cl-consp? (list 1 2))))
|
||||
(deftest "cl-consp? nil" (assert= false (cl-consp? nil)))
|
||||
(deftest "cl-listp? nil" (assert= true (cl-listp? nil)))
|
||||
(deftest
|
||||
"cl-listp? list"
|
||||
(assert= true (cl-listp? (list 1 2))))
|
||||
(deftest "cl-atom? nil" (assert= true (cl-atom? nil)))
|
||||
(deftest "cl-atom? pair" (assert= false (cl-atom? (list 1))))
|
||||
(deftest "cl-integerp?" (assert= true (cl-integerp? 42)))
|
||||
(deftest "cl-floatp?" (assert= true (cl-floatp? 3.14)))
|
||||
(deftest
|
||||
"cl-characterp?"
|
||||
(assert= true (cl-characterp? (integer->char 65))))
|
||||
(deftest "cl-stringp?" (assert= true (cl-stringp? "hello")))
|
||||
(deftest "cl-symbolp?" (assert= true (cl-symbolp? (quote foo)))))
|
||||
|
||||
(defsuite
|
||||
"cl-arithmetic"
|
||||
(deftest "cl-mod" (assert= 1 (cl-mod 10 3)))
|
||||
(deftest "cl-rem" (assert= 1 (cl-rem 10 3)))
|
||||
(deftest
|
||||
"cl-quotient"
|
||||
(assert= 3 (cl-quotient 10 3)))
|
||||
(deftest "cl-gcd" (assert= 4 (cl-gcd 12 8)))
|
||||
(deftest "cl-lcm" (assert= 12 (cl-lcm 4 6)))
|
||||
(deftest "cl-abs pos" (assert= 5 (cl-abs 5)))
|
||||
(deftest "cl-abs neg" (assert= 5 (cl-abs -5)))
|
||||
(deftest "cl-min" (assert= 2 (cl-min 2 7)))
|
||||
(deftest "cl-max" (assert= 7 (cl-max 2 7)))
|
||||
(deftest "cl-evenp? t" (assert= true (cl-evenp? 4)))
|
||||
(deftest "cl-evenp? f" (assert= false (cl-evenp? 3)))
|
||||
(deftest "cl-oddp? t" (assert= true (cl-oddp? 7)))
|
||||
(deftest "cl-zerop?" (assert= true (cl-zerop? 0)))
|
||||
(deftest "cl-plusp?" (assert= true (cl-plusp? 1)))
|
||||
(deftest "cl-minusp?" (assert= true (cl-minusp? -1)))
|
||||
(deftest "cl-signum pos" (assert= 1 (cl-signum 42)))
|
||||
(deftest "cl-signum neg" (assert= -1 (cl-signum -7)))
|
||||
(deftest "cl-signum zero" (assert= 0 (cl-signum 0))))
|
||||
|
||||
(defsuite
|
||||
"cl-chars"
|
||||
(deftest
|
||||
"cl-char-code"
|
||||
(assert= 65 (cl-char-code (integer->char 65))))
|
||||
(deftest "cl-code-char" (assert= true (char? (cl-code-char 65))))
|
||||
(deftest
|
||||
"cl-char-upcase"
|
||||
(assert=
|
||||
(integer->char 65)
|
||||
(cl-char-upcase (integer->char 97))))
|
||||
(deftest
|
||||
"cl-char-downcase"
|
||||
(assert=
|
||||
(integer->char 97)
|
||||
(cl-char-downcase (integer->char 65))))
|
||||
(deftest
|
||||
"cl-alpha-char-p"
|
||||
(assert= true (cl-alpha-char-p (integer->char 65))))
|
||||
(deftest
|
||||
"cl-digit-char-p"
|
||||
(assert= true (cl-digit-char-p (integer->char 48))))
|
||||
(deftest
|
||||
"cl-char=?"
|
||||
(assert=
|
||||
true
|
||||
(cl-char=? (integer->char 65) (integer->char 65))))
|
||||
(deftest
|
||||
"cl-char<?"
|
||||
(assert=
|
||||
true
|
||||
(cl-char<? (integer->char 65) (integer->char 90))))
|
||||
(deftest
|
||||
"cl-char space"
|
||||
(assert= (integer->char 32) cl-char-space))
|
||||
(deftest
|
||||
"cl-char newline"
|
||||
(assert= (integer->char 10) cl-char-newline)))
|
||||
|
||||
(defsuite
|
||||
"cl-format"
|
||||
(deftest
|
||||
"cl-format nil basic"
|
||||
(assert= "hello" (cl-format nil "~a" "hello")))
|
||||
(deftest
|
||||
"cl-format nil number"
|
||||
(assert= "42" (cl-format nil "~d" 42)))
|
||||
(deftest
|
||||
"cl-format nil hex"
|
||||
(assert= "ff" (cl-format nil "~x" 255)))
|
||||
(deftest
|
||||
"cl-format nil template"
|
||||
(assert= "x=3 y=4" (cl-format nil "x=~d y=~d" 3 4)))
|
||||
(deftest "cl-format nil tilde" (assert= "a~b" (cl-format nil "a~~b"))))
|
||||
|
||||
(defsuite
|
||||
"cl-gensym"
|
||||
(deftest
|
||||
"cl-gensym returns symbol"
|
||||
(assert= "symbol" (type-of (cl-gensym))))
|
||||
(deftest "cl-gensym unique" (assert= false (= (cl-gensym) (cl-gensym)))))
|
||||
|
||||
(defsuite
|
||||
"cl-sets"
|
||||
(deftest "cl-make-set empty" (assert= true (cl-set? (cl-make-set))))
|
||||
(deftest
|
||||
"cl-set-add/member"
|
||||
(let
|
||||
((s (cl-make-set)))
|
||||
(do
|
||||
(cl-set-add s 1)
|
||||
(assert= true (cl-set-memberp s 1)))))
|
||||
(deftest
|
||||
"cl-set-memberp false"
|
||||
(assert= false (cl-set-memberp (cl-make-set) 42)))
|
||||
(deftest
|
||||
"cl-list->set"
|
||||
(let
|
||||
((s (cl-list->set (list 1 2 3))))
|
||||
(assert= true (cl-set-memberp s 2)))))
|
||||
|
||||
(defsuite
|
||||
"cl-lists"
|
||||
(deftest
|
||||
"cl-nth 0"
|
||||
(assert=
|
||||
1
|
||||
(cl-nth 0 (list 1 2 3))))
|
||||
(deftest
|
||||
"cl-nth 2"
|
||||
(assert=
|
||||
3
|
||||
(cl-nth 2 (list 1 2 3))))
|
||||
(deftest
|
||||
"cl-last"
|
||||
(assert=
|
||||
(list 3)
|
||||
(cl-last (list 1 2 3))))
|
||||
(deftest
|
||||
"cl-butlast"
|
||||
(assert=
|
||||
(list 1 2)
|
||||
(cl-butlast (list 1 2 3))))
|
||||
(deftest
|
||||
"cl-nthcdr 1"
|
||||
(assert=
|
||||
(list 2 3)
|
||||
(cl-nthcdr 1 (list 1 2 3))))
|
||||
(deftest
|
||||
"cl-assoc hit"
|
||||
(assert=
|
||||
(list "b" 2)
|
||||
(cl-assoc "b" (list (list "a" 1) (list "b" 2)))))
|
||||
(deftest
|
||||
"cl-assoc miss"
|
||||
(assert= nil (cl-assoc "z" (list (list "a" 1)))))
|
||||
(deftest
|
||||
"cl-getf hit"
|
||||
(assert= 42 (cl-getf (list "x" 42 "y" 99) "x")))
|
||||
(deftest "cl-getf miss" (assert= nil (cl-getf (list "x" 42) "z")))
|
||||
(deftest
|
||||
"cl-adjoin new"
|
||||
(assert=
|
||||
(list 0 1 2)
|
||||
(cl-adjoin 0 (list 1 2))))
|
||||
(deftest
|
||||
"cl-adjoin dup"
|
||||
(assert=
|
||||
(list 1 2)
|
||||
(cl-adjoin 1 (list 1 2))))
|
||||
(deftest
|
||||
"cl-flatten"
|
||||
(assert=
|
||||
(list 1 2 3 4)
|
||||
(cl-flatten (list 1 (list 2 3) 4))))
|
||||
(deftest
|
||||
"cl-member hit"
|
||||
(assert=
|
||||
(list 2 3)
|
||||
(cl-member 2 (list 1 2 3))))
|
||||
(deftest
|
||||
"cl-member miss"
|
||||
(assert=
|
||||
nil
|
||||
(cl-member 9 (list 1 2 3)))))
|
||||
|
||||
(defsuite
|
||||
"cl-radix"
|
||||
(deftest "binary" (assert= "1010" (cl-format-binary 10)))
|
||||
(deftest "octal" (assert= "17" (cl-format-octal 15)))
|
||||
(deftest "hex" (assert= "ff" (cl-format-hex 255)))
|
||||
(deftest "decimal" (assert= "42" (cl-format-decimal 42)))
|
||||
(deftest
|
||||
"n->s r16"
|
||||
(assert= "1f" (cl-integer-to-string 31 16)))
|
||||
(deftest
|
||||
"s->n r16"
|
||||
(assert= 31 (cl-string-to-integer "1f" 16))))
|
||||
@@ -1008,27 +1008,11 @@
|
||||
(let
|
||||
((name (symbol-name head))
|
||||
(argc (len args))
|
||||
(specialized-op (cond
|
||||
(and (= argc 2) (= name "+")) 160
|
||||
(and (= argc 2) (= name "-")) 161
|
||||
(and (= argc 2) (= name "*")) 162
|
||||
(and (= argc 2) (= name "/")) 163
|
||||
(and (= argc 2) (= name "=")) 164
|
||||
(and (= argc 2) (= name "<")) 165
|
||||
(and (= argc 2) (= name ">")) 166
|
||||
(and (= argc 2) (= name "cons")) 172
|
||||
(and (= argc 1) (= name "not")) 167
|
||||
(and (= argc 1) (= name "len")) 168
|
||||
(and (= argc 1) (= name "first")) 169
|
||||
(and (= argc 1) (= name "rest")) 170
|
||||
:else nil)))
|
||||
(name-idx (pool-add (get em "pool") name)))
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
(if specialized-op
|
||||
(emit-op em specialized-op)
|
||||
(let ((name-idx (pool-add (get em "pool") name)))
|
||||
(emit-op em 52)
|
||||
(emit-u16 em name-idx)
|
||||
(emit-byte em argc))))
|
||||
(emit-byte em argc))
|
||||
(do
|
||||
(compile-expr em head scope false)
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
|
||||
@@ -1,157 +0,0 @@
|
||||
;; lib/datalog/aggregates.sx — count / sum / min / max / findall.
|
||||
;;
|
||||
;; Surface form (always 3-arg after the relation name):
|
||||
;;
|
||||
;; (count Result Var GoalLit)
|
||||
;; (sum Result Var GoalLit)
|
||||
;; (min Result Var GoalLit)
|
||||
;; (max Result Var GoalLit)
|
||||
;; (findall List Var GoalLit)
|
||||
;;
|
||||
;; Parsed naturally because arg-position compounds are already allowed
|
||||
;; (Phase 4 needs them for arithmetic). At evaluation time the aggregator
|
||||
;; runs `dl-find-bindings` on `GoalLit` under the current subst, collects
|
||||
;; the distinct values of `Var`, and binds `Result`.
|
||||
;;
|
||||
;; Aggregation is non-monotonic — `count(C, X, p(X))` shrinks as p loses
|
||||
;; tuples. The stratifier (lib/datalog/strata.sx) treats every aggregate's
|
||||
;; goal relation as a negation-like edge so the inner relation is fully
|
||||
;; derived before the aggregate fires.
|
||||
;;
|
||||
;; Empty input: count → 0, sum → 0, min/max → no binding (rule fails).
|
||||
|
||||
(define dl-aggregate-rels (list "count" "sum" "min" "max" "findall"))
|
||||
|
||||
(define
|
||||
dl-aggregate?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(>= (len lit) 4)
|
||||
(let ((rel (dl-rel-name lit)))
|
||||
(cond
|
||||
((nil? rel) false)
|
||||
(else (dl-member-string? rel dl-aggregate-rels)))))))
|
||||
|
||||
;; Apply aggregation operator to a list of (already-distinct) numeric or
|
||||
;; symbolic values. Returns the aggregated value, or :empty if min/max
|
||||
;; has no input.
|
||||
(define
|
||||
dl-do-aggregate
|
||||
(fn
|
||||
(op vals)
|
||||
(cond
|
||||
((= op "count") (len vals))
|
||||
((= op "sum") (dl-sum-vals vals 0))
|
||||
((= op "findall") vals)
|
||||
((= op "min")
|
||||
(cond
|
||||
((= (len vals) 0) :empty)
|
||||
(else (dl-min-vals vals 1 (first vals)))))
|
||||
((= op "max")
|
||||
(cond
|
||||
((= (len vals) 0) :empty)
|
||||
(else (dl-max-vals vals 1 (first vals)))))
|
||||
(else (error (str "datalog: unknown aggregate " op))))))
|
||||
|
||||
(define
|
||||
dl-sum-vals
|
||||
(fn
|
||||
(vals acc)
|
||||
(cond
|
||||
((= (len vals) 0) acc)
|
||||
(else (dl-sum-vals (rest vals) (+ acc (first vals)))))))
|
||||
|
||||
(define
|
||||
dl-min-vals
|
||||
(fn
|
||||
(vals i cur)
|
||||
(cond
|
||||
((>= i (len vals)) cur)
|
||||
(else
|
||||
(let ((v (nth vals i)))
|
||||
(dl-min-vals vals (+ i 1) (if (< v cur) v cur)))))))
|
||||
|
||||
(define
|
||||
dl-max-vals
|
||||
(fn
|
||||
(vals i cur)
|
||||
(cond
|
||||
((>= i (len vals)) cur)
|
||||
(else
|
||||
(let ((v (nth vals i)))
|
||||
(dl-max-vals vals (+ i 1) (if (> v cur) v cur)))))))
|
||||
|
||||
;; Membership check by deep equality (so 30 == 30.0 etc).
|
||||
(define
|
||||
dl-val-member?
|
||||
(fn
|
||||
(v xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-tuple-equal? v (first xs)) true)
|
||||
(else (dl-val-member? v (rest xs))))))
|
||||
|
||||
;; Evaluate an aggregate body lit under `subst`. Returns the list of
|
||||
;; extended substitutions (0 or 1 element).
|
||||
(define
|
||||
dl-eval-aggregate
|
||||
(fn
|
||||
(lit db subst)
|
||||
(let
|
||||
((op (dl-rel-name lit))
|
||||
(result-var (nth lit 1))
|
||||
(agg-var (nth lit 2))
|
||||
(goal (nth lit 3)))
|
||||
(cond
|
||||
((not (dl-var? agg-var))
|
||||
(error (str "datalog aggregate (" op
|
||||
"): second arg must be a variable, got " agg-var)))
|
||||
((not (and (list? goal) (> (len goal) 0)
|
||||
(symbol? (first goal))))
|
||||
(error (str "datalog aggregate (" op
|
||||
"): third arg must be a positive literal, got "
|
||||
goal)))
|
||||
((not (dl-member-string?
|
||||
(symbol->string agg-var)
|
||||
(dl-vars-of goal)))
|
||||
(error (str "datalog aggregate (" op
|
||||
"): aggregation variable " agg-var
|
||||
" does not appear in the goal " goal
|
||||
" — without it every match contributes the same "
|
||||
"(unbound) value and the result is meaningless")))
|
||||
(else
|
||||
(let ((vals (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let ((v (dl-apply-subst agg-var s)))
|
||||
(when (not (dl-val-member? v vals))
|
||||
(append! vals v))))
|
||||
(dl-find-bindings (list goal) db subst))
|
||||
(let ((agg-val (dl-do-aggregate op vals)))
|
||||
(cond
|
||||
((= agg-val :empty) (list))
|
||||
(else
|
||||
(let ((s2 (dl-unify result-var agg-val subst)))
|
||||
(if (nil? s2) (list) (list s2)))))))))))))
|
||||
|
||||
|
||||
;; Stratification edges from aggregates: like negation, the goal's
|
||||
;; relation must be in a strictly lower stratum so that the aggregate
|
||||
;; fires only after the underlying tuples are settled.
|
||||
(define
|
||||
dl-aggregate-dep-edge
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((dl-aggregate? lit)
|
||||
(let ((goal (nth lit 3)))
|
||||
(cond
|
||||
((and (list? goal) (> (len goal) 0))
|
||||
(let ((rel (dl-rel-name goal)))
|
||||
(if (nil? rel) nil {:rel rel :neg true})))
|
||||
(else nil))))
|
||||
(else nil))))
|
||||
@@ -1,303 +0,0 @@
|
||||
;; lib/datalog/api.sx — SX-data embedding API.
|
||||
;;
|
||||
;; Where Phase 1's `dl-program` takes a Datalog source string,
|
||||
;; this module exposes a parser-free API that consumes SX data
|
||||
;; directly. Two rule shapes are accepted:
|
||||
;;
|
||||
;; - dict: {:head <literal> :body (<literal> ...)}
|
||||
;; - list: (<head-elements...> <- <body-literal> ...)
|
||||
;; — `<-` is an SX symbol used as the rule arrow.
|
||||
;;
|
||||
;; Examples:
|
||||
;;
|
||||
;; (dl-program-data
|
||||
;; '((parent tom bob) (parent tom liz) (parent bob ann))
|
||||
;; '((ancestor X Y <- (parent X Y))
|
||||
;; (ancestor X Z <- (parent X Y) (ancestor Y Z))))
|
||||
;;
|
||||
;; (dl-query db '(ancestor tom X)) ; same query API as before
|
||||
;;
|
||||
;; Variables follow the parser convention: SX symbols whose first
|
||||
;; character is uppercase or `_` are variables.
|
||||
|
||||
(define
|
||||
dl-rule
|
||||
(fn (head body) {:head head :body body}))
|
||||
|
||||
(define
|
||||
dl-rule-arrow?
|
||||
(fn
|
||||
(x)
|
||||
(and (symbol? x) (= (symbol->string x) "<-"))))
|
||||
|
||||
(define
|
||||
dl-find-arrow
|
||||
(fn
|
||||
(rl i n)
|
||||
(cond
|
||||
((>= i n) nil)
|
||||
((dl-rule-arrow? (nth rl i)) i)
|
||||
(else (dl-find-arrow rl (+ i 1) n)))))
|
||||
|
||||
;; Given a list of the form (head-elt ... <- body-lit ...) returns
|
||||
;; {:head (head-elt ...) :body (body-lit ...)}. If no arrow is
|
||||
;; present, the whole list is treated as the head and the body is
|
||||
;; empty (i.e. a fact written rule-style).
|
||||
(define
|
||||
dl-rule-from-list
|
||||
(fn
|
||||
(rl)
|
||||
(let ((n (len rl)))
|
||||
(let ((idx (dl-find-arrow rl 0 n)))
|
||||
(cond
|
||||
((nil? idx) {:head rl :body (list)})
|
||||
(else
|
||||
(let
|
||||
((head (slice rl 0 idx))
|
||||
(body (slice rl (+ idx 1) n)))
|
||||
{:head head :body body})))))))
|
||||
|
||||
;; Coerce a rule given as either a dict or a list-with-arrow to a dict.
|
||||
(define
|
||||
dl-coerce-rule
|
||||
(fn
|
||||
(r)
|
||||
(cond
|
||||
((dict? r) r)
|
||||
((list? r) (dl-rule-from-list r))
|
||||
(else (error (str "dl-coerce-rule: expected dict or list, got " r))))))
|
||||
|
||||
;; Build a db from SX data lists.
|
||||
(define
|
||||
dl-program-data
|
||||
(fn
|
||||
(facts rules)
|
||||
(let ((db (dl-make-db)))
|
||||
(do
|
||||
(for-each (fn (lit) (dl-add-fact! db lit)) facts)
|
||||
(for-each
|
||||
(fn (r) (dl-add-rule! db (dl-coerce-rule r)))
|
||||
rules)
|
||||
db))))
|
||||
|
||||
;; Add a single fact at runtime, then re-saturate the db so derived
|
||||
;; tuples reflect the change. Returns the db.
|
||||
(define
|
||||
dl-assert!
|
||||
(fn
|
||||
(db lit)
|
||||
(do
|
||||
(dl-add-fact! db lit)
|
||||
(dl-saturate! db)
|
||||
db)))
|
||||
|
||||
;; Remove a fact and re-saturate. Mixed relations (which have BOTH
|
||||
;; user-asserted facts AND rules) are supported via :edb-keys provenance
|
||||
;; — explicit facts are marked at dl-add-fact! time, the saturator uses
|
||||
;; dl-add-derived! which doesn't mark them, so the retract pass can
|
||||
;; safely wipe IDB-derived tuples while preserving the user's EDB.
|
||||
;;
|
||||
;; Effect:
|
||||
;; - remove tuples matching `lit` from :facts and :edb-keys
|
||||
;; - for every relation that has a rule (i.e. potentially IDB or
|
||||
;; mixed), drop the IDB-derived portion (anything not in :edb-keys)
|
||||
;; so the saturator can re-derive cleanly
|
||||
;; - re-saturate
|
||||
(define
|
||||
dl-retract!
|
||||
(fn
|
||||
(db lit)
|
||||
(let
|
||||
((rel-key (dl-rel-name lit)))
|
||||
(do
|
||||
;; Drop the matching tuple from its relation list, its facts-keys,
|
||||
;; its first-arg index, AND from :edb-keys (if present).
|
||||
(when
|
||||
(has-key? (get db :facts) rel-key)
|
||||
(let
|
||||
((existing (get (get db :facts) rel-key))
|
||||
(kept (list))
|
||||
(kept-keys {})
|
||||
(kept-index {})
|
||||
(edb-rel (cond
|
||||
((has-key? (get db :edb-keys) rel-key)
|
||||
(get (get db :edb-keys) rel-key))
|
||||
(else nil)))
|
||||
(kept-edb {}))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(t)
|
||||
(when
|
||||
(not (dl-tuple-equal? t lit))
|
||||
(do
|
||||
(append! kept t)
|
||||
(let ((tk (dl-tuple-key t)))
|
||||
(do
|
||||
(dict-set! kept-keys tk true)
|
||||
(when
|
||||
(and (not (nil? edb-rel))
|
||||
(has-key? edb-rel tk))
|
||||
(dict-set! kept-edb tk true))))
|
||||
(when
|
||||
(>= (len t) 2)
|
||||
(let ((k (dl-arg-key (nth t 1))))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? kept-index k))
|
||||
(dict-set! kept-index k (list)))
|
||||
(append! (get kept-index k) t)))))))
|
||||
existing)
|
||||
(dict-set! (get db :facts) rel-key kept)
|
||||
(dict-set! (get db :facts-keys) rel-key kept-keys)
|
||||
(dict-set! (get db :facts-index) rel-key kept-index)
|
||||
(when
|
||||
(not (nil? edb-rel))
|
||||
(dict-set! (get db :edb-keys) rel-key kept-edb)))))
|
||||
;; For each rule-head relation, strip the IDB-derived tuples
|
||||
;; (anything not marked in :edb-keys) so the saturator can
|
||||
;; cleanly re-derive without leaving stale tuples that depended
|
||||
;; on the now-removed fact.
|
||||
(let ((rule-heads (dl-rule-head-rels db)))
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(when
|
||||
(has-key? (get db :facts) k)
|
||||
(let
|
||||
((existing (get (get db :facts) k))
|
||||
(kept (list))
|
||||
(kept-keys {})
|
||||
(kept-index {})
|
||||
(edb-rel (cond
|
||||
((has-key? (get db :edb-keys) k)
|
||||
(get (get db :edb-keys) k))
|
||||
(else {}))))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(t)
|
||||
(let ((tk (dl-tuple-key t)))
|
||||
(when
|
||||
(has-key? edb-rel tk)
|
||||
(do
|
||||
(append! kept t)
|
||||
(dict-set! kept-keys tk true)
|
||||
(when
|
||||
(>= (len t) 2)
|
||||
(let ((kk (dl-arg-key (nth t 1))))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? kept-index kk))
|
||||
(dict-set! kept-index kk (list)))
|
||||
(append! (get kept-index kk) t))))))))
|
||||
existing)
|
||||
(dict-set! (get db :facts) k kept)
|
||||
(dict-set! (get db :facts-keys) k kept-keys)
|
||||
(dict-set! (get db :facts-index) k kept-index)))))
|
||||
rule-heads))
|
||||
(dl-saturate! db)
|
||||
db))))
|
||||
|
||||
;; ── Convenience: single-call source + query ───────────────────
|
||||
;; (dl-eval source query-source) parses both, builds a db, saturates,
|
||||
;; runs the query, returns the substitution list. The query source
|
||||
;; should be `?- goal[, goal ...].` — the parser produces a clause
|
||||
;; with :query containing a list of literals which is fed straight
|
||||
;; to dl-query.
|
||||
(define
|
||||
dl-eval
|
||||
(fn
|
||||
(source query-source)
|
||||
(let
|
||||
((db (dl-program source))
|
||||
(queries (dl-parse query-source)))
|
||||
(cond
|
||||
((= (len queries) 0) (error "dl-eval: query string is empty"))
|
||||
((not (has-key? (first queries) :query))
|
||||
(error "dl-eval: second arg must be a `?- ...` query clause"))
|
||||
(else
|
||||
(dl-query db (get (first queries) :query)))))))
|
||||
|
||||
;; (dl-eval-magic source query-source) — like dl-eval but routes a
|
||||
;; single-positive-literal query through `dl-magic-query` for goal-
|
||||
;; directed evaluation. Multi-literal query bodies fall back to the
|
||||
;; standard dl-query path (magic-sets is currently only wired for
|
||||
;; single-positive goals). The caller's source is parsed afresh
|
||||
;; each call so successive invocations are independent.
|
||||
(define
|
||||
dl-eval-magic
|
||||
(fn
|
||||
(source query-source)
|
||||
(let
|
||||
((db (dl-program source))
|
||||
(queries (dl-parse query-source)))
|
||||
(cond
|
||||
((= (len queries) 0) (error "dl-eval-magic: query string is empty"))
|
||||
((not (has-key? (first queries) :query))
|
||||
(error
|
||||
"dl-eval-magic: second arg must be a `?- ...` query clause"))
|
||||
(else
|
||||
(let
|
||||
((qbody (get (first queries) :query)))
|
||||
(cond
|
||||
((and (= (len qbody) 1)
|
||||
(list? (first qbody))
|
||||
(> (len (first qbody)) 0)
|
||||
(symbol? (first (first qbody))))
|
||||
(dl-magic-query db (first qbody)))
|
||||
(else (dl-query db qbody)))))))))
|
||||
|
||||
;; List rules whose head's relation matches `rel-name`. Useful for
|
||||
;; inspection ("show me how this relation is derived") without
|
||||
;; exposing the internal `:rules` list.
|
||||
(define
|
||||
dl-rules-of
|
||||
(fn
|
||||
(db rel-name)
|
||||
(let ((out (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(when
|
||||
(= (dl-rel-name (get rule :head)) rel-name)
|
||||
(append! out rule)))
|
||||
(dl-rules db))
|
||||
out))))
|
||||
|
||||
(define
|
||||
dl-rule-head-rels
|
||||
(fn
|
||||
(db)
|
||||
(let ((seen (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(let ((h (dl-rel-name (get rule :head))))
|
||||
(when
|
||||
(and (not (nil? h)) (not (dl-member-string? h seen)))
|
||||
(append! seen h))))
|
||||
(dl-rules db))
|
||||
seen))))
|
||||
|
||||
;; Wipe every relation that has at least one rule (i.e. every IDB
|
||||
;; relation) — leaves EDB facts and rule definitions intact. Useful
|
||||
;; before a follow-up `dl-saturate!` if you want a clean restart, or
|
||||
;; for inspection of the EDB-only baseline.
|
||||
(define
|
||||
dl-clear-idb!
|
||||
(fn
|
||||
(db)
|
||||
(let ((rule-heads (dl-rule-head-rels db)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(do
|
||||
(dict-set! (get db :facts) k (list))
|
||||
(dict-set! (get db :facts-keys) k {})
|
||||
(dict-set! (get db :facts-index) k {})))
|
||||
rule-heads)
|
||||
db))))
|
||||
@@ -1,406 +0,0 @@
|
||||
;; lib/datalog/builtins.sx — comparison + arithmetic body literals.
|
||||
;;
|
||||
;; Built-in predicates filter / extend candidate substitutions during
|
||||
;; rule evaluation. They are not stored facts and do not participate in
|
||||
;; the Herbrand base.
|
||||
;;
|
||||
;; (< a b) (<= a b) (> a b) (>= a b) ; numeric (or string) compare
|
||||
;; (= a b) ; unify (binds vars)
|
||||
;; (!= a b) ; ground-only inequality
|
||||
;; (is X expr) ; bind X to expr's value
|
||||
;;
|
||||
;; Arithmetic expressions are SX-list compounds:
|
||||
;; (+ a b) (- a b) (* a b) (/ a b)
|
||||
;; or numbers / variables (must be bound at evaluation time).
|
||||
|
||||
(define
|
||||
dl-comparison?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let
|
||||
((rel (dl-rel-name lit)))
|
||||
(cond
|
||||
((nil? rel) false)
|
||||
(else (dl-member-string? rel (list "<" "<=" ">" ">=" "!="))))))))
|
||||
|
||||
(define
|
||||
dl-eq?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let ((rel (dl-rel-name lit))) (and (not (nil? rel)) (= rel "="))))))
|
||||
|
||||
(define
|
||||
dl-is?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let
|
||||
((rel (dl-rel-name lit)))
|
||||
(and (not (nil? rel)) (= rel "is"))))))
|
||||
|
||||
;; Evaluate an arithmetic expression under subst. Returns the numeric
|
||||
;; result, or raises if any operand is unbound or non-numeric.
|
||||
(define
|
||||
dl-eval-arith
|
||||
(fn
|
||||
(expr subst)
|
||||
(let
|
||||
((w (dl-walk expr subst)))
|
||||
(cond
|
||||
((number? w) w)
|
||||
((dl-var? w)
|
||||
(error (str "datalog arith: unbound variable " (symbol->string w))))
|
||||
((list? w)
|
||||
(let
|
||||
((rel (dl-rel-name w)) (args (rest w)))
|
||||
(cond
|
||||
((not (= (len args) 2))
|
||||
(error (str "datalog arith: need 2 args, got " w)))
|
||||
(else
|
||||
(let
|
||||
((a (dl-eval-arith (first args) subst))
|
||||
(b (dl-eval-arith (nth args 1) subst)))
|
||||
(cond
|
||||
((= rel "+") (+ a b))
|
||||
((= rel "-") (- a b))
|
||||
((= rel "*") (* a b))
|
||||
((= rel "/")
|
||||
(cond
|
||||
((= b 0)
|
||||
(error
|
||||
(str "datalog arith: division by zero in "
|
||||
w)))
|
||||
(else (/ a b))))
|
||||
(else (error (str "datalog arith: unknown op " rel)))))))))
|
||||
(else (error (str "datalog arith: not a number — " w)))))))
|
||||
|
||||
;; Comparable types — both operands must be the same primitive type
|
||||
;; (both numbers, both strings). `!=` is the exception: it's defined
|
||||
;; for any pair (returns true iff not equal) since dl-tuple-equal?
|
||||
;; handles type-mixed comparisons.
|
||||
(define
|
||||
dl-compare-typeok?
|
||||
(fn
|
||||
(rel a b)
|
||||
(cond
|
||||
((= rel "!=") true)
|
||||
((and (number? a) (number? b)) true)
|
||||
((and (string? a) (string? b)) true)
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
dl-eval-compare
|
||||
(fn
|
||||
(lit subst)
|
||||
(let
|
||||
((rel (dl-rel-name lit))
|
||||
(a (dl-walk (nth lit 1) subst))
|
||||
(b (dl-walk (nth lit 2) subst)))
|
||||
(cond
|
||||
((or (dl-var? a) (dl-var? b))
|
||||
(error
|
||||
(str
|
||||
"datalog: comparison "
|
||||
rel
|
||||
" has unbound argument; "
|
||||
"ensure prior body literal binds the variable")))
|
||||
((not (dl-compare-typeok? rel a b))
|
||||
(error
|
||||
(str "datalog: comparison " rel " requires same-type "
|
||||
"operands (both numbers or both strings), got "
|
||||
a " and " b)))
|
||||
(else
|
||||
(let
|
||||
((ok (cond ((= rel "<") (< a b)) ((= rel "<=") (<= a b)) ((= rel ">") (> a b)) ((= rel ">=") (>= a b)) ((= rel "!=") (not (dl-tuple-equal? a b))) (else (error (str "datalog: unknown compare " rel))))))
|
||||
(if ok subst nil)))))))
|
||||
|
||||
(define
|
||||
dl-eval-eq
|
||||
(fn
|
||||
(lit subst)
|
||||
(dl-unify (nth lit 1) (nth lit 2) subst)))
|
||||
|
||||
(define
|
||||
dl-eval-is
|
||||
(fn
|
||||
(lit subst)
|
||||
(let
|
||||
((target (nth lit 1)) (expr (nth lit 2)))
|
||||
(let
|
||||
((value (dl-eval-arith expr subst)))
|
||||
(dl-unify target value subst)))))
|
||||
|
||||
(define
|
||||
dl-eval-builtin
|
||||
(fn
|
||||
(lit subst)
|
||||
(cond
|
||||
((dl-comparison? lit) (dl-eval-compare lit subst))
|
||||
((dl-eq? lit) (dl-eval-eq lit subst))
|
||||
((dl-is? lit) (dl-eval-is lit subst))
|
||||
(else (error (str "dl-eval-builtin: not a built-in: " lit))))))
|
||||
|
||||
;; ── Safety analysis ──────────────────────────────────────────────
|
||||
;;
|
||||
;; Walks body literals left-to-right tracking a "bound" set. The check
|
||||
;; understands these literal kinds:
|
||||
;;
|
||||
;; positive non-built-in → adds its vars to bound
|
||||
;; (is X expr) → vars(expr) ⊆ bound, then add X (if var)
|
||||
;; <,<=,>,>=,!= → all vars ⊆ bound (no binding)
|
||||
;; (= a b) where:
|
||||
;; both non-vars → constraint check, no binding
|
||||
;; a var, b not → bind a
|
||||
;; b var, a not → bind b
|
||||
;; both vars → at least one in bound; bind the other
|
||||
;; {:neg lit} → all vars ⊆ bound (Phase 7 enforces fully)
|
||||
;;
|
||||
;; At end, head vars (minus `_`) must be ⊆ bound.
|
||||
|
||||
(define
|
||||
dl-vars-not-in
|
||||
(fn
|
||||
(vs bound)
|
||||
(let
|
||||
((out (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when (not (dl-member-string? v bound)) (append! out v)))
|
||||
vs)
|
||||
out))))
|
||||
|
||||
;; Filter a list of variable-name strings to exclude anonymous-renamed
|
||||
;; vars (`_` in source → `_anon*` by dl-rename-anon-term). Used by
|
||||
;; the negation safety check, where anonymous vars are existential
|
||||
;; within the negated literal.
|
||||
(define
|
||||
dl-non-anon-vars
|
||||
(fn
|
||||
(vs)
|
||||
(let
|
||||
((out (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(not (and (>= (len v) 5)
|
||||
(= (slice v 0 5) "_anon")))
|
||||
(append! out v)))
|
||||
vs)
|
||||
out))))
|
||||
|
||||
(define
|
||||
dl-rule-check-safety
|
||||
(fn
|
||||
(rule)
|
||||
(let
|
||||
((head (get rule :head))
|
||||
(body (get rule :body))
|
||||
(bound (list))
|
||||
(err nil))
|
||||
(do
|
||||
(define
|
||||
dl-add-bound!
|
||||
(fn
|
||||
(vs)
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when (not (dl-member-string? v bound)) (append! bound v)))
|
||||
vs)))
|
||||
(define
|
||||
dl-process-eq!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((a (nth lit 1)) (b (nth lit 2)))
|
||||
(let
|
||||
((va (dl-var? a)) (vb (dl-var? b)))
|
||||
(cond
|
||||
((and (not va) (not vb)) nil)
|
||||
((and va (not vb))
|
||||
(dl-add-bound! (list (symbol->string a))))
|
||||
((and (not va) vb)
|
||||
(dl-add-bound! (list (symbol->string b))))
|
||||
(else
|
||||
(let
|
||||
((sa (symbol->string a)) (sb (symbol->string b)))
|
||||
(cond
|
||||
((dl-member-string? sa bound)
|
||||
(dl-add-bound! (list sb)))
|
||||
((dl-member-string? sb bound)
|
||||
(dl-add-bound! (list sa)))
|
||||
(else
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"= between two unbound variables "
|
||||
(list sa sb)
|
||||
" — at least one must be bound by an "
|
||||
"earlier positive body literal")))))))))))
|
||||
(define
|
||||
dl-process-cmp!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((needed (dl-vars-of (list (nth lit 1) (nth lit 2)))))
|
||||
(let
|
||||
((missing (dl-vars-not-in needed bound)))
|
||||
(when
|
||||
(> (len missing) 0)
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"comparison "
|
||||
(dl-rel-name lit)
|
||||
" requires bound variable(s) "
|
||||
missing
|
||||
" (must be bound by an earlier positive "
|
||||
"body literal)")))))))
|
||||
(define
|
||||
dl-process-is!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((tgt (nth lit 1)) (expr (nth lit 2)))
|
||||
(let
|
||||
((needed (dl-vars-of expr)))
|
||||
(let
|
||||
((missing (dl-vars-not-in needed bound)))
|
||||
(cond
|
||||
((> (len missing) 0)
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"is RHS uses unbound variable(s) "
|
||||
missing
|
||||
" — bind them via a prior positive body "
|
||||
"literal")))
|
||||
(else
|
||||
(when
|
||||
(dl-var? tgt)
|
||||
(dl-add-bound! (list (symbol->string tgt)))))))))))
|
||||
(define
|
||||
dl-process-neg!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((inner (get lit :neg)))
|
||||
(let
|
||||
((inner-rn
|
||||
(cond
|
||||
((and (list? inner) (> (len inner) 0))
|
||||
(dl-rel-name inner))
|
||||
(else nil)))
|
||||
;; Anonymous variables (`_` in source → `_anon*` after
|
||||
;; renaming) are existentially quantified within the
|
||||
;; negated literal — they don't need to be bound by
|
||||
;; an earlier body lit, since `not p(X, _)` is a
|
||||
;; valid idiom for "no Y exists s.t. p(X, Y)". Filter
|
||||
;; them out of the safety check.
|
||||
(needed (dl-non-anon-vars (dl-vars-of inner)))
|
||||
(missing (dl-vars-not-in needed bound)))
|
||||
(cond
|
||||
((and (not (nil? inner-rn)) (dl-reserved-rel? inner-rn))
|
||||
(set! err
|
||||
(str "negated literal uses reserved name '"
|
||||
inner-rn
|
||||
"' — nested `not(...)` / negated built-ins are "
|
||||
"not supported; introduce an intermediate "
|
||||
"relation and negate that")))
|
||||
((> (len missing) 0)
|
||||
(set! err
|
||||
(str "negation refers to unbound variable(s) "
|
||||
missing
|
||||
" — they must be bound by an earlier "
|
||||
"positive body literal"))))))))
|
||||
(define
|
||||
dl-process-agg!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((result-var (nth lit 1)))
|
||||
;; Aggregate goal vars are existentially quantified within
|
||||
;; the aggregate; nothing required from outer context. The
|
||||
;; result var becomes bound after the aggregate fires.
|
||||
(when
|
||||
(dl-var? result-var)
|
||||
(dl-add-bound! (list (symbol->string result-var)))))))
|
||||
|
||||
(define
|
||||
dl-process-lit!
|
||||
(fn
|
||||
(lit)
|
||||
(when
|
||||
(nil? err)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(dl-process-neg! lit))
|
||||
;; A bare dict that is not a recognised negation is
|
||||
;; almost certainly a typo (e.g. `{:negs ...}` instead
|
||||
;; of `{:neg ...}`). Without this guard the dict would
|
||||
;; silently fall through every clause; the head safety
|
||||
;; check would then flag the head variables as unbound
|
||||
;; even though the real bug is the malformed body lit.
|
||||
((dict? lit)
|
||||
(set! err
|
||||
(str "body literal is a dict but lacks :neg — "
|
||||
"the only dict-shaped body lit recognised is "
|
||||
"{:neg <positive-lit>} for stratified "
|
||||
"negation, got " lit)))
|
||||
((dl-aggregate? lit) (dl-process-agg! lit))
|
||||
((dl-eq? lit) (dl-process-eq! lit))
|
||||
((dl-is? lit) (dl-process-is! lit))
|
||||
((dl-comparison? lit) (dl-process-cmp! lit))
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(let ((rn (dl-rel-name lit)))
|
||||
(cond
|
||||
((and (not (nil? rn)) (dl-reserved-rel? rn))
|
||||
(set! err
|
||||
(str "body literal uses reserved name '" rn
|
||||
"' — built-ins / aggregates have their own "
|
||||
"syntax; nested `not(...)` is not supported "
|
||||
"(use stratified negation via an "
|
||||
"intermediate relation)")))
|
||||
(else (dl-add-bound! (dl-vars-of lit))))))
|
||||
(else
|
||||
;; Anything that's not a dict, not a list, or an
|
||||
;; empty list. Numbers / strings / symbols as body
|
||||
;; lits don't make sense — surface the type.
|
||||
(set! err
|
||||
(str "body literal must be a positive lit, "
|
||||
"built-in, aggregate, or {:neg ...} dict, "
|
||||
"got " lit)))))))
|
||||
(for-each dl-process-lit! body)
|
||||
(when
|
||||
(nil? err)
|
||||
(let
|
||||
((head-vars (dl-vars-of head)) (missing (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(and (not (dl-member-string? v bound)) (not (= v "_")))
|
||||
(append! missing v)))
|
||||
head-vars)
|
||||
(when
|
||||
(> (len missing) 0)
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"head variable(s) "
|
||||
missing
|
||||
" do not appear in any positive body literal"))))))
|
||||
err))))
|
||||
@@ -1,32 +0,0 @@
|
||||
# Datalog conformance config — sourced by lib/guest/conformance.sh.
|
||||
|
||||
LANG_NAME=datalog
|
||||
MODE=dict
|
||||
|
||||
PRELOADS=(
|
||||
lib/datalog/tokenizer.sx
|
||||
lib/datalog/parser.sx
|
||||
lib/datalog/unify.sx
|
||||
lib/datalog/db.sx
|
||||
lib/datalog/builtins.sx
|
||||
lib/datalog/aggregates.sx
|
||||
lib/datalog/strata.sx
|
||||
lib/datalog/eval.sx
|
||||
lib/datalog/api.sx
|
||||
lib/datalog/magic.sx
|
||||
lib/datalog/demo.sx
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"tokenize:lib/datalog/tests/tokenize.sx:(dl-tokenize-tests-run!)"
|
||||
"parse:lib/datalog/tests/parse.sx:(dl-parse-tests-run!)"
|
||||
"unify:lib/datalog/tests/unify.sx:(dl-unify-tests-run!)"
|
||||
"eval:lib/datalog/tests/eval.sx:(dl-eval-tests-run!)"
|
||||
"builtins:lib/datalog/tests/builtins.sx:(dl-builtins-tests-run!)"
|
||||
"semi_naive:lib/datalog/tests/semi_naive.sx:(dl-semi-naive-tests-run!)"
|
||||
"negation:lib/datalog/tests/negation.sx:(dl-negation-tests-run!)"
|
||||
"aggregates:lib/datalog/tests/aggregates.sx:(dl-aggregates-tests-run!)"
|
||||
"api:lib/datalog/tests/api.sx:(dl-api-tests-run!)"
|
||||
"magic:lib/datalog/tests/magic.sx:(dl-magic-tests-run!)"
|
||||
"demo:lib/datalog/tests/demo.sx:(dl-demo-tests-run!)"
|
||||
)
|
||||
@@ -1,3 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/datalog/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
@@ -1,97 +0,0 @@
|
||||
;; lib/datalog/datalog.sx — public API documentation index.
|
||||
;;
|
||||
;; This file is reference-only — `load` is an epoch-protocol command,
|
||||
;; not an SX function, so it cannot reload a list of files from inside
|
||||
;; another `.sx` file. To set up a fresh sx_server session with all
|
||||
;; modules in scope, issue these loads in order:
|
||||
;;
|
||||
;; (load "lib/datalog/tokenizer.sx")
|
||||
;; (load "lib/datalog/parser.sx")
|
||||
;; (load "lib/datalog/unify.sx")
|
||||
;; (load "lib/datalog/db.sx")
|
||||
;; (load "lib/datalog/builtins.sx")
|
||||
;; (load "lib/datalog/aggregates.sx")
|
||||
;; (load "lib/datalog/strata.sx")
|
||||
;; (load "lib/datalog/eval.sx")
|
||||
;; (load "lib/datalog/api.sx")
|
||||
;; (load "lib/datalog/magic.sx")
|
||||
;; (load "lib/datalog/demo.sx")
|
||||
;;
|
||||
;; (lib/datalog/conformance.sh runs this load list automatically.)
|
||||
;;
|
||||
;; ── Public API surface ─────────────────────────────────────────────
|
||||
;;
|
||||
;; Source / data:
|
||||
;; (dl-tokenize "src") → token list
|
||||
;; (dl-parse "src") → parsed clauses
|
||||
;; (dl-program "src") → db built from a source string
|
||||
;; (dl-program-data facts rules) → db from SX data lists; rules
|
||||
;; accept either dict form or
|
||||
;; list form with `<-` arrow
|
||||
;;
|
||||
;; Construction (mutates db):
|
||||
;; (dl-make-db) empty db
|
||||
;; (dl-add-fact! db lit) rejects non-ground
|
||||
;; (dl-add-rule! db rule) rejects unsafe rules
|
||||
;; (dl-rule head body) dict-rule constructor
|
||||
;; (dl-add-clause! db clause) parser output → fact or rule
|
||||
;; (dl-load-program! db src) string source
|
||||
;; (dl-set-strategy! db strategy) :semi-naive default; :magic
|
||||
;; is informational, use
|
||||
;; dl-magic-query for actual
|
||||
;; magic-sets evaluation
|
||||
;;
|
||||
;; Mutation:
|
||||
;; (dl-assert! db lit) add + re-saturate
|
||||
;; (dl-retract! db lit) drop EDB, wipe IDB, re-saturate
|
||||
;; (dl-clear-idb! db) wipe rule-headed relations
|
||||
;;
|
||||
;; Query / inspection:
|
||||
;; (dl-saturate! db) stratified semi-naive default
|
||||
;; (dl-saturate-naive! db) reference (slow on chains)
|
||||
;; (dl-saturate-rules! db rules) per-rule-set semi-naive worker
|
||||
;; (dl-query db goal) list of substitution dicts
|
||||
;; (dl-relation db rel-name) tuple list for a relation
|
||||
;; (dl-rules db) rule list
|
||||
;; (dl-fact-count db) total ground tuples
|
||||
;; (dl-summary db) {<rel>: count} for inspection
|
||||
;;
|
||||
;; Single-call convenience:
|
||||
;; (dl-eval source query-source) parse, run, return substs
|
||||
;; (dl-eval-magic source query-source) single-goal → magic-sets
|
||||
;;
|
||||
;; Magic-sets (lib/datalog/magic.sx):
|
||||
;; (dl-adorn-goal goal) "b/f" adornment string
|
||||
;; (dl-rule-sips rule head-adn) SIPS analysis per body lit
|
||||
;; (dl-magic-rewrite rules rel adn args)
|
||||
;; rewritten rule list + seed
|
||||
;; (dl-magic-query db query-goal) end-to-end magic-sets query
|
||||
;;
|
||||
;; ── Body literal kinds ─────────────────────────────────────────────
|
||||
;;
|
||||
;; Positive (rel arg ... arg)
|
||||
;; Negation {:neg (rel arg ...)}
|
||||
;; Comparison (< X Y), (<= X Y), (> X Y), (>= X Y),
|
||||
;; (= X Y), (!= X Y)
|
||||
;; Arithmetic (is Z (+ X Y)) and (- * /)
|
||||
;; Aggregation (count R V Goal), (sum R V Goal),
|
||||
;; (min R V Goal), (max R V Goal),
|
||||
;; (findall L V Goal)
|
||||
;;
|
||||
;; ── Variable conventions ───────────────────────────────────────────
|
||||
;;
|
||||
;; Variables: SX symbols whose first char is uppercase A–Z or '_'.
|
||||
;; Anonymous '_' is renamed to a fresh _anon<N> per occurrence at
|
||||
;; rule/query load time so multiple '_' don't unify.
|
||||
;;
|
||||
;; ── Demo programs ──────────────────────────────────────────────────
|
||||
;;
|
||||
;; See lib/datalog/demo.sx — federation, content, permissions, and
|
||||
;; the canonical "cooking posts by people I follow (transitively)"
|
||||
;; example.
|
||||
;;
|
||||
;; ── Status ─────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; See plans/datalog-on-sx.md — phase-by-phase progress log and
|
||||
;; roadmap. Run `bash lib/datalog/conformance.sh` to refresh
|
||||
;; `lib/datalog/scoreboard.{json,md}`.
|
||||
@@ -1,575 +0,0 @@
|
||||
;; lib/datalog/db.sx — Datalog database (EDB + IDB + rules) + safety hook.
|
||||
;;
|
||||
;; A db is a mutable dict:
|
||||
;; {:facts {<rel-name-string> -> (literal ...)}
|
||||
;; :rules ({:head literal :body (literal ...)} ...)}
|
||||
;;
|
||||
;; Facts are stored as full literals `(rel arg ... arg)` so they unify
|
||||
;; directly against rule body literals. Each relation's tuple list is
|
||||
;; deduplicated on insert.
|
||||
;;
|
||||
;; Phase 3 introduced safety analysis for head variables; Phase 4 (in
|
||||
;; lib/datalog/builtins.sx) swaps in the real `dl-rule-check-safety`,
|
||||
;; which is order-aware and understands built-in predicates.
|
||||
|
||||
(define
|
||||
dl-make-db
|
||||
(fn ()
|
||||
{:facts {}
|
||||
:facts-keys {}
|
||||
:facts-index {}
|
||||
:edb-keys {}
|
||||
:rules (list)
|
||||
:strategy :semi-naive}))
|
||||
|
||||
;; Record (rel-key, tuple-key) as user-asserted EDB. dl-add-fact! calls
|
||||
;; this when an explicit fact is added; the saturator (which uses
|
||||
;; dl-add-derived!) does NOT, so derived tuples never appear here.
|
||||
;; dl-retract! consults :edb-keys to know which tuples must survive
|
||||
;; the wipe-and-resaturate round-trip.
|
||||
(define
|
||||
dl-mark-edb!
|
||||
(fn
|
||||
(db rel-key tk)
|
||||
(let
|
||||
((edb (get db :edb-keys)))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? edb rel-key))
|
||||
(dict-set! edb rel-key {}))
|
||||
(dict-set! (get edb rel-key) tk true)))))
|
||||
|
||||
(define
|
||||
dl-edb-fact?
|
||||
(fn
|
||||
(db rel-key tk)
|
||||
(let
|
||||
((edb (get db :edb-keys)))
|
||||
(and (has-key? edb rel-key)
|
||||
(has-key? (get edb rel-key) tk)))))
|
||||
|
||||
;; Evaluation strategy. Default :semi-naive (used by dl-saturate!).
|
||||
;; :naive selects dl-saturate-naive! (slower but easier to reason
|
||||
;; about). :magic is a marker — goal-directed magic-sets evaluation
|
||||
;; is invoked separately via `dl-magic-query`; setting :magic here
|
||||
;; is purely informational. Any other value is rejected so typos
|
||||
;; don't silently fall back to the default.
|
||||
(define
|
||||
dl-strategy-values
|
||||
(list :semi-naive :naive :magic))
|
||||
|
||||
(define
|
||||
dl-set-strategy!
|
||||
(fn
|
||||
(db strategy)
|
||||
(cond
|
||||
((not (dl-keyword-member? strategy dl-strategy-values))
|
||||
(error (str "dl-set-strategy!: unknown strategy " strategy
|
||||
" — must be one of " dl-strategy-values)))
|
||||
(else
|
||||
(do
|
||||
(dict-set! db :strategy strategy)
|
||||
db)))))
|
||||
|
||||
(define
|
||||
dl-keyword-member?
|
||||
(fn
|
||||
(k xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= k (first xs)) true)
|
||||
(else (dl-keyword-member? k (rest xs))))))
|
||||
|
||||
(define
|
||||
dl-get-strategy
|
||||
(fn
|
||||
(db)
|
||||
(if (has-key? db :strategy) (get db :strategy) :semi-naive)))
|
||||
|
||||
(define
|
||||
dl-rel-name
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg)) (dl-rel-name (get lit :neg)))
|
||||
((and (list? lit) (> (len lit) 0) (symbol? (first lit)))
|
||||
(symbol->string (first lit)))
|
||||
(else nil))))
|
||||
|
||||
(define dl-builtin-rels (list "<" "<=" ">" ">=" "=" "!=" "is"))
|
||||
|
||||
(define
|
||||
dl-member-string?
|
||||
(fn
|
||||
(s xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) s) true)
|
||||
(else (dl-member-string? s (rest xs))))))
|
||||
|
||||
(define
|
||||
dl-builtin?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let
|
||||
((rel (dl-rel-name lit)))
|
||||
(cond
|
||||
((nil? rel) false)
|
||||
(else (dl-member-string? rel dl-builtin-rels)))))))
|
||||
|
||||
(define
|
||||
dl-positive-lit?
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg)) false)
|
||||
((dl-builtin? lit) false)
|
||||
((and (list? lit) (> (len lit) 0)) true)
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
dl-tuple-equal?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-tuple-equal-list? a b 0)))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-tuple-equal-list?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-tuple-equal? (nth a i) (nth b i))) false)
|
||||
(else (dl-tuple-equal-list? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-tuple-member?
|
||||
(fn
|
||||
(lit lits)
|
||||
(dl-tuple-member-aux? lit lits 0 (len lits))))
|
||||
|
||||
(define
|
||||
dl-tuple-member-aux?
|
||||
(fn
|
||||
(lit lits i n)
|
||||
(cond
|
||||
((>= i n) false)
|
||||
((dl-tuple-equal? lit (nth lits i)) true)
|
||||
(else (dl-tuple-member-aux? lit lits (+ i 1) n)))))
|
||||
|
||||
(define
|
||||
dl-ensure-rel!
|
||||
(fn
|
||||
(db rel-key)
|
||||
(let
|
||||
((facts (get db :facts))
|
||||
(fk (get db :facts-keys))
|
||||
(fi (get db :facts-index)))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? facts rel-key))
|
||||
(dict-set! facts rel-key (list)))
|
||||
(when
|
||||
(not (has-key? fk rel-key))
|
||||
(dict-set! fk rel-key {}))
|
||||
(when
|
||||
(not (has-key? fi rel-key))
|
||||
(dict-set! fi rel-key {}))
|
||||
(get facts rel-key)))))
|
||||
|
||||
;; First-arg index helpers. Tuples are keyed by their first-after-rel
|
||||
;; arg's `(str ...)`; when that arg is a constant, dl-match-positive
|
||||
;; uses the index instead of scanning the full relation.
|
||||
(define
|
||||
dl-arg-key
|
||||
(fn
|
||||
(v)
|
||||
(str v)))
|
||||
|
||||
(define
|
||||
dl-index-add!
|
||||
(fn
|
||||
(db rel-key lit)
|
||||
(let
|
||||
((idx (get db :facts-index))
|
||||
(n (len lit)))
|
||||
(when
|
||||
(and (>= n 2) (has-key? idx rel-key))
|
||||
(let
|
||||
((rel-idx (get idx rel-key))
|
||||
(k (dl-arg-key (nth lit 1))))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? rel-idx k))
|
||||
(dict-set! rel-idx k (list)))
|
||||
(append! (get rel-idx k) lit)))))))
|
||||
|
||||
(define
|
||||
dl-index-lookup
|
||||
(fn
|
||||
(db rel-key arg-val)
|
||||
(let
|
||||
((idx (get db :facts-index)))
|
||||
(cond
|
||||
((not (has-key? idx rel-key)) (list))
|
||||
(else
|
||||
(let ((rel-idx (get idx rel-key))
|
||||
(k (dl-arg-key arg-val)))
|
||||
(if (has-key? rel-idx k) (get rel-idx k) (list))))))))
|
||||
|
||||
(define dl-tuple-key (fn (lit) (str lit)))
|
||||
|
||||
(define
|
||||
dl-rel-tuples
|
||||
(fn
|
||||
(db rel-key)
|
||||
(let
|
||||
((facts (get db :facts)))
|
||||
(if (has-key? facts rel-key) (get facts rel-key) (list)))))
|
||||
|
||||
;; Reserved relation names: built-in / aggregate / negation / arrow.
|
||||
;; Rules and facts may not have these as their head's relation, since
|
||||
;; the saturator treats them specially or they are not relation names
|
||||
;; at all.
|
||||
(define
|
||||
dl-reserved-rel-names
|
||||
(list "not" "count" "sum" "min" "max" "findall" "is"
|
||||
"<" "<=" ">" ">=" "=" "!=" "+" "-" "*" "/" ":-" "?-"))
|
||||
|
||||
(define
|
||||
dl-reserved-rel?
|
||||
(fn
|
||||
(name) (dl-member-string? name dl-reserved-rel-names)))
|
||||
|
||||
;; Internal: append a derived tuple to :facts without the public
|
||||
;; validation pass and without marking :edb-keys. Used by the saturator
|
||||
;; (eval.sx) and magic-sets (magic.sx). Returns true if the tuple was
|
||||
;; new, false if already present.
|
||||
(define
|
||||
dl-add-derived!
|
||||
(fn
|
||||
(db lit)
|
||||
(let
|
||||
((rel-key (dl-rel-name lit)))
|
||||
(let
|
||||
((tuples (dl-ensure-rel! db rel-key))
|
||||
(key-dict (get (get db :facts-keys) rel-key))
|
||||
(tk (dl-tuple-key lit)))
|
||||
(cond
|
||||
((has-key? key-dict tk) false)
|
||||
(else
|
||||
(do
|
||||
(dict-set! key-dict tk true)
|
||||
(append! tuples lit)
|
||||
(dl-index-add! db rel-key lit)
|
||||
true)))))))
|
||||
|
||||
;; A simple term — number, string, or symbol — i.e. anything legal
|
||||
;; as an EDB fact arg. Compound (list) args belong only in body
|
||||
;; literals where they encode arithmetic / aggregate sub-goals.
|
||||
(define
|
||||
dl-simple-term?
|
||||
(fn
|
||||
(term)
|
||||
(or (number? term) (string? term) (symbol? term))))
|
||||
|
||||
(define
|
||||
dl-args-simple?
|
||||
(fn
|
||||
(lit i n)
|
||||
(cond
|
||||
((>= i n) true)
|
||||
((not (dl-simple-term? (nth lit i))) false)
|
||||
(else (dl-args-simple? lit (+ i 1) n)))))
|
||||
|
||||
(define
|
||||
dl-add-fact!
|
||||
(fn
|
||||
(db lit)
|
||||
(cond
|
||||
((not (and (list? lit) (> (len lit) 0)))
|
||||
(error (str "dl-add-fact!: expected literal list, got " lit)))
|
||||
((dl-reserved-rel? (dl-rel-name lit))
|
||||
(error (str "dl-add-fact!: '" (dl-rel-name lit)
|
||||
"' is a reserved name (built-in / aggregate / negation)")))
|
||||
((not (dl-args-simple? lit 1 (len lit)))
|
||||
(error (str "dl-add-fact!: fact args must be numbers, strings, "
|
||||
"or symbols — compound args (e.g. arithmetic "
|
||||
"expressions) are body-only and aren't evaluated "
|
||||
"in fact position. got " lit)))
|
||||
((not (dl-ground? lit (dl-empty-subst)))
|
||||
(error (str "dl-add-fact!: expected ground literal, got " lit)))
|
||||
(else
|
||||
(let
|
||||
((rel-key (dl-rel-name lit)) (tk (dl-tuple-key lit)))
|
||||
(do
|
||||
;; Always mark EDB origin — even if the tuple key was already
|
||||
;; present (e.g. previously derived), so an explicit assert
|
||||
;; promotes it to EDB and protects it from the IDB wipe.
|
||||
(dl-mark-edb! db rel-key tk)
|
||||
(dl-add-derived! db lit)))))))
|
||||
|
||||
;; The full safety check lives in builtins.sx (it has to know which
|
||||
;; predicates are built-ins). dl-add-rule! calls it via forward
|
||||
;; reference; load builtins.sx alongside db.sx in any setup that
|
||||
;; adds rules. The fallback below is used if builtins.sx isn't loaded.
|
||||
(define
|
||||
dl-rule-check-safety
|
||||
(fn
|
||||
(rule)
|
||||
(let
|
||||
((head-vars (dl-vars-of (get rule :head))) (body-vars (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(lit)
|
||||
(when
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(not (and (dict? lit) (has-key? lit :neg))))
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(not (dl-member-string? v body-vars))
|
||||
(append! body-vars v)))
|
||||
(dl-vars-of lit))))
|
||||
(get rule :body))
|
||||
(let
|
||||
((missing (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(and
|
||||
(not (dl-member-string? v body-vars))
|
||||
(not (= v "_")))
|
||||
(append! missing v)))
|
||||
head-vars)
|
||||
(cond
|
||||
((> (len missing) 0)
|
||||
(str
|
||||
"head variable(s) "
|
||||
missing
|
||||
" do not appear in any body literal"))
|
||||
(else nil))))))))
|
||||
|
||||
(define
|
||||
dl-rename-anon-term
|
||||
(fn
|
||||
(term next-name)
|
||||
(cond
|
||||
((and (symbol? term) (= (symbol->string term) "_"))
|
||||
(next-name))
|
||||
((list? term)
|
||||
(map (fn (x) (dl-rename-anon-term x next-name)) term))
|
||||
(else term))))
|
||||
|
||||
(define
|
||||
dl-rename-anon-lit
|
||||
(fn
|
||||
(lit next-name)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
{:neg (dl-rename-anon-term (get lit :neg) next-name)})
|
||||
((list? lit) (dl-rename-anon-term lit next-name))
|
||||
(else lit))))
|
||||
|
||||
(define
|
||||
dl-make-anon-renamer
|
||||
(fn
|
||||
(start)
|
||||
(let ((counter start))
|
||||
(fn () (do (set! counter (+ counter 1))
|
||||
(string->symbol (str "_anon" counter)))))))
|
||||
|
||||
;; Scan a rule for variables already named `_anon<N>` (which would
|
||||
;; otherwise collide with the renamer's output). Returns the max N
|
||||
;; seen, or 0 if none. The renamer then starts at that max + 1, so
|
||||
;; freshly-introduced anonymous names can't shadow a user-written
|
||||
;; `_anon<N>` symbol.
|
||||
(define
|
||||
dl-max-anon-num
|
||||
(fn
|
||||
(term acc)
|
||||
(cond
|
||||
((symbol? term)
|
||||
(let ((s (symbol->string term)))
|
||||
(cond
|
||||
((and (>= (len s) 6) (= (slice s 0 5) "_anon"))
|
||||
(let ((n (dl-try-parse-int (slice s 5 (len s)))))
|
||||
(cond
|
||||
((nil? n) acc)
|
||||
((> n acc) n)
|
||||
(else acc))))
|
||||
(else acc))))
|
||||
((dict? term)
|
||||
(cond
|
||||
((has-key? term :neg)
|
||||
(dl-max-anon-num (get term :neg) acc))
|
||||
(else acc)))
|
||||
((list? term) (dl-max-anon-num-list term acc 0))
|
||||
(else acc))))
|
||||
|
||||
(define
|
||||
dl-max-anon-num-list
|
||||
(fn
|
||||
(xs acc i)
|
||||
(cond
|
||||
((>= i (len xs)) acc)
|
||||
(else
|
||||
(dl-max-anon-num-list xs (dl-max-anon-num (nth xs i) acc) (+ i 1))))))
|
||||
|
||||
;; Cheap "is this string a decimal int" check. Returns the number or
|
||||
;; nil. Avoids relying on host parse-number, which on non-int strings
|
||||
;; might raise rather than return nil.
|
||||
(define
|
||||
dl-try-parse-int
|
||||
(fn
|
||||
(s)
|
||||
(cond
|
||||
((= (len s) 0) nil)
|
||||
((not (dl-all-digits? s 0 (len s))) nil)
|
||||
(else (parse-number s)))))
|
||||
|
||||
(define
|
||||
dl-all-digits?
|
||||
(fn
|
||||
(s i n)
|
||||
(cond
|
||||
((>= i n) true)
|
||||
((let ((c (slice s i (+ i 1))))
|
||||
(not (and (>= c "0") (<= c "9"))))
|
||||
false)
|
||||
(else (dl-all-digits? s (+ i 1) n)))))
|
||||
|
||||
(define
|
||||
dl-rename-anon-rule
|
||||
(fn
|
||||
(rule)
|
||||
(let
|
||||
((start (dl-max-anon-num (get rule :head)
|
||||
(dl-max-anon-num-list (get rule :body) 0 0))))
|
||||
(let ((next-name (dl-make-anon-renamer start)))
|
||||
{:head (dl-rename-anon-term (get rule :head) next-name)
|
||||
:body (map (fn (lit) (dl-rename-anon-lit lit next-name))
|
||||
(get rule :body))}))))
|
||||
|
||||
(define
|
||||
dl-add-rule!
|
||||
(fn
|
||||
(db rule)
|
||||
(cond
|
||||
((not (dict? rule))
|
||||
(error (str "dl-add-rule!: expected rule dict, got " rule)))
|
||||
((not (has-key? rule :head))
|
||||
(error (str "dl-add-rule!: rule missing :head, got " rule)))
|
||||
((not (and (list? (get rule :head))
|
||||
(> (len (get rule :head)) 0)
|
||||
(symbol? (first (get rule :head)))))
|
||||
(error (str "dl-add-rule!: head must be a non-empty list "
|
||||
"starting with a relation-name symbol, got "
|
||||
(get rule :head))))
|
||||
((not (dl-args-simple? (get rule :head) 1 (len (get rule :head))))
|
||||
(error (str "dl-add-rule!: rule head args must be variables or "
|
||||
"constants — compound terms (e.g. `(*(X, 2))`) are "
|
||||
"not legal in head position; introduce an `is`-bound "
|
||||
"intermediate in the body. got " (get rule :head))))
|
||||
((not (list? (if (has-key? rule :body) (get rule :body) (list))))
|
||||
(error (str "dl-add-rule!: body must be a list of literals, got "
|
||||
(get rule :body))))
|
||||
((dl-reserved-rel? (dl-rel-name (get rule :head)))
|
||||
(error (str "dl-add-rule!: '" (dl-rel-name (get rule :head))
|
||||
"' is a reserved name (built-in / aggregate / negation)")))
|
||||
(else
|
||||
(let ((rule (dl-rename-anon-rule rule)))
|
||||
(let
|
||||
((err (dl-rule-check-safety rule)))
|
||||
(cond
|
||||
((not (nil? err)) (error (str "dl-add-rule!: " err)))
|
||||
(else
|
||||
(let
|
||||
((rules (get db :rules)))
|
||||
(do (append! rules rule) true))))))))))
|
||||
|
||||
(define
|
||||
dl-add-clause!
|
||||
(fn
|
||||
(db clause)
|
||||
(cond
|
||||
((has-key? clause :query) false)
|
||||
((and (has-key? clause :body) (= (len (get clause :body)) 0))
|
||||
(dl-add-fact! db (get clause :head)))
|
||||
(else (dl-add-rule! db clause)))))
|
||||
|
||||
(define
|
||||
dl-load-program!
|
||||
(fn
|
||||
(db source)
|
||||
(let
|
||||
((clauses (dl-parse source)))
|
||||
(do (for-each (fn (c) (dl-add-clause! db c)) clauses) db))))
|
||||
|
||||
(define
|
||||
dl-program
|
||||
(fn (source) (let ((db (dl-make-db))) (dl-load-program! db source))))
|
||||
|
||||
(define dl-rules (fn (db) (get db :rules)))
|
||||
|
||||
(define
|
||||
dl-fact-count
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((facts (get db :facts)) (total 0))
|
||||
(do
|
||||
(for-each
|
||||
(fn (k) (set! total (+ total (len (get facts k)))))
|
||||
(keys facts))
|
||||
total))))
|
||||
|
||||
;; Returns {<rel-name>: tuple-count} for debugging. Includes
|
||||
;; relations with any tuples plus all rule-head relations (so empty
|
||||
;; IDB shows as 0). Skips empty EDB-only entries that are placeholders
|
||||
;; from internal `dl-ensure-rel!` calls.
|
||||
(define
|
||||
dl-summary
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((facts (get db :facts))
|
||||
(out {})
|
||||
(rule-heads (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(let ((h (dl-rel-name (get rule :head))))
|
||||
(when
|
||||
(and (not (nil? h)) (not (dl-member-string? h rule-heads)))
|
||||
(append! rule-heads h))))
|
||||
(dl-rules db))
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(let ((c (len (get facts k))))
|
||||
(when
|
||||
(or (> c 0) (dl-member-string? k rule-heads))
|
||||
(dict-set! out k c))))
|
||||
(keys facts))
|
||||
;; Add rule heads that have no facts (yet).
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(when (not (has-key? out k)) (dict-set! out k 0)))
|
||||
rule-heads)
|
||||
out))))
|
||||
@@ -1,162 +0,0 @@
|
||||
;; lib/datalog/demo.sx — example programs over rose-ash-shaped data.
|
||||
;;
|
||||
;; Phase 10 prototypes Datalog as a rose-ash query language. Wiring
|
||||
;; the EDB to actual PostgreSQL is out of scope for this loop (it
|
||||
;; would touch service code outside lib/datalog/), but the programs
|
||||
;; below show the shape of queries we want, and the test suite runs
|
||||
;; them against synthetic in-memory tuples loaded via dl-program-data.
|
||||
;;
|
||||
;; Seven thematic demos:
|
||||
;;
|
||||
;; 1. Federation — follow graph, transitive reach, mutuals, FOAF.
|
||||
;; 2. Content — posts, tags, likes, popularity, "for you" feed.
|
||||
;; 3. Permissions — group membership and resource access.
|
||||
;; 4. Cooking-posts — canonical "posts about cooking by people I
|
||||
;; follow (transitively)" multi-domain query.
|
||||
;; 5. Tag co-occurrence — distinct (T1, T2) pairs with counts.
|
||||
;; 6. Shortest path — weighted-DAG path enumeration + min agg.
|
||||
;; 7. Org chart — transitive subordinate + headcount per mgr.
|
||||
|
||||
;; ── Demo 1: federation follow graph ─────────────────────────────
|
||||
;; EDB: (follows ACTOR-A ACTOR-B) — A follows B.
|
||||
;; IDB:
|
||||
;; (mutual A B) — A follows B and B follows A
|
||||
;; (reachable A B) — transitive follow closure
|
||||
;; (foaf A C) — friend of a friend (mutual filter)
|
||||
(define
|
||||
dl-demo-federation-rules
|
||||
(quote
|
||||
((mutual A B <- (follows A B) (follows B A))
|
||||
(reachable A B <- (follows A B))
|
||||
(reachable A C <- (follows A B) (reachable B C))
|
||||
(foaf A C <- (follows A B) (follows B C) (!= A C)))))
|
||||
|
||||
;; ── Demo 2: content recommendation ──────────────────────────────
|
||||
;; EDB:
|
||||
;; (authored ACTOR POST)
|
||||
;; (tagged POST TAG)
|
||||
;; (liked ACTOR POST)
|
||||
;; IDB:
|
||||
;; (post-likes POST N) — count of likes per post
|
||||
;; (popular POST) — posts with >= 3 likes
|
||||
;; (tagged-by-mutual ACTOR POST) — post tagged TOPIC by someone
|
||||
;; A's mutuals follow.
|
||||
(define
|
||||
dl-demo-content-rules
|
||||
(quote
|
||||
((post-likes P N <- (authored Author P) (count N L (liked L P)))
|
||||
(popular P <- (authored Author P) (post-likes P N) (>= N 3))
|
||||
(interesting Me P
|
||||
<-
|
||||
(follows Me Buddy)
|
||||
(authored Buddy P)
|
||||
(popular P)))))
|
||||
|
||||
;; ── Demo 3: role-based permissions ──────────────────────────────
|
||||
;; EDB:
|
||||
;; (member ACTOR GROUP)
|
||||
;; (subgroup CHILD PARENT)
|
||||
;; (allowed GROUP RESOURCE)
|
||||
;; IDB:
|
||||
;; (in-group ACTOR GROUP) — direct or via subgroup chain
|
||||
;; (can-access ACTOR RESOURCE) — actor inherits group permission
|
||||
(define
|
||||
dl-demo-perm-rules
|
||||
(quote
|
||||
((in-group A G <- (member A G))
|
||||
(in-group A G <- (member A H) (subgroup-trans H G))
|
||||
(subgroup-trans X Y <- (subgroup X Y))
|
||||
(subgroup-trans X Z <- (subgroup X Y) (subgroup-trans Y Z))
|
||||
(can-access A R <- (in-group A G) (allowed G R)))))
|
||||
|
||||
;; ── Demo 4: cooking-posts (the canonical Phase 10 query) ────────
|
||||
;; "Posts about cooking by people I follow (transitively)."
|
||||
;; Combines federation (follows + transitive reach), authoring,
|
||||
;; tagging — the rose-ash multi-domain join.
|
||||
;;
|
||||
;; EDB:
|
||||
;; (follows ACTOR-A ACTOR-B)
|
||||
;; (authored ACTOR POST)
|
||||
;; (tagged POST TAG)
|
||||
(define
|
||||
dl-demo-cooking-rules
|
||||
(quote
|
||||
((reach Me Them <- (follows Me Them))
|
||||
(reach Me Them <- (follows Me X) (reach X Them))
|
||||
(cooking-post-by-network Me P
|
||||
<-
|
||||
(reach Me Author)
|
||||
(authored Author P)
|
||||
(tagged P cooking)))))
|
||||
|
||||
;; ── Demo 5: tag co-occurrence ───────────────────────────────────
|
||||
;; "Posts tagged with both T1 AND T2." Useful for narrowed-down
|
||||
;; recommendations like "vegetarian cooking" posts.
|
||||
;;
|
||||
;; EDB:
|
||||
;; (tagged POST TAG)
|
||||
;; IDB:
|
||||
;; (cotagged POST T1 T2) — post has both T1 and T2 (T1 != T2)
|
||||
;; (popular-pair T1 T2 N) — count of posts cotagged (T1, T2)
|
||||
(define
|
||||
dl-demo-tag-cooccur-rules
|
||||
(quote
|
||||
((cotagged P T1 T2 <- (tagged P T1) (tagged P T2) (!= T1 T2))
|
||||
;; Distinct (T1, T2) pairs that occur somewhere.
|
||||
(tag-pair T1 T2 <- (cotagged P T1 T2))
|
||||
(tag-pair-count T1 T2 N
|
||||
<-
|
||||
(tag-pair T1 T2)
|
||||
(count N P (cotagged P T1 T2))))))
|
||||
|
||||
;; ── Demo 6: weighted-DAG shortest path ─────────────────────────
|
||||
;; "What's the cheapest way from X to Y?" Edge weights with `is`
|
||||
;; arithmetic to sum costs, then `min` aggregation to pick the
|
||||
;; shortest. Termination requires the graph to be a DAG (cycles
|
||||
;; would produce infinite distances without a bound; programs
|
||||
;; built on this should add a depth filter `(<, D, MAX)` if cycles
|
||||
;; are possible).
|
||||
;;
|
||||
;; EDB:
|
||||
;; (edge FROM TO COST)
|
||||
;; IDB:
|
||||
;; (path FROM TO COST) — any path
|
||||
;; (shortest FROM TO COST) — minimum cost path
|
||||
(define
|
||||
dl-demo-shortest-path-rules
|
||||
(quote
|
||||
((path X Y W <- (edge X Y W))
|
||||
(path X Z W
|
||||
<-
|
||||
(edge X Y W1)
|
||||
(path Y Z W2)
|
||||
(is W (+ W1 W2)))
|
||||
(shortest X Y W <- (path X Y _) (min W C (path X Y C))))))
|
||||
|
||||
;; ── Demo 7: org chart + transitive headcount ───────────────────
|
||||
;; Manager graph: each employee has a single manager. Compute the
|
||||
;; transitive subordinate set and headcount per manager.
|
||||
;;
|
||||
;; EDB:
|
||||
;; (manager EMP MGR) — EMP reports directly to MGR
|
||||
;; IDB:
|
||||
;; (subordinate MGR EMP) — EMP is in MGR's subtree
|
||||
;; (headcount MGR N) — number of subordinates under MGR
|
||||
(define
|
||||
dl-demo-org-rules
|
||||
(quote
|
||||
((subordinate Mgr Emp <- (manager Emp Mgr))
|
||||
(subordinate Mgr Emp
|
||||
<- (manager Mid Mgr) (subordinate Mid Emp))
|
||||
(headcount Mgr N
|
||||
<- (subordinate Mgr Anyone) (count N E (subordinate Mgr E))))))
|
||||
|
||||
;; ── Loader stub ──────────────────────────────────────────────────
|
||||
;; Wiring to PostgreSQL would replace these helpers with calls into
|
||||
;; rose-ash's internal HTTP RPC (fetch_data → /internal/data/...).
|
||||
;; The shape returned by dl-load-from-edb! is the same in either case.
|
||||
(define
|
||||
dl-demo-make
|
||||
(fn
|
||||
(facts rules)
|
||||
(dl-program-data facts rules)))
|
||||
@@ -1,512 +0,0 @@
|
||||
;; lib/datalog/eval.sx — fixpoint evaluator (naive + semi-naive).
|
||||
;;
|
||||
;; Two saturators are exposed:
|
||||
;; `dl-saturate-naive!` — re-joins each rule against the full DB every
|
||||
;; iteration. Reference implementation; useful for differential tests.
|
||||
;; `dl-saturate!` — semi-naive default. Tracks per-relation delta
|
||||
;; sets and substitutes one positive body literal per rule with the
|
||||
;; delta of its relation, joining the rest against the previous-
|
||||
;; iteration DB. Same fixpoint, dramatically less work on recursive
|
||||
;; rules.
|
||||
;;
|
||||
;; Body literal kinds:
|
||||
;; positive (rel arg ... arg) → match against EDB+IDB tuples
|
||||
;; built-in (< X Y), (is X e) → constraint via dl-eval-builtin
|
||||
;; negation {:neg lit} → Phase 7
|
||||
|
||||
(define
|
||||
dl-match-positive
|
||||
(fn
|
||||
(lit db subst)
|
||||
(let
|
||||
((rel (dl-rel-name lit)) (results (list)))
|
||||
(cond
|
||||
((nil? rel) (error (str "dl-match-positive: bad literal " lit)))
|
||||
(else
|
||||
(let
|
||||
;; If the first argument walks to a non-variable (constant
|
||||
;; or already-bound var), use the first-arg index for
|
||||
;; this relation. Otherwise scan the full tuple list.
|
||||
((tuples
|
||||
(cond
|
||||
((>= (len lit) 2)
|
||||
(let ((walked (dl-walk (nth lit 1) subst)))
|
||||
(cond
|
||||
((dl-var? walked) (dl-rel-tuples db rel))
|
||||
(else (dl-index-lookup db rel walked)))))
|
||||
(else (dl-rel-tuples db rel)))))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(tuple)
|
||||
(let
|
||||
((s (dl-unify lit tuple subst)))
|
||||
(when (not (nil? s)) (append! results s))))
|
||||
tuples)
|
||||
results)))))))
|
||||
|
||||
;; Match a positive literal against the delta set for its relation only.
|
||||
(define
|
||||
dl-match-positive-delta
|
||||
(fn
|
||||
(lit delta subst)
|
||||
(let
|
||||
((rel (dl-rel-name lit)) (results (list)))
|
||||
(let
|
||||
((tuples (if (has-key? delta rel) (get delta rel) (list))))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(tuple)
|
||||
(let
|
||||
((s (dl-unify lit tuple subst)))
|
||||
(when (not (nil? s)) (append! results s))))
|
||||
tuples)
|
||||
results)))))
|
||||
|
||||
;; Naive matcher (for dl-saturate-naive! and dl-query post-saturation).
|
||||
(define
|
||||
dl-match-negation
|
||||
(fn
|
||||
(inner db subst)
|
||||
(let
|
||||
((walked (dl-apply-subst inner subst))
|
||||
(matches (dl-match-positive inner db subst)))
|
||||
(cond
|
||||
((= (len matches) 0) (list subst))
|
||||
(else (list))))))
|
||||
|
||||
(define
|
||||
dl-match-lit
|
||||
(fn
|
||||
(lit db subst)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(dl-match-negation (get lit :neg) db subst))
|
||||
((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
|
||||
((dl-builtin? lit)
|
||||
(let
|
||||
((s (dl-eval-builtin lit subst)))
|
||||
(if (nil? s) (list) (list s))))
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(dl-match-positive lit db subst))
|
||||
(else (error (str "datalog: unknown body-literal shape: " lit))))))
|
||||
|
||||
(define
|
||||
dl-find-bindings
|
||||
(fn (lits db subst) (dl-fb-aux lits db subst 0 (len lits))))
|
||||
|
||||
(define
|
||||
dl-fb-aux
|
||||
(fn
|
||||
(lits db subst i n)
|
||||
(cond
|
||||
((nil? subst) (list))
|
||||
((>= i n) (list subst))
|
||||
(else
|
||||
(let
|
||||
((options (dl-match-lit (nth lits i) db subst))
|
||||
(results (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(for-each
|
||||
(fn (s2) (append! results s2))
|
||||
(dl-fb-aux lits db s (+ i 1) n)))
|
||||
options)
|
||||
results))))))
|
||||
|
||||
;; Naive: apply each rule against full DB until no new tuples.
|
||||
(define
|
||||
dl-apply-rule!
|
||||
(fn
|
||||
(db rule)
|
||||
(let
|
||||
((head (get rule :head)) (body (get rule :body)) (new? false))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((derived (dl-apply-subst head s)))
|
||||
(when (dl-add-derived! db derived) (set! new? true))))
|
||||
(dl-find-bindings body db (dl-empty-subst)))
|
||||
new?))))
|
||||
|
||||
;; Returns true iff one more saturation step would derive no new
|
||||
;; tuples (i.e. the db is at fixpoint). Useful in tests that want
|
||||
;; to assert "no work left" after a saturation call. Works under
|
||||
;; either saturator since both compute the same fixpoint.
|
||||
(define
|
||||
dl-saturated?
|
||||
(fn
|
||||
(db)
|
||||
(let ((any-new false))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(when (not any-new)
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let ((derived (dl-apply-subst (get rule :head) s)))
|
||||
(when
|
||||
(and (not any-new)
|
||||
(not (dl-tuple-member?
|
||||
derived
|
||||
(dl-rel-tuples
|
||||
db (dl-rel-name derived)))))
|
||||
(set! any-new true))))
|
||||
(dl-find-bindings (get rule :body) db (dl-empty-subst)))))
|
||||
(dl-rules db))
|
||||
(not any-new)))))
|
||||
|
||||
(define
|
||||
dl-saturate-naive!
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((changed true))
|
||||
(do
|
||||
(define
|
||||
dl-snloop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
changed
|
||||
(do
|
||||
(set! changed false)
|
||||
(for-each
|
||||
(fn (r) (when (dl-apply-rule! db r) (set! changed true)))
|
||||
(dl-rules db))
|
||||
(dl-snloop)))))
|
||||
(dl-snloop)
|
||||
db))))
|
||||
|
||||
;; ── Semi-naive ───────────────────────────────────────────────────
|
||||
|
||||
;; Take a snapshot dict {rel -> tuples} of every relation currently in
|
||||
;; the DB. Used as initial delta for the first iteration.
|
||||
(define
|
||||
dl-snapshot-facts
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((facts (get db :facts)) (out {}))
|
||||
(do
|
||||
(for-each
|
||||
(fn (k) (dict-set! out k (dl-copy-list (get facts k))))
|
||||
(keys facts))
|
||||
out))))
|
||||
|
||||
(define
|
||||
dl-copy-list
|
||||
(fn
|
||||
(xs)
|
||||
(let
|
||||
((out (list)))
|
||||
(do (for-each (fn (x) (append! out x)) xs) out))))
|
||||
|
||||
;; Does any relation in `delta` have ≥1 tuple?
|
||||
(define
|
||||
dl-delta-empty?
|
||||
(fn
|
||||
(delta)
|
||||
(let
|
||||
((ks (keys delta)) (any-non-empty false))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(when
|
||||
(> (len (get delta k)) 0)
|
||||
(set! any-non-empty true)))
|
||||
ks)
|
||||
(not any-non-empty)))))
|
||||
|
||||
;; Find substitutions such that `lits` are all satisfied AND `delta-idx`
|
||||
;; is matched against the per-relation delta only. The other positive
|
||||
;; literals match against the snapshot DB (db.facts read at iteration
|
||||
;; start). Built-ins and negations behave as in `dl-match-lit`.
|
||||
(define
|
||||
dl-find-bindings-semi
|
||||
(fn
|
||||
(lits db delta delta-idx subst)
|
||||
(dl-fbs-aux lits db delta delta-idx 0 subst)))
|
||||
|
||||
(define
|
||||
dl-fbs-aux
|
||||
(fn
|
||||
(lits db delta delta-idx i subst)
|
||||
(cond
|
||||
((nil? subst) (list))
|
||||
((>= i (len lits)) (list subst))
|
||||
(else
|
||||
(let
|
||||
((lit (nth lits i))
|
||||
(options
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(dl-match-negation (get lit :neg) db subst))
|
||||
((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
|
||||
((dl-builtin? lit)
|
||||
(let
|
||||
((s (dl-eval-builtin lit subst)))
|
||||
(if (nil? s) (list) (list s))))
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(if
|
||||
(= i delta-idx)
|
||||
(dl-match-positive-delta lit delta subst)
|
||||
(dl-match-positive lit db subst)))
|
||||
(else (error (str "datalog: unknown body-lit: " lit)))))
|
||||
(results (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(for-each
|
||||
(fn (s2) (append! results s2))
|
||||
(dl-fbs-aux lits db delta delta-idx (+ i 1) s)))
|
||||
options)
|
||||
results))))))
|
||||
|
||||
;; Collect candidate head tuples from a rule using delta. Walks every
|
||||
;; positive body position and unions the resulting heads. For rules
|
||||
;; with no positive body literal, falls back to a naive single-pass
|
||||
;; (so static facts like `(p X) :- (= X 5).` derive on iteration 1).
|
||||
(define
|
||||
dl-collect-rule-candidates
|
||||
(fn
|
||||
(rule db delta)
|
||||
(let
|
||||
((head (get rule :head))
|
||||
(body (get rule :body))
|
||||
(out (list))
|
||||
(saw-pos false))
|
||||
(do
|
||||
(define
|
||||
dl-cri
|
||||
(fn
|
||||
(i)
|
||||
(when
|
||||
(< i (len body))
|
||||
(do
|
||||
(let
|
||||
((lit (nth body i)))
|
||||
(when
|
||||
(dl-positive-lit? lit)
|
||||
(do
|
||||
(set! saw-pos true)
|
||||
(for-each
|
||||
(fn (s) (append! out (dl-apply-subst head s)))
|
||||
(dl-find-bindings-semi
|
||||
body
|
||||
db
|
||||
delta
|
||||
i
|
||||
(dl-empty-subst))))))
|
||||
(dl-cri (+ i 1))))))
|
||||
(dl-cri 0)
|
||||
(when
|
||||
(not saw-pos)
|
||||
(for-each
|
||||
(fn (s) (append! out (dl-apply-subst head s)))
|
||||
(dl-find-bindings body db (dl-empty-subst))))
|
||||
out))))
|
||||
|
||||
;; Add a list of candidate tuples to db; collect newly-added ones into
|
||||
;; the new-delta dict (keyed by relation name).
|
||||
(define
|
||||
dl-commit-candidates!
|
||||
(fn
|
||||
(db candidates new-delta)
|
||||
(for-each
|
||||
(fn
|
||||
(lit)
|
||||
(when
|
||||
(dl-add-derived! db lit)
|
||||
(let
|
||||
((rel (dl-rel-name lit)))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? new-delta rel))
|
||||
(dict-set! new-delta rel (list)))
|
||||
(append! (get new-delta rel) lit)))))
|
||||
candidates)))
|
||||
|
||||
(define
|
||||
dl-saturate-rules!
|
||||
(fn
|
||||
(db rules)
|
||||
(let
|
||||
((delta (dl-snapshot-facts db)))
|
||||
(do
|
||||
(define
|
||||
dl-sr-step
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((pending (list)) (new-delta {}))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(for-each
|
||||
(fn (cand) (append! pending cand))
|
||||
(dl-collect-rule-candidates rule db delta)))
|
||||
rules)
|
||||
(dl-commit-candidates! db pending new-delta)
|
||||
(cond
|
||||
((dl-delta-empty? new-delta) nil)
|
||||
(else (do (set! delta new-delta) (dl-sr-step))))))))
|
||||
(dl-sr-step)
|
||||
db))))
|
||||
|
||||
;; Stratified driver: rejects non-stratifiable programs at saturation
|
||||
;; time, then iterates strata in increasing order, running semi-naive on
|
||||
;; the rules whose head sits in that stratum.
|
||||
(define
|
||||
dl-saturate!
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((err (dl-check-stratifiable db)))
|
||||
(cond
|
||||
((not (nil? err)) (error (str "dl-saturate!: " err)))
|
||||
(else
|
||||
(let
|
||||
((strata (dl-compute-strata db)))
|
||||
(let
|
||||
((grouped (dl-group-rules-by-stratum db strata)))
|
||||
(let
|
||||
((groups (get grouped :groups))
|
||||
(max-s (get grouped :max)))
|
||||
(do
|
||||
(define
|
||||
dl-strat-loop
|
||||
(fn
|
||||
(s)
|
||||
(when
|
||||
(<= s max-s)
|
||||
(let
|
||||
((sk (str s)))
|
||||
(do
|
||||
(when
|
||||
(has-key? groups sk)
|
||||
(dl-saturate-rules! db (get groups sk)))
|
||||
(dl-strat-loop (+ s 1)))))))
|
||||
(dl-strat-loop 0)
|
||||
db)))))))))
|
||||
|
||||
;; ── Querying ─────────────────────────────────────────────────────
|
||||
|
||||
;; Coerce a query argument to a list of body literals. A single literal
|
||||
;; like `(p X)` (positive — head is a symbol) or `{:neg ...}` becomes
|
||||
;; `((p X))`. A list of literals like `((p X) (q X))` is returned as-is.
|
||||
(define
|
||||
dl-query-coerce
|
||||
(fn
|
||||
(goal)
|
||||
(cond
|
||||
((and (dict? goal) (has-key? goal :neg)) (list goal))
|
||||
((and (list? goal) (> (len goal) 0) (symbol? (first goal)))
|
||||
(list goal))
|
||||
((list? goal) goal)
|
||||
(else (error (str "dl-query: unrecognised goal shape: " goal))))))
|
||||
|
||||
(define
|
||||
dl-query
|
||||
(fn
|
||||
(db goal)
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
;; Rename anonymous '_' vars in each goal literal so multiple
|
||||
;; occurrences do not unify together. Keep the user-facing var
|
||||
;; list (taken before renaming) so projected results retain user
|
||||
;; names.
|
||||
(let
|
||||
((goals (dl-query-coerce goal))
|
||||
;; Start the renamer past any `_anon<N>` symbols the user
|
||||
;; may have written in the query — avoids collision.
|
||||
(renamer
|
||||
(dl-make-anon-renamer (dl-max-anon-num-list goal 0 0))))
|
||||
(let
|
||||
((user-vars (dl-query-user-vars goals))
|
||||
(renamed (map (fn (g) (dl-rename-anon-lit g renamer)) goals)))
|
||||
(let
|
||||
((substs (dl-find-bindings renamed db (dl-empty-subst)))
|
||||
(results (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((proj (dl-project-subst s user-vars)))
|
||||
(when
|
||||
(not (dl-tuple-member? proj results))
|
||||
(append! results proj))))
|
||||
substs)
|
||||
results)))))))
|
||||
|
||||
(define
|
||||
dl-query-user-vars
|
||||
(fn
|
||||
(goals)
|
||||
(let ((seen (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(g)
|
||||
(cond
|
||||
((and (dict? g) (has-key? g :neg))
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(and (not (= v "_")) (not (dl-member-string? v seen)))
|
||||
(append! seen v)))
|
||||
(dl-vars-of (get g :neg))))
|
||||
((dl-aggregate? g)
|
||||
;; Only the result var (first arg of the aggregate
|
||||
;; literal) is user-facing. The aggregated var and
|
||||
;; any vars in the inner goal are internal.
|
||||
(let ((r (nth g 1)))
|
||||
(when
|
||||
(dl-var? r)
|
||||
(let ((rn (symbol->string r)))
|
||||
(when
|
||||
(and (not (= rn "_"))
|
||||
(not (dl-member-string? rn seen)))
|
||||
(append! seen rn))))))
|
||||
(else
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(and (not (= v "_")) (not (dl-member-string? v seen)))
|
||||
(append! seen v)))
|
||||
(dl-vars-of g)))))
|
||||
goals)
|
||||
seen))))
|
||||
|
||||
(define
|
||||
dl-project-subst
|
||||
(fn
|
||||
(subst names)
|
||||
(let
|
||||
((out {}))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(n)
|
||||
(let
|
||||
((sym (string->symbol n)))
|
||||
(let
|
||||
((v (dl-walk sym subst)))
|
||||
(dict-set! out n (dl-apply-subst v subst)))))
|
||||
names)
|
||||
out))))
|
||||
|
||||
(define dl-relation (fn (db name) (dl-rel-tuples db name)))
|
||||
@@ -1,464 +0,0 @@
|
||||
;; lib/datalog/magic.sx — adornment analysis + sideways info passing.
|
||||
;;
|
||||
;; First step of the magic-sets transformation (Phase 6). Right now
|
||||
;; the saturator does not consume these — they are introspection
|
||||
;; helpers that future magic-set rewriting will build on top of.
|
||||
;;
|
||||
;; Definitions:
|
||||
;; - An *adornment* of an n-ary literal is an n-character string
|
||||
;; of "b" (bound — value already known at the call site) and
|
||||
;; "f" (free — to be derived).
|
||||
;; - SIPS (Sideways Information Passing Strategy) walks the body
|
||||
;; of an adorned rule left-to-right tracking which variables
|
||||
;; have been bound so far, computing each body literal's
|
||||
;; adornment in turn.
|
||||
;;
|
||||
;; Usage:
|
||||
;;
|
||||
;; (dl-adorn-goal '(ancestor tom X))
|
||||
;; => "bf"
|
||||
;;
|
||||
;; (dl-rule-sips
|
||||
;; {:head (ancestor X Z)
|
||||
;; :body ((parent X Y) (ancestor Y Z))}
|
||||
;; "bf")
|
||||
;; => ({:lit (parent X Y) :adornment "bf"}
|
||||
;; {:lit (ancestor Y Z) :adornment "bf"})
|
||||
|
||||
;; Per-arg adornment under the current bound-var name set.
|
||||
(define
|
||||
dl-adorn-arg
|
||||
(fn
|
||||
(arg bound)
|
||||
(cond
|
||||
((dl-var? arg)
|
||||
(if (dl-member-string? (symbol->string arg) bound) "b" "f"))
|
||||
(else "b"))))
|
||||
|
||||
;; Adornment for the args of a literal (after the relation name).
|
||||
(define
|
||||
dl-adorn-args
|
||||
(fn
|
||||
(args bound)
|
||||
(cond
|
||||
((= (len args) 0) "")
|
||||
(else
|
||||
(str
|
||||
(dl-adorn-arg (first args) bound)
|
||||
(dl-adorn-args (rest args) bound))))))
|
||||
|
||||
;; Adornment of a top-level goal under the empty bound-var set.
|
||||
(define
|
||||
dl-adorn-goal
|
||||
(fn (goal) (dl-adorn-args (rest goal) (list))))
|
||||
|
||||
;; Adornment of a literal under an explicit bound set.
|
||||
(define
|
||||
dl-adorn-lit
|
||||
(fn (lit bound) (dl-adorn-args (rest lit) bound)))
|
||||
|
||||
;; The set of variable names made bound by walking a positive
|
||||
;; literal whose adornment is known. Free positions add their
|
||||
;; vars to the bound set.
|
||||
(define
|
||||
dl-vars-bound-by-lit
|
||||
(fn
|
||||
(lit bound)
|
||||
(let ((args (rest lit)) (out (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn (a)
|
||||
(when
|
||||
(and (dl-var? a)
|
||||
(not (dl-member-string? (symbol->string a) bound))
|
||||
(not (dl-member-string? (symbol->string a) out)))
|
||||
(append! out (symbol->string a))))
|
||||
args)
|
||||
out))))
|
||||
|
||||
;; Walk the rule body left-to-right tracking bound vars seeded by the
|
||||
;; head adornment. Returns a list of {:lit :adornment} entries.
|
||||
;;
|
||||
;; Negation, comparison, and built-ins are passed through with their
|
||||
;; adornment computed from the current bound set; they don't add new
|
||||
;; bindings (except `is`, which binds its left arg if a var). Aggregates
|
||||
;; are treated like is — the result var becomes bound.
|
||||
(define
|
||||
dl-init-head-bound
|
||||
(fn
|
||||
(head adornment)
|
||||
(let ((args (rest head)) (out (list)))
|
||||
(do
|
||||
(define
|
||||
dl-ihb-loop
|
||||
(fn
|
||||
(i)
|
||||
(when
|
||||
(< i (len args))
|
||||
(do
|
||||
(let
|
||||
((c (slice adornment i (+ i 1)))
|
||||
(a (nth args i)))
|
||||
(when
|
||||
(and (= c "b") (dl-var? a))
|
||||
(let ((n (symbol->string a)))
|
||||
(when
|
||||
(not (dl-member-string? n out))
|
||||
(append! out n)))))
|
||||
(dl-ihb-loop (+ i 1))))))
|
||||
(dl-ihb-loop 0)
|
||||
out))))
|
||||
|
||||
(define
|
||||
dl-rule-sips
|
||||
(fn
|
||||
(rule head-adornment)
|
||||
(let
|
||||
((bound (dl-init-head-bound (get rule :head) head-adornment))
|
||||
(out (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(let ((target (get lit :neg)))
|
||||
(append!
|
||||
out
|
||||
{:lit lit :adornment (dl-adorn-lit target bound)})))
|
||||
((dl-builtin? lit)
|
||||
(let ((adn (dl-adorn-lit lit bound)))
|
||||
(do
|
||||
(append! out {:lit lit :adornment adn})
|
||||
;; `is` binds its left arg (if var) once RHS is ground.
|
||||
(when
|
||||
(and (= (dl-rel-name lit) "is") (dl-var? (nth lit 1)))
|
||||
(let ((n (symbol->string (nth lit 1))))
|
||||
(when
|
||||
(not (dl-member-string? n bound))
|
||||
(append! bound n)))))))
|
||||
((and (list? lit) (dl-aggregate? lit))
|
||||
(let ((adn (dl-adorn-lit lit bound)))
|
||||
(do
|
||||
(append! out {:lit lit :adornment adn})
|
||||
;; Result var (first arg) becomes bound.
|
||||
(when (dl-var? (nth lit 1))
|
||||
(let ((n (symbol->string (nth lit 1))))
|
||||
(when
|
||||
(not (dl-member-string? n bound))
|
||||
(append! bound n)))))))
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(let ((adn (dl-adorn-lit lit bound)))
|
||||
(do
|
||||
(append! out {:lit lit :adornment adn})
|
||||
(for-each
|
||||
(fn (n)
|
||||
(when (not (dl-member-string? n bound))
|
||||
(append! bound n)))
|
||||
(dl-vars-bound-by-lit lit bound)))))))
|
||||
(get rule :body))
|
||||
out))))
|
||||
|
||||
;; ── Magic predicate naming + bound-args extraction ─────────────
|
||||
;; These are building blocks for the magic-sets *transformation*
|
||||
;; itself. The transformation (which generates rewritten rules
|
||||
;; with magic_<rel>^<adornment> filters) is future work — for now
|
||||
;; these helpers can be used to inspect what such a transformation
|
||||
;; would produce.
|
||||
|
||||
;; "magic_p^bf" given relation "p" and adornment "bf".
|
||||
(define
|
||||
dl-magic-rel-name
|
||||
(fn (rel adornment) (str "magic_" rel "^" adornment)))
|
||||
|
||||
;; A magic predicate literal:
|
||||
;; (magic_<rel>^<adornment> arg1 arg2 ...)
|
||||
(define
|
||||
dl-magic-lit
|
||||
(fn
|
||||
(rel adornment bound-args)
|
||||
(cons (string->symbol (dl-magic-rel-name rel adornment)) bound-args)))
|
||||
|
||||
;; Extract bound args (those at "b" positions in `adornment`) from a
|
||||
;; literal `(rel arg1 arg2 ... argN)`. Returns the list of arg values.
|
||||
(define
|
||||
dl-bound-args
|
||||
(fn
|
||||
(lit adornment)
|
||||
(let ((args (rest lit)) (out (list)))
|
||||
(do
|
||||
(define
|
||||
dl-ba-loop
|
||||
(fn
|
||||
(i)
|
||||
(when
|
||||
(< i (len args))
|
||||
(do
|
||||
(when
|
||||
(= (slice adornment i (+ i 1)) "b")
|
||||
(append! out (nth args i)))
|
||||
(dl-ba-loop (+ i 1))))))
|
||||
(dl-ba-loop 0)
|
||||
out))))
|
||||
|
||||
;; ── Magic-sets rewriter ─────────────────────────────────────────
|
||||
;;
|
||||
;; Given the original rule list and a query (rel, adornment) pair,
|
||||
;; generates the magic-rewritten program: a list of rules that
|
||||
;; (a) gate each original rule with a `magic_<rel>^<adn>` filter and
|
||||
;; (b) propagate the magic relation through SIPS so that only
|
||||
;; query-relevant tuples are derived. Seed facts are returned
|
||||
;; separately and must be added to the db at evaluation time.
|
||||
;;
|
||||
;; Output: {:rules <rewritten-rules> :seed <magic-seed-literal>}
|
||||
;;
|
||||
;; The rewriter only rewrites IDB rules; EDB facts pass through.
|
||||
;; Built-in predicates and negation in body literals are kept in
|
||||
;; place but do not generate propagation rules of their own.
|
||||
|
||||
(define
|
||||
dl-magic-pair-key
|
||||
(fn (rel adornment) (str rel "^" adornment)))
|
||||
|
||||
(define
|
||||
dl-magic-rewrite
|
||||
(fn
|
||||
(rules query-rel query-adornment query-args)
|
||||
(let
|
||||
((seen (list))
|
||||
(queue (list))
|
||||
(out (list)))
|
||||
(do
|
||||
(define
|
||||
dl-mq-mark!
|
||||
(fn
|
||||
(rel adornment)
|
||||
(let ((k (dl-magic-pair-key rel adornment)))
|
||||
(when
|
||||
(not (dl-member-string? k seen))
|
||||
(do
|
||||
(append! seen k)
|
||||
(append! queue {:rel rel :adn adornment}))))))
|
||||
|
||||
(define
|
||||
dl-mq-rewrite-rule!
|
||||
(fn
|
||||
(rule adn)
|
||||
(let
|
||||
((head (get rule :head))
|
||||
(body (get rule :body))
|
||||
(sips (dl-rule-sips rule adn)))
|
||||
(let
|
||||
((magic-filter
|
||||
(dl-magic-lit
|
||||
(dl-rel-name head)
|
||||
adn
|
||||
(dl-bound-args head adn))))
|
||||
(do
|
||||
;; Adorned rule: head :- magic-filter, body...
|
||||
(let ((new-body (list)))
|
||||
(do
|
||||
(append! new-body magic-filter)
|
||||
(for-each
|
||||
(fn (lit) (append! new-body lit))
|
||||
body)
|
||||
(append! out {:head head :body new-body})))
|
||||
;; Propagation rules for each positive non-builtin
|
||||
;; body literal at position i.
|
||||
(define
|
||||
dl-mq-prop-loop
|
||||
(fn
|
||||
(i)
|
||||
(when
|
||||
(< i (len body))
|
||||
(do
|
||||
(let
|
||||
((lit (nth body i))
|
||||
(sip-entry (nth sips i)))
|
||||
(when
|
||||
(and (list? lit)
|
||||
(> (len lit) 0)
|
||||
(not (and (dict? lit) (has-key? lit :neg)))
|
||||
(not (dl-builtin? lit))
|
||||
(not (dl-aggregate? lit)))
|
||||
(let
|
||||
((lit-adn (get sip-entry :adornment))
|
||||
(lit-rel (dl-rel-name lit)))
|
||||
(let
|
||||
((prop-head
|
||||
(dl-magic-lit
|
||||
lit-rel
|
||||
lit-adn
|
||||
(dl-bound-args lit lit-adn))))
|
||||
(let ((prop-body (list)))
|
||||
(do
|
||||
(append! prop-body magic-filter)
|
||||
(define
|
||||
dl-mq-prefix-loop
|
||||
(fn
|
||||
(j)
|
||||
(when
|
||||
(< j i)
|
||||
(do
|
||||
(append!
|
||||
prop-body
|
||||
(nth body j))
|
||||
(dl-mq-prefix-loop (+ j 1))))))
|
||||
(dl-mq-prefix-loop 0)
|
||||
(append!
|
||||
out
|
||||
{:head prop-head :body prop-body})
|
||||
(dl-mq-mark! lit-rel lit-adn)))))))
|
||||
(dl-mq-prop-loop (+ i 1))))))
|
||||
(dl-mq-prop-loop 0))))))
|
||||
|
||||
(dl-mq-mark! query-rel query-adornment)
|
||||
|
||||
(let ((idx 0))
|
||||
(define
|
||||
dl-mq-process
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< idx (len queue))
|
||||
(let ((item (nth queue idx)))
|
||||
(do
|
||||
(set! idx (+ idx 1))
|
||||
(let
|
||||
((rel (get item :rel)) (adn (get item :adn)))
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(when
|
||||
(= (dl-rel-name (get rule :head)) rel)
|
||||
(dl-mq-rewrite-rule! rule adn)))
|
||||
rules))
|
||||
(dl-mq-process))))))
|
||||
(dl-mq-process))
|
||||
|
||||
{:rules out
|
||||
:seed
|
||||
(dl-magic-lit
|
||||
query-rel
|
||||
query-adornment
|
||||
query-args)}))))
|
||||
|
||||
;; ── Top-level magic-sets driver ─────────────────────────────────
|
||||
;;
|
||||
;; (dl-magic-query db query-goal) — run `query-goal` under magic-sets
|
||||
;; evaluation. Builds a fresh internal db with:
|
||||
;; - the caller's EDB facts (relations not headed by any rule),
|
||||
;; - the magic seed fact, and
|
||||
;; - the rewritten rules.
|
||||
;; Saturates and queries, returning the substitution list. The
|
||||
;; caller's db is untouched.
|
||||
;;
|
||||
;; Useful primarily as a perf alternative for queries that only
|
||||
;; need a small slice of a recursive relation. Equivalent to
|
||||
;; dl-query for any single fully-stratifiable program.
|
||||
|
||||
(define
|
||||
dl-magic-rule-heads
|
||||
(fn
|
||||
(rules)
|
||||
(let ((seen (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(r)
|
||||
(let ((h (dl-rel-name (get r :head))))
|
||||
(when
|
||||
(and (not (nil? h)) (not (dl-member-string? h seen)))
|
||||
(append! seen h))))
|
||||
rules)
|
||||
seen))))
|
||||
|
||||
;; True iff any rule's body contains a literal kind that the magic
|
||||
;; rewriter doesn't propagate magic to — i.e. an aggregate or a
|
||||
;; negation. Used by dl-magic-query to decide whether to pre-saturate
|
||||
;; the source db (for correctness on stratified programs) or skip
|
||||
;; that step (preserving full magic-sets efficiency for pure
|
||||
;; positive programs).
|
||||
(define
|
||||
dl-rule-has-nonprop-lit?
|
||||
(fn
|
||||
(body i n)
|
||||
(cond
|
||||
((>= i n) false)
|
||||
((let ((lit (nth body i)))
|
||||
(or (and (dict? lit) (has-key? lit :neg))
|
||||
(dl-aggregate? lit)))
|
||||
true)
|
||||
(else (dl-rule-has-nonprop-lit? body (+ i 1) n)))))
|
||||
|
||||
(define
|
||||
dl-rules-need-presaturation?
|
||||
(fn
|
||||
(rules)
|
||||
(cond
|
||||
((= (len rules) 0) false)
|
||||
((let ((body (get (first rules) :body)))
|
||||
(dl-rule-has-nonprop-lit? body 0 (len body)))
|
||||
true)
|
||||
(else (dl-rules-need-presaturation? (rest rules))))))
|
||||
|
||||
(define
|
||||
dl-magic-query
|
||||
(fn
|
||||
(db query-goal)
|
||||
;; Magic-sets only applies to positive non-builtin / non-aggregate
|
||||
;; literals against rule-defined relations. For other goal shapes
|
||||
;; (built-ins, aggregates, EDB-only relations) the seed is either
|
||||
;; non-ground or unused; fall back to dl-query.
|
||||
(cond
|
||||
((not (and (list? query-goal)
|
||||
(> (len query-goal) 0)
|
||||
(symbol? (first query-goal))))
|
||||
(error (str "dl-magic-query: goal must be a positive literal "
|
||||
"(non-empty list with a symbol head), got " query-goal)))
|
||||
((or (dl-builtin? query-goal)
|
||||
(dl-aggregate? query-goal)
|
||||
(and (dict? query-goal) (has-key? query-goal :neg)))
|
||||
(dl-query db query-goal))
|
||||
(else
|
||||
(do
|
||||
;; If the rule set has aggregates or negation, pre-saturate
|
||||
;; the source db before copying facts. The magic rewriter
|
||||
;; passes aggregate body lits and negated lits through
|
||||
;; unchanged (no magic propagation generated for them) — so
|
||||
;; if their inner-goal relation is IDB, it would be empty in
|
||||
;; the magic db. Pre-saturating ensures equivalence with
|
||||
;; `dl-query` for every stratified program. Pure positive
|
||||
;; programs skip this and keep the full magic-sets perf win
|
||||
;; from goal-directed re-derivation.
|
||||
(when
|
||||
(dl-rules-need-presaturation? (dl-rules db))
|
||||
(dl-saturate! db))
|
||||
(let
|
||||
((query-rel (dl-rel-name query-goal))
|
||||
(query-adn (dl-adorn-goal query-goal)))
|
||||
(let
|
||||
((query-args (dl-bound-args query-goal query-adn))
|
||||
(rules (dl-rules db)))
|
||||
(let
|
||||
((rewritten (dl-magic-rewrite rules query-rel query-adn query-args))
|
||||
(mdb (dl-make-db))
|
||||
(rule-heads (dl-magic-rule-heads rules)))
|
||||
(do
|
||||
;; Copy ALL existing facts. EDB-only relations bring their
|
||||
;; tuples; mixed EDB+IDB relations bring both their EDB
|
||||
;; portion and any pre-saturated IDB tuples (which the
|
||||
;; rewritten rules would re-derive anyway). Skipping facts
|
||||
;; for rule-headed relations would leave the magic run
|
||||
;; without the EDB portion of mixed relations.
|
||||
(for-each
|
||||
(fn
|
||||
(rel)
|
||||
(for-each
|
||||
(fn (t) (dl-add-fact! mdb t))
|
||||
(dl-rel-tuples db rel)))
|
||||
(keys (get db :facts)))
|
||||
;; Seed + rewritten rules.
|
||||
(dl-add-fact! mdb (get rewritten :seed))
|
||||
(for-each (fn (r) (dl-add-rule! mdb r)) (get rewritten :rules))
|
||||
(dl-query mdb query-goal))))))))))
|
||||
@@ -1,252 +0,0 @@
|
||||
;; lib/datalog/parser.sx — Datalog tokens → AST
|
||||
;;
|
||||
;; Output shapes:
|
||||
;; Literal (positive) := (relname arg ... arg) — SX list
|
||||
;; Literal (negative) := {:neg (relname arg ... arg)} — dict
|
||||
;; Argument := var-symbol | atom-symbol | number | string
|
||||
;; | (op-name arg ... arg) — arithmetic compound
|
||||
;; Fact := {:head literal :body ()}
|
||||
;; Rule := {:head literal :body (lit ... lit)}
|
||||
;; Query := {:query (lit ... lit)}
|
||||
;; Program := list of facts / rules / queries
|
||||
;;
|
||||
;; Variables and constants are both SX symbols; the evaluator dispatches
|
||||
;; on first-char case ('A'..'Z' or '_' = variable, otherwise constant).
|
||||
;;
|
||||
;; The parser permits nested compounds in arg position to support
|
||||
;; arithmetic (e.g. (is Z (+ X Y))). Safety analysis at rule-load time
|
||||
;; rejects compounds whose head is not an arithmetic operator.
|
||||
|
||||
(define
|
||||
dl-pp-peek
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((i (get st :idx)) (tokens (get st :tokens)))
|
||||
(if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
|
||||
|
||||
(define
|
||||
dl-pp-peek2
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((i (+ (get st :idx) 1)) (tokens (get st :tokens)))
|
||||
(if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
|
||||
|
||||
(define
|
||||
dl-pp-advance!
|
||||
(fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
|
||||
|
||||
(define
|
||||
dl-pp-at?
|
||||
(fn
|
||||
(st type value)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(and
|
||||
(= (get t :type) type)
|
||||
(or (= value nil) (= (get t :value) value))))))
|
||||
|
||||
(define
|
||||
dl-pp-error
|
||||
(fn
|
||||
(st msg)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(error
|
||||
(str
|
||||
"Parse error at pos "
|
||||
(get t :pos)
|
||||
": "
|
||||
msg
|
||||
" (got "
|
||||
(get t :type)
|
||||
" '"
|
||||
(if (= (get t :value) nil) "" (get t :value))
|
||||
"')")))))
|
||||
|
||||
(define
|
||||
dl-pp-expect!
|
||||
(fn
|
||||
(st type value)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(if
|
||||
(dl-pp-at? st type value)
|
||||
(do (dl-pp-advance! st) t)
|
||||
(dl-pp-error
|
||||
st
|
||||
(str "expected " type (if (= value nil) "" (str " '" value "'"))))))))
|
||||
|
||||
;; Argument: variable, atom, number, string, or compound (relname/op + parens).
|
||||
(define
|
||||
dl-pp-parse-arg
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(let
|
||||
((ty (get t :type)) (vv (get t :value)))
|
||||
(cond
|
||||
((= ty "number") (do (dl-pp-advance! st) vv))
|
||||
((= ty "string") (do (dl-pp-advance! st) vv))
|
||||
((= ty "var") (do (dl-pp-advance! st) (string->symbol vv)))
|
||||
;; Negative numeric literal: `-` op directly followed by a
|
||||
;; number (no `(`) is parsed as a single negative number.
|
||||
;; This keeps `(-X Y)` (compound) and `-N` (literal) distinct.
|
||||
((and (= ty "op") (= vv "-")
|
||||
(= (get (dl-pp-peek2 st) :type) "number"))
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((n (get (dl-pp-peek st) :value)))
|
||||
(do (dl-pp-advance! st) (- 0 n)))))
|
||||
((or (= ty "atom") (= ty "op"))
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(if
|
||||
(dl-pp-at? st "punct" "(")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((args (dl-pp-parse-arg-list st)))
|
||||
(do
|
||||
(dl-pp-expect! st "punct" ")")
|
||||
(cons (string->symbol vv) args))))
|
||||
(string->symbol vv))))
|
||||
(else (dl-pp-error st "expected term")))))))
|
||||
|
||||
;; Comma-separated args inside parens.
|
||||
(define
|
||||
dl-pp-parse-arg-list
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((args (list)))
|
||||
(do
|
||||
(append! args (dl-pp-parse-arg st))
|
||||
(define
|
||||
dl-pp-arg-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(dl-pp-at? st "punct" ",")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(append! args (dl-pp-parse-arg st))
|
||||
(dl-pp-arg-loop)))))
|
||||
(dl-pp-arg-loop)
|
||||
args))))
|
||||
|
||||
;; A positive literal: relname (atom or op) followed by optional (args).
|
||||
(define
|
||||
dl-pp-parse-positive
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(let
|
||||
((ty (get t :type)) (vv (get t :value)))
|
||||
(if
|
||||
(or (= ty "atom") (= ty "op"))
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(if
|
||||
(dl-pp-at? st "punct" "(")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((args (dl-pp-parse-arg-list st)))
|
||||
(do
|
||||
(dl-pp-expect! st "punct" ")")
|
||||
(cons (string->symbol vv) args))))
|
||||
(list (string->symbol vv))))
|
||||
(dl-pp-error st "expected literal head"))))))
|
||||
|
||||
;; A body literal: positive, or not(positive).
|
||||
(define
|
||||
dl-pp-parse-body-lit
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((t1 (dl-pp-peek st)) (t2 (dl-pp-peek2 st)))
|
||||
(if
|
||||
(and
|
||||
(= (get t1 :type) "atom")
|
||||
(= (get t1 :value) "not")
|
||||
(= (get t2 :type) "punct")
|
||||
(= (get t2 :value) "("))
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((inner (dl-pp-parse-positive st)))
|
||||
(do (dl-pp-expect! st "punct" ")") {:neg inner})))
|
||||
(dl-pp-parse-positive st)))))
|
||||
|
||||
;; Comma-separated body literals.
|
||||
(define
|
||||
dl-pp-parse-body
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((lits (list)))
|
||||
(do
|
||||
(append! lits (dl-pp-parse-body-lit st))
|
||||
(define
|
||||
dl-pp-body-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(dl-pp-at? st "punct" ",")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(append! lits (dl-pp-parse-body-lit st))
|
||||
(dl-pp-body-loop)))))
|
||||
(dl-pp-body-loop)
|
||||
lits))))
|
||||
|
||||
;; Single clause: fact, rule, or query. Consumes trailing dot.
|
||||
(define
|
||||
dl-pp-parse-clause
|
||||
(fn
|
||||
(st)
|
||||
(cond
|
||||
((dl-pp-at? st "op" "?-")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((body (dl-pp-parse-body st)))
|
||||
(do (dl-pp-expect! st "punct" ".") {:query body}))))
|
||||
(else
|
||||
(let
|
||||
((head (dl-pp-parse-positive st)))
|
||||
(cond
|
||||
((dl-pp-at? st "op" ":-")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((body (dl-pp-parse-body st)))
|
||||
(do (dl-pp-expect! st "punct" ".") {:body body :head head}))))
|
||||
(else (do (dl-pp-expect! st "punct" ".") {:body (list) :head head}))))))))
|
||||
|
||||
(define
|
||||
dl-parse-program
|
||||
(fn
|
||||
(tokens)
|
||||
(let
|
||||
((st {:tokens tokens :idx 0}) (clauses (list)))
|
||||
(do
|
||||
(define
|
||||
dl-pp-prog-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(not (dl-pp-at? st "eof" nil))
|
||||
(do
|
||||
(append! clauses (dl-pp-parse-clause st))
|
||||
(dl-pp-prog-loop)))))
|
||||
(dl-pp-prog-loop)
|
||||
clauses))))
|
||||
|
||||
(define dl-parse (fn (src) (dl-parse-program (dl-tokenize src))))
|
||||
@@ -1,20 +0,0 @@
|
||||
{
|
||||
"lang": "datalog",
|
||||
"total_passed": 276,
|
||||
"total_failed": 0,
|
||||
"total": 276,
|
||||
"suites": [
|
||||
{"name":"tokenize","passed":31,"failed":0,"total":31},
|
||||
{"name":"parse","passed":23,"failed":0,"total":23},
|
||||
{"name":"unify","passed":29,"failed":0,"total":29},
|
||||
{"name":"eval","passed":44,"failed":0,"total":44},
|
||||
{"name":"builtins","passed":26,"failed":0,"total":26},
|
||||
{"name":"semi_naive","passed":8,"failed":0,"total":8},
|
||||
{"name":"negation","passed":12,"failed":0,"total":12},
|
||||
{"name":"aggregates","passed":23,"failed":0,"total":23},
|
||||
{"name":"api","passed":22,"failed":0,"total":22},
|
||||
{"name":"magic","passed":37,"failed":0,"total":37},
|
||||
{"name":"demo","passed":21,"failed":0,"total":21}
|
||||
],
|
||||
"generated": "2026-05-14T20:30:05+00:00"
|
||||
}
|
||||
@@ -1,17 +0,0 @@
|
||||
# datalog scoreboard
|
||||
|
||||
**276 / 276 passing** (0 failure(s)).
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
| tokenize | 31 | 31 | ok |
|
||||
| parse | 23 | 23 | ok |
|
||||
| unify | 29 | 29 | ok |
|
||||
| eval | 44 | 44 | ok |
|
||||
| builtins | 26 | 26 | ok |
|
||||
| semi_naive | 8 | 8 | ok |
|
||||
| negation | 12 | 12 | ok |
|
||||
| aggregates | 23 | 23 | ok |
|
||||
| api | 22 | 22 | ok |
|
||||
| magic | 37 | 37 | ok |
|
||||
| demo | 21 | 21 | ok |
|
||||
@@ -1,323 +0,0 @@
|
||||
;; lib/datalog/strata.sx — dependency graph, SCC analysis, stratum assignment.
|
||||
;;
|
||||
;; A program is stratifiable iff no cycle in its dependency graph passes
|
||||
;; through a negative edge. The stratum of relation R is the depth at which
|
||||
;; R can first be evaluated:
|
||||
;;
|
||||
;; stratum(R) = max over edges (R → S) of:
|
||||
;; stratum(S) if the edge is positive
|
||||
;; stratum(S) + 1 if the edge is negative
|
||||
;;
|
||||
;; All relations in the same SCC share a stratum (and the SCC must have only
|
||||
;; positive internal edges, else the program is non-stratifiable).
|
||||
|
||||
;; Build dep graph: dict {head-rel-name -> ({:rel str :neg bool} ...)}.
|
||||
(define
|
||||
dl-build-dep-graph
|
||||
(fn
|
||||
(db)
|
||||
(let ((g {}))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(let
|
||||
((head-rel (dl-rel-name (get rule :head))))
|
||||
(when
|
||||
(not (nil? head-rel))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? g head-rel))
|
||||
(dict-set! g head-rel (list)))
|
||||
(let ((existing (get g head-rel)))
|
||||
(for-each
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((dl-aggregate? lit)
|
||||
(let
|
||||
((edge (dl-aggregate-dep-edge lit)))
|
||||
(when
|
||||
(not (nil? edge))
|
||||
(append! existing edge))))
|
||||
(else
|
||||
(let
|
||||
((target
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(dl-rel-name (get lit :neg)))
|
||||
((dl-builtin? lit) nil)
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(dl-rel-name lit))
|
||||
(else nil)))
|
||||
(neg?
|
||||
(and (dict? lit) (has-key? lit :neg))))
|
||||
(when
|
||||
(not (nil? target))
|
||||
(append!
|
||||
existing
|
||||
{:rel target :neg neg?}))))))
|
||||
(get rule :body)))))))
|
||||
(dl-rules db))
|
||||
g))))
|
||||
|
||||
;; All relations referenced — heads of rules + EDB names + body relations.
|
||||
(define
|
||||
dl-all-relations
|
||||
(fn
|
||||
(db)
|
||||
(let ((seen (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(when (not (dl-member-string? k seen)) (append! seen k)))
|
||||
(keys (get db :facts)))
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(do
|
||||
(let ((h (dl-rel-name (get rule :head))))
|
||||
(when
|
||||
(and (not (nil? h)) (not (dl-member-string? h seen)))
|
||||
(append! seen h)))
|
||||
(for-each
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((t
|
||||
(cond
|
||||
((dl-aggregate? lit)
|
||||
(let ((edge (dl-aggregate-dep-edge lit)))
|
||||
(if (nil? edge) nil (get edge :rel))))
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(dl-rel-name (get lit :neg)))
|
||||
((dl-builtin? lit) nil)
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(dl-rel-name lit))
|
||||
(else nil))))
|
||||
(when
|
||||
(and (not (nil? t)) (not (dl-member-string? t seen)))
|
||||
(append! seen t))))
|
||||
(get rule :body))))
|
||||
(dl-rules db))
|
||||
seen))))
|
||||
|
||||
;; reach: dict {from: dict {to: edge-info}} where edge-info is
|
||||
;; {:any bool :neg bool}
|
||||
;; meaning "any path from `from` to `to`" and "exists a negative-passing
|
||||
;; path from `from` to `to`".
|
||||
;;
|
||||
;; Floyd-Warshall over the dep graph. The 'neg' flag propagates through
|
||||
;; concatenation: if any edge along the path is negative, the path's
|
||||
;; flag is true.
|
||||
(define
|
||||
dl-build-reach
|
||||
(fn
|
||||
(graph nodes)
|
||||
(let ((reach {}))
|
||||
(do
|
||||
(for-each
|
||||
(fn (n) (dict-set! reach n {}))
|
||||
nodes)
|
||||
(for-each
|
||||
(fn
|
||||
(head)
|
||||
(when
|
||||
(has-key? graph head)
|
||||
(for-each
|
||||
(fn
|
||||
(edge)
|
||||
(let
|
||||
((target (get edge :rel)) (n (get edge :neg)))
|
||||
(let ((row (get reach head)))
|
||||
(cond
|
||||
((has-key? row target)
|
||||
(let ((cur (get row target)))
|
||||
(dict-set!
|
||||
row
|
||||
target
|
||||
{:any true :neg (or n (get cur :neg))})))
|
||||
(else
|
||||
(dict-set! row target {:any true :neg n}))))))
|
||||
(get graph head))))
|
||||
nodes)
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(for-each
|
||||
(fn
|
||||
(i)
|
||||
(let ((row-i (get reach i)))
|
||||
(when
|
||||
(has-key? row-i k)
|
||||
(let ((ik (get row-i k)) (row-k (get reach k)))
|
||||
(for-each
|
||||
(fn
|
||||
(j)
|
||||
(when
|
||||
(has-key? row-k j)
|
||||
(let ((kj (get row-k j)))
|
||||
(let
|
||||
((combined-neg (or (get ik :neg) (get kj :neg))))
|
||||
(cond
|
||||
((has-key? row-i j)
|
||||
(let ((cur (get row-i j)))
|
||||
(dict-set!
|
||||
row-i
|
||||
j
|
||||
{:any true
|
||||
:neg (or combined-neg (get cur :neg))})))
|
||||
(else
|
||||
(dict-set!
|
||||
row-i
|
||||
j
|
||||
{:any true :neg combined-neg})))))))
|
||||
nodes)))))
|
||||
nodes))
|
||||
nodes)
|
||||
reach))))
|
||||
|
||||
;; Returns nil on success, or error message string on failure.
|
||||
(define
|
||||
dl-check-stratifiable
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((graph (dl-build-dep-graph db))
|
||||
(nodes (dl-all-relations db)))
|
||||
(let ((reach (dl-build-reach graph nodes)) (err nil))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(when
|
||||
(nil? err)
|
||||
(let ((head-rel (dl-rel-name (get rule :head))))
|
||||
(for-each
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(let ((tgt (dl-rel-name (get lit :neg))))
|
||||
(when
|
||||
(and (not (nil? tgt))
|
||||
(dl-reach-cycle? reach head-rel tgt))
|
||||
(set!
|
||||
err
|
||||
(str "non-stratifiable: relation " head-rel
|
||||
" transitively depends through negation on "
|
||||
tgt
|
||||
" which depends back on " head-rel)))))
|
||||
((dl-aggregate? lit)
|
||||
(let ((edge (dl-aggregate-dep-edge lit)))
|
||||
(when
|
||||
(not (nil? edge))
|
||||
(let ((tgt (get edge :rel)))
|
||||
(when
|
||||
(and (not (nil? tgt))
|
||||
(dl-reach-cycle? reach head-rel tgt))
|
||||
(set!
|
||||
err
|
||||
(str "non-stratifiable: relation "
|
||||
head-rel
|
||||
" aggregates over " tgt
|
||||
" which depends back on "
|
||||
head-rel)))))))))
|
||||
(get rule :body)))))
|
||||
(dl-rules db))
|
||||
err)))))
|
||||
|
||||
(define
|
||||
dl-reach-cycle?
|
||||
(fn
|
||||
(reach a b)
|
||||
(and
|
||||
(dl-reach-row-has? reach b a)
|
||||
(dl-reach-row-has? reach a b))))
|
||||
|
||||
(define
|
||||
dl-reach-row-has?
|
||||
(fn
|
||||
(reach from to)
|
||||
(let ((row (get reach from)))
|
||||
(and (not (nil? row)) (has-key? row to)))))
|
||||
|
||||
;; Compute stratum per relation. Iteratively propagate from EDB roots.
|
||||
;; Uses the per-relation max-stratum-of-deps formula. Stops when stable.
|
||||
(define
|
||||
dl-compute-strata
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((graph (dl-build-dep-graph db))
|
||||
(nodes (dl-all-relations db))
|
||||
(strata {}))
|
||||
(do
|
||||
(for-each (fn (n) (dict-set! strata n 0)) nodes)
|
||||
(let ((changed true))
|
||||
(do
|
||||
(define
|
||||
dl-cs-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
changed
|
||||
(do
|
||||
(set! changed false)
|
||||
(for-each
|
||||
(fn
|
||||
(head)
|
||||
(when
|
||||
(has-key? graph head)
|
||||
(for-each
|
||||
(fn
|
||||
(edge)
|
||||
(let
|
||||
((tgt (get edge :rel))
|
||||
(n (get edge :neg)))
|
||||
(let
|
||||
((tgt-strat
|
||||
(if (has-key? strata tgt)
|
||||
(get strata tgt) 0))
|
||||
(cur (get strata head)))
|
||||
(let
|
||||
((needed
|
||||
(if n (+ tgt-strat 1) tgt-strat)))
|
||||
(when
|
||||
(> needed cur)
|
||||
(do
|
||||
(dict-set! strata head needed)
|
||||
(set! changed true)))))))
|
||||
(get graph head))))
|
||||
nodes)
|
||||
(dl-cs-loop)))))
|
||||
(dl-cs-loop)))
|
||||
strata))))
|
||||
|
||||
;; Group rules by their head's stratum. Returns dict {stratum-int -> rules}.
|
||||
(define
|
||||
dl-group-rules-by-stratum
|
||||
(fn
|
||||
(db strata)
|
||||
(let ((groups {}) (max-s 0))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(rule)
|
||||
(let
|
||||
((head-rel (dl-rel-name (get rule :head))))
|
||||
(let
|
||||
((s (if (has-key? strata head-rel)
|
||||
(get strata head-rel) 0)))
|
||||
(do
|
||||
(when (> s max-s) (set! max-s s))
|
||||
(let
|
||||
((sk (str s)))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? groups sk))
|
||||
(dict-set! groups sk (list)))
|
||||
(append! (get groups sk) rule)))))))
|
||||
(dl-rules db))
|
||||
{:groups groups :max max-s}))))
|
||||
@@ -1,357 +0,0 @@
|
||||
;; lib/datalog/tests/aggregates.sx — count / sum / min / max.
|
||||
|
||||
(define dl-at-pass 0)
|
||||
(define dl-at-fail 0)
|
||||
(define dl-at-failures (list))
|
||||
|
||||
(define
|
||||
dl-at-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-at-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let ((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-at-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-at-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-at-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-at-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-at-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i)))
|
||||
(not (dl-at-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-at-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-at-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and
|
||||
(= (len a) (len b))
|
||||
(dl-at-subset? a b)
|
||||
(dl-at-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-at-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-at-contains? ys (first xs))) false)
|
||||
(else (dl-at-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-at-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-at-deep=? (first xs) target) true)
|
||||
(else (dl-at-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-at-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-at-deep=? got expected)
|
||||
(set! dl-at-pass (+ dl-at-pass 1))
|
||||
(do
|
||||
(set! dl-at-fail (+ dl-at-fail 1))
|
||||
(append!
|
||||
dl-at-failures
|
||||
(str
|
||||
name
|
||||
"\n expected: " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-at-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-at-set=? got expected)
|
||||
(set! dl-at-pass (+ dl-at-pass 1))
|
||||
(do
|
||||
(set! dl-at-fail (+ dl-at-fail 1))
|
||||
(append!
|
||||
dl-at-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-at-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do
|
||||
(guard
|
||||
(e (#t (set! threw true)))
|
||||
(thunk))
|
||||
threw))))
|
||||
|
||||
(define
|
||||
dl-at-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
;; count
|
||||
(dl-at-test-set! "count siblings"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(p, bob). parent(p, alice). parent(p, charlie).
|
||||
sibling(X, Y) :- parent(P, X), parent(P, Y), !=(X, Y).
|
||||
sib_count(N) :- count(N, S, sibling(bob, S)).")
|
||||
(list (quote sib_count) (quote N)))
|
||||
(list {:N 2}))
|
||||
|
||||
;; sum
|
||||
(dl-at-test-set! "sum prices"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"price(apple, 5). price(pear, 7). price(plum, 3).
|
||||
total(T) :- sum(T, X, price(F, X)).")
|
||||
(list (quote total) (quote T)))
|
||||
(list {:T 15}))
|
||||
|
||||
;; min
|
||||
(dl-at-test-set! "min score"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"score(alice, 80). score(bob, 65). score(carol, 92).
|
||||
lo(M) :- min(M, S, score(P, S)).")
|
||||
(list (quote lo) (quote M)))
|
||||
(list {:M 65}))
|
||||
|
||||
;; max
|
||||
(dl-at-test-set! "max score"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"score(alice, 80). score(bob, 65). score(carol, 92).
|
||||
hi(M) :- max(M, S, score(P, S)).")
|
||||
(list (quote hi) (quote M)))
|
||||
(list {:M 92}))
|
||||
|
||||
;; count over derived relation (stratification needed).
|
||||
(dl-at-test-set! "count over derived"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(a, b). parent(a, c). parent(b, d). parent(c, e).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
|
||||
num_ancestors(N) :- count(N, X, ancestor(a, X)).")
|
||||
(list (quote num_ancestors) (quote N)))
|
||||
(list {:N 4}))
|
||||
|
||||
;; count with no matches → 0.
|
||||
(dl-at-test-set! "count empty"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(2).
|
||||
zero(N) :- count(N, X, q(X)).")
|
||||
(list (quote zero) (quote N)))
|
||||
(list {:N 0}))
|
||||
|
||||
;; sum with no matches → 0.
|
||||
(dl-at-test-set! "sum empty"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(2).
|
||||
total(T) :- sum(T, X, q(X)).")
|
||||
(list (quote total) (quote T)))
|
||||
(list {:T 0}))
|
||||
|
||||
;; min with no matches → rule does not fire.
|
||||
(dl-at-test-set! "min empty"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(2).
|
||||
lo(M) :- min(M, X, q(X)).")
|
||||
(list (quote lo) (quote M)))
|
||||
(list))
|
||||
|
||||
;; Aggregate with comparison filter on result.
|
||||
(dl-at-test-set! "popularity threshold"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"post(p1). post(p2).
|
||||
liked(u1, p1). liked(u2, p1). liked(u3, p1).
|
||||
liked(u1, p2). liked(u2, p2).
|
||||
popular(P) :- post(P), count(N, U, liked(U, P)), >=(N, 3).")
|
||||
(list (quote popular) (quote P)))
|
||||
(list {:P (quote p1)}))
|
||||
|
||||
;; findall: collect distinct values into a list.
|
||||
(dl-at-test-set! "findall over EDB"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(a). p(b). p(c).
|
||||
all_p(L) :- findall(L, X, p(X)).")
|
||||
(list (quote all_p) (quote L)))
|
||||
(list {:L (list (quote a) (quote b) (quote c))}))
|
||||
|
||||
(dl-at-test-set! "findall over derived"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(a, b). parent(b, c). parent(c, d).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
|
||||
desc(L) :- findall(L, X, ancestor(a, X)).")
|
||||
(list (quote desc) (quote L)))
|
||||
(list {:L (list (quote b) (quote c) (quote d))}))
|
||||
|
||||
(dl-at-test-set! "findall empty"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1).
|
||||
all_q(L) :- findall(L, X, q(X)).")
|
||||
(list (quote all_q) (quote L)))
|
||||
(list {:L (list)}))
|
||||
|
||||
;; Aggregate vs single distinct.
|
||||
;; Group-by via aggregate-in-rule-body. Per-user friend count
|
||||
;; over a friends relation. The U var is bound by the prior
|
||||
;; positive lit u(U) so the aggregate counts only U-rooted
|
||||
;; friends per group.
|
||||
(dl-at-test-set! "group-by per-user friend count"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"u(alice). u(bob). u(carol).
|
||||
f(alice, x). f(alice, y). f(bob, x).
|
||||
counts(U, N) :- u(U), count(N, X, f(U, X)).")
|
||||
(list (quote counts) (quote U) (quote N)))
|
||||
(list
|
||||
{:U (quote alice) :N 2}
|
||||
{:U (quote bob) :N 1}
|
||||
{:U (quote carol) :N 0}))
|
||||
|
||||
;; Stratification: recursion through aggregation is rejected.
|
||||
;; Aggregate validates that second arg is a variable.
|
||||
(dl-at-test! "agg second arg must be var"
|
||||
(dl-at-throws?
|
||||
(fn () (dl-eval "p(1). q(N) :- count(N, 5, p(X))." "?- q(N).")))
|
||||
true)
|
||||
|
||||
;; Aggregate validates that third arg is a positive literal.
|
||||
(dl-at-test! "agg third arg must be a literal"
|
||||
(dl-at-throws?
|
||||
(fn () (dl-eval "p(1). q(N) :- count(N, X, 42)." "?- q(N).")))
|
||||
true)
|
||||
|
||||
;; Aggregate validates that the agg-var (2nd arg) appears in the
|
||||
;; goal. Without it every match contributes the same unbound
|
||||
;; symbol — count silently returns 1, sum raises a confusing
|
||||
;; "expected number" error, etc. Catch the mistake at safety
|
||||
;; check time instead.
|
||||
(dl-at-test! "agg-var must appear in goal"
|
||||
(dl-at-throws?
|
||||
(fn ()
|
||||
(dl-eval
|
||||
"p(1). p(2). c(N) :- count(N, Y, p(X))."
|
||||
"?- c(N).")))
|
||||
true)
|
||||
|
||||
;; Indirect recursion through aggregation also rejected.
|
||||
;; q -> r (via positive lit), r -> q (via aggregate body).
|
||||
;; The aggregate edge counts as negation for stratification.
|
||||
(dl-at-test! "indirect agg cycle rejected"
|
||||
(dl-at-throws?
|
||||
(fn ()
|
||||
(let ((db (dl-make-db)))
|
||||
(do
|
||||
(dl-add-rule! db
|
||||
{:head (list (quote q) (quote N))
|
||||
:body (list (list (quote r) (quote N)))})
|
||||
(dl-add-rule! db
|
||||
{:head (list (quote r) (quote N))
|
||||
:body (list (list (quote count) (quote N) (quote X)
|
||||
(list (quote q) (quote X))))})
|
||||
(dl-saturate! db)))))
|
||||
true)
|
||||
|
||||
(dl-at-test! "agg recursion rejected"
|
||||
(dl-at-throws?
|
||||
(fn ()
|
||||
(let ((db (dl-make-db)))
|
||||
(do
|
||||
(dl-add-rule! db
|
||||
{:head (list (quote q) (quote N))
|
||||
:body (list (list (quote count) (quote N) (quote X)
|
||||
(list (quote q) (quote X))))})
|
||||
(dl-saturate! db)))))
|
||||
true)
|
||||
|
||||
;; Negation + aggregation in the same body — different strata.
|
||||
(dl-at-test-set! "neg + agg coexist"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"u(a). u(b). u(c). banned(b).
|
||||
active(X) :- u(X), not(banned(X)).
|
||||
cnt(N) :- count(N, X, active(X)).")
|
||||
(list (quote cnt) (quote N)))
|
||||
(list {:N 2}))
|
||||
|
||||
;; Min over a derived empty relation: no result.
|
||||
(dl-at-test-set! "min over empty derived"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"s(50). s(60).
|
||||
score(N) :- s(N), >(N, 100).
|
||||
low(M) :- min(M, X, score(X)).")
|
||||
(list (quote low) (quote M)))
|
||||
(list))
|
||||
|
||||
;; Aggregates as the top-level query goal (regression for
|
||||
;; dl-match-lit aggregate dispatch and projection cleanup).
|
||||
(dl-at-test-set! "count as query goal"
|
||||
(dl-query
|
||||
(dl-program "p(1). p(2). p(3). p(4).")
|
||||
(list (quote count) (quote N) (quote X) (list (quote p) (quote X))))
|
||||
(list {:N 4}))
|
||||
|
||||
(dl-at-test-set! "findall as query goal"
|
||||
(dl-query
|
||||
(dl-program "p(1). p(2). p(3).")
|
||||
(list (quote findall) (quote L) (quote X)
|
||||
(list (quote p) (quote X))))
|
||||
(list {:L (list 1 2 3)}))
|
||||
|
||||
(dl-at-test-set! "distinct counted once"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"rated(alice, x). rated(alice, y). rated(bob, x).
|
||||
rater_count(N) :- count(N, U, rated(U, F)).")
|
||||
(list (quote rater_count) (quote N)))
|
||||
(list {:N 2})))))
|
||||
|
||||
(define
|
||||
dl-aggregates-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-at-pass 0)
|
||||
(set! dl-at-fail 0)
|
||||
(set! dl-at-failures (list))
|
||||
(dl-at-run-all!)
|
||||
{:passed dl-at-pass
|
||||
:failed dl-at-fail
|
||||
:total (+ dl-at-pass dl-at-fail)
|
||||
:failures dl-at-failures})))
|
||||
@@ -1,350 +0,0 @@
|
||||
;; lib/datalog/tests/api.sx — SX-data embedding API.
|
||||
|
||||
(define dl-api-pass 0)
|
||||
(define dl-api-fail 0)
|
||||
(define dl-api-failures (list))
|
||||
|
||||
(define
|
||||
dl-api-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-api-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let ((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-api-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-api-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-api-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-api-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-api-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i)))
|
||||
(not (dl-api-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-api-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-api-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and
|
||||
(= (len a) (len b))
|
||||
(dl-api-subset? a b)
|
||||
(dl-api-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-api-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-api-contains? ys (first xs))) false)
|
||||
(else (dl-api-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-api-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-api-deep=? (first xs) target) true)
|
||||
(else (dl-api-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-api-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-api-deep=? got expected)
|
||||
(set! dl-api-pass (+ dl-api-pass 1))
|
||||
(do
|
||||
(set! dl-api-fail (+ dl-api-fail 1))
|
||||
(append!
|
||||
dl-api-failures
|
||||
(str
|
||||
name
|
||||
"\n expected: " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-api-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-api-set=? got expected)
|
||||
(set! dl-api-pass (+ dl-api-pass 1))
|
||||
(do
|
||||
(set! dl-api-fail (+ dl-api-fail 1))
|
||||
(append!
|
||||
dl-api-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-api-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
;; dl-program-data with arrow form.
|
||||
(dl-api-test-set! "data API ancestor closure"
|
||||
(dl-query
|
||||
(dl-program-data
|
||||
(quote ((parent tom bob) (parent bob ann) (parent ann pat)))
|
||||
(quote
|
||||
((ancestor X Y <- (parent X Y))
|
||||
(ancestor X Z <- (parent X Y) (ancestor Y Z)))))
|
||||
(quote (ancestor tom X)))
|
||||
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
||||
|
||||
;; dl-program-data with dict rules.
|
||||
(dl-api-test-set! "data API with dict rules"
|
||||
(dl-query
|
||||
(dl-program-data
|
||||
(quote ((p a) (p b) (p c)))
|
||||
(list
|
||||
{:head (quote (q X)) :body (quote ((p X)))}))
|
||||
(quote (q X)))
|
||||
(list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
;; dl-rule helper.
|
||||
(dl-api-test-set! "dl-rule constructor"
|
||||
(dl-query
|
||||
(dl-program-data
|
||||
(quote ((p 1) (p 2)))
|
||||
(list (dl-rule (quote (q X)) (quote ((p X))))))
|
||||
(quote (q X)))
|
||||
(list {:X 1} {:X 2}))
|
||||
|
||||
;; dl-assert! adds and re-derives.
|
||||
(dl-api-test-set! "dl-assert! incremental"
|
||||
(let
|
||||
((db (dl-program-data
|
||||
(quote ((parent tom bob) (parent bob ann)))
|
||||
(quote
|
||||
((ancestor X Y <- (parent X Y))
|
||||
(ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(dl-assert! db (quote (parent ann pat)))
|
||||
(dl-query db (quote (ancestor tom X)))))
|
||||
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
||||
|
||||
;; dl-retract! removes a fact and recomputes IDB.
|
||||
(dl-api-test-set! "dl-retract! removes derived"
|
||||
(let
|
||||
((db (dl-program-data
|
||||
(quote ((parent tom bob) (parent bob ann) (parent ann pat)))
|
||||
(quote
|
||||
((ancestor X Y <- (parent X Y))
|
||||
(ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(dl-retract! db (quote (parent bob ann)))
|
||||
(dl-query db (quote (ancestor tom X)))))
|
||||
(list {:X (quote bob)}))
|
||||
|
||||
;; dl-retract! on a relation with BOTH explicit facts AND a rule
|
||||
;; (a "mixed" relation) used to wipe the EDB portion when the IDB
|
||||
;; was re-derived, even when the retract didn't match anything.
|
||||
;; :edb-keys provenance now preserves user-asserted facts.
|
||||
(dl-api-test-set! "dl-retract! preserves EDB in mixed relation"
|
||||
(let
|
||||
((db (dl-program-data
|
||||
(quote ((p a) (p b) (q c)))
|
||||
(quote ((p X <- (q X)))))))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
;; Retract a non-existent tuple — should be a no-op.
|
||||
(dl-retract! db (quote (p z)))
|
||||
(dl-query db (quote (p X)))))
|
||||
(list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
;; And retracting an actual EDB fact in a mixed relation drops
|
||||
;; only that fact; the derived portion stays.
|
||||
(dl-api-test-set! "dl-retract! mixed: drop EDB, keep IDB"
|
||||
(let
|
||||
((db (dl-program-data
|
||||
(quote ((p a) (p b) (q c)))
|
||||
(quote ((p X <- (q X)))))))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(dl-retract! db (quote (p a)))
|
||||
(dl-query db (quote (p X)))))
|
||||
(list {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
;; dl-program-data + dl-query with constants in head.
|
||||
(dl-api-test-set! "constant-in-head data"
|
||||
(dl-query
|
||||
(dl-program-data
|
||||
(quote ((edge a b) (edge b c) (edge c a)))
|
||||
(quote
|
||||
((reach X Y <- (edge X Y))
|
||||
(reach X Z <- (edge X Y) (reach Y Z)))))
|
||||
(quote (reach a X)))
|
||||
(list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
;; Assert into empty db.
|
||||
(dl-api-test-set! "assert into empty"
|
||||
(let
|
||||
((db (dl-program-data (list) (list))))
|
||||
(do
|
||||
(dl-assert! db (quote (p 1)))
|
||||
(dl-assert! db (quote (p 2)))
|
||||
(dl-query db (quote (p X)))))
|
||||
(list {:X 1} {:X 2}))
|
||||
|
||||
;; Multi-goal query: pass list of literals.
|
||||
(dl-api-test-set! "multi-goal query"
|
||||
(dl-query
|
||||
(dl-program-data
|
||||
(quote ((p 1) (p 2) (p 3) (q 2) (q 3)))
|
||||
(list))
|
||||
(list (quote (p X)) (quote (q X))))
|
||||
(list {:X 2} {:X 3}))
|
||||
|
||||
;; Multi-goal with comparison.
|
||||
(dl-api-test-set! "multi-goal with comparison"
|
||||
(dl-query
|
||||
(dl-program-data
|
||||
(quote ((n 1) (n 2) (n 3) (n 4) (n 5)))
|
||||
(list))
|
||||
(list (quote (n X)) (list (string->symbol ">") (quote X) 2)))
|
||||
(list {:X 3} {:X 4} {:X 5}))
|
||||
|
||||
;; dl-eval: single-call source + query.
|
||||
(dl-api-test-set! "dl-eval ancestor"
|
||||
(dl-eval
|
||||
"parent(a, b). parent(b, c).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
|
||||
"?- ancestor(a, X).")
|
||||
(list {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
(dl-api-test-set! "dl-eval multi-goal"
|
||||
(dl-eval
|
||||
"p(1). p(2). p(3). q(2). q(3)."
|
||||
"?- p(X), q(X).")
|
||||
(list {:X 2} {:X 3}))
|
||||
|
||||
;; dl-rules-of: rules with head matching a relation name.
|
||||
(dl-api-test! "dl-rules-of count"
|
||||
(let
|
||||
((db (dl-program
|
||||
"p(1). q(X) :- p(X). r(X) :- p(X). q(2).")))
|
||||
(len (dl-rules-of db "q")))
|
||||
1)
|
||||
|
||||
(dl-api-test! "dl-rules-of empty"
|
||||
(let
|
||||
((db (dl-program "p(1). p(2).")))
|
||||
(len (dl-rules-of db "q")))
|
||||
0)
|
||||
|
||||
;; dl-clear-idb!: wipe rule-headed relations.
|
||||
(dl-api-test! "dl-clear-idb! wipes IDB"
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(a, b). parent(b, c).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(dl-clear-idb! db)
|
||||
(len (dl-relation db "ancestor"))))
|
||||
0)
|
||||
|
||||
(dl-api-test! "dl-clear-idb! preserves EDB"
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(a, b). parent(b, c).
|
||||
ancestor(X, Y) :- parent(X, Y).")))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(dl-clear-idb! db)
|
||||
(len (dl-relation db "parent"))))
|
||||
2)
|
||||
|
||||
;; dl-eval-magic — routes single-goal queries through
|
||||
;; magic-sets evaluation.
|
||||
(dl-api-test-set! "dl-eval-magic ancestor"
|
||||
(dl-eval-magic
|
||||
"parent(a, b). parent(b, c).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
|
||||
"?- ancestor(a, X).")
|
||||
(list {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
;; Equivalence: dl-eval and dl-eval-magic produce the same
|
||||
;; answers for any well-formed query (magic-sets is a perf
|
||||
;; alternative, not a semantic change).
|
||||
(dl-api-test! "dl-eval ≡ dl-eval-magic on ancestor"
|
||||
(let
|
||||
((source "parent(a, b). parent(b, c). parent(c, d).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
|
||||
(let
|
||||
((semi (dl-eval source "?- ancestor(a, X)."))
|
||||
(magic (dl-eval-magic source "?- ancestor(a, X).")))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; Comprehensive integration: recursion + stratified negation
|
||||
;; + aggregation + comparison composed in a single program.
|
||||
;; (Uses _Anything as a regular var instead of `_` so the
|
||||
;; outer rule binds via the reach lit.)
|
||||
(dl-api-test-set! "integration"
|
||||
(dl-eval
|
||||
(str
|
||||
"edge(a, b). edge(b, c). edge(c, d). edge(a, d). "
|
||||
"banned(c). "
|
||||
"reach(X, Y) :- edge(X, Y). "
|
||||
"reach(X, Z) :- edge(X, Y), reach(Y, Z). "
|
||||
"safe(X, Y) :- reach(X, Y), not(banned(Y)). "
|
||||
"reach_count(X, N) :- reach(X, Z), count(N, Y, safe(X, Y)). "
|
||||
"popular(X) :- reach_count(X, N), >=(N, 2).")
|
||||
"?- popular(X).")
|
||||
(list {:X (quote a)}))
|
||||
|
||||
;; dl-rule-from-list with no arrow → fact-style.
|
||||
(dl-api-test-set! "no arrow → fact-like rule"
|
||||
(let
|
||||
((rule (dl-rule-from-list (quote (foo X Y)))))
|
||||
(list rule))
|
||||
(list {:head (quote (foo X Y)) :body (list)}))
|
||||
|
||||
;; dl-coerce-rule on dict passes through.
|
||||
(dl-api-test-set! "coerce dict rule"
|
||||
(let
|
||||
((d {:head (quote (h X)) :body (quote ((b X)))}))
|
||||
(list (dl-coerce-rule d)))
|
||||
(list {:head (quote (h X)) :body (quote ((b X)))})))))
|
||||
|
||||
(define
|
||||
dl-api-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-api-pass 0)
|
||||
(set! dl-api-fail 0)
|
||||
(set! dl-api-failures (list))
|
||||
(dl-api-run-all!)
|
||||
{:passed dl-api-pass
|
||||
:failed dl-api-fail
|
||||
:total (+ dl-api-pass dl-api-fail)
|
||||
:failures dl-api-failures})))
|
||||
@@ -1,285 +0,0 @@
|
||||
;; lib/datalog/tests/builtins.sx — comparison + arithmetic body literals.
|
||||
|
||||
(define dl-bt-pass 0)
|
||||
(define dl-bt-fail 0)
|
||||
(define dl-bt-failures (list))
|
||||
|
||||
(define
|
||||
dl-bt-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-bt-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-bt-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-bt-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-bt-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-bt-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-bt-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-bt-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-bt-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-bt-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and (= (len a) (len b)) (dl-bt-subset? a b) (dl-bt-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-bt-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-bt-contains? ys (first xs))) false)
|
||||
(else (dl-bt-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-bt-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-bt-deep=? (first xs) target) true)
|
||||
(else (dl-bt-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-bt-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-bt-set=? got expected)
|
||||
(set! dl-bt-pass (+ dl-bt-pass 1))
|
||||
(do
|
||||
(set! dl-bt-fail (+ dl-bt-fail 1))
|
||||
(append!
|
||||
dl-bt-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): "
|
||||
expected
|
||||
"\n got: "
|
||||
got))))))
|
||||
|
||||
(define
|
||||
dl-bt-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-bt-deep=? got expected)
|
||||
(set! dl-bt-pass (+ dl-bt-pass 1))
|
||||
(do
|
||||
(set! dl-bt-fail (+ dl-bt-fail 1))
|
||||
(append!
|
||||
dl-bt-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-bt-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
||||
|
||||
(define
|
||||
dl-bt-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-bt-test-set!
|
||||
"less than filter"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"age(alice, 30). age(bob, 17). age(carol, 22).\n adult(X) :- age(X, A), >=(A, 18).")
|
||||
(list (quote adult) (quote X)))
|
||||
(list {:X (quote alice)} {:X (quote carol)}))
|
||||
(dl-bt-test-set!
|
||||
"less-equal filter"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3). n(4). n(5).\n small(X) :- n(X), <=(X, 3).")
|
||||
(list (quote small) (quote X)))
|
||||
(list {:X 1} {:X 2} {:X 3}))
|
||||
(dl-bt-test-set!
|
||||
"not-equal filter"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1, 2). p(2, 2). p(3, 4).\n diff(X, Y) :- p(X, Y), !=(X, Y).")
|
||||
(list (quote diff) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 2} {:X 3 :Y 4}))
|
||||
(dl-bt-test-set!
|
||||
"is plus"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3).\n succ(X, Y) :- n(X), is(Y, +(X, 1)).")
|
||||
(list (quote succ) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 2} {:X 2 :Y 3} {:X 3 :Y 4}))
|
||||
(dl-bt-test-set!
|
||||
"is multiply"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(2). n(3). n(4).\n square(X, Y) :- n(X), is(Y, *(X, X)).")
|
||||
(list (quote square) (quote X) (quote Y)))
|
||||
(list {:X 2 :Y 4} {:X 3 :Y 9} {:X 4 :Y 16}))
|
||||
(dl-bt-test-set!
|
||||
"is nested expr"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3).\n f(X, Y) :- n(X), is(Y, *(+(X, 1), 2)).")
|
||||
(list (quote f) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 4} {:X 2 :Y 6} {:X 3 :Y 8}))
|
||||
(dl-bt-test-set!
|
||||
"is bound LHS — equality"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1, 2). n(2, 5). n(3, 4).\n succ(X, Y) :- n(X, Y), is(Y, +(X, 1)).")
|
||||
(list (quote succ) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 2} {:X 3 :Y 4}))
|
||||
(dl-bt-test-set!
|
||||
"triple via is"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3).\n triple(X, Y) :- n(X), is(Y, *(X, 3)).")
|
||||
(list (quote triple) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 3} {:X 2 :Y 6} {:X 3 :Y 9}))
|
||||
(dl-bt-test-set!
|
||||
"= unifies var with constant"
|
||||
(dl-query
|
||||
(dl-program "p(a). p(b).\n qual(X) :- p(X), =(X, a).")
|
||||
(list (quote qual) (quote X)))
|
||||
(list {:X (quote a)}))
|
||||
(dl-bt-test-set!
|
||||
"= unifies two vars (one bound)"
|
||||
(dl-query
|
||||
(dl-program "p(a). p(b).\n twin(X, Y) :- p(X), =(Y, X).")
|
||||
(list (quote twin) (quote X) (quote Y)))
|
||||
(list {:X (quote a) :Y (quote a)} {:X (quote b) :Y (quote b)}))
|
||||
(dl-bt-test!
|
||||
"big count"
|
||||
(let
|
||||
((db (dl-program "n(0). n(1). n(2). n(3). n(4). n(5). n(6). n(7). n(8). n(9).\n big(X) :- n(X), >=(X, 5).")))
|
||||
(do (dl-saturate! db) (len (dl-relation db "big"))))
|
||||
5)
|
||||
;; Built-in / arithmetic literals work as standalone query goals
|
||||
;; (without needing a wrapper rule).
|
||||
(dl-bt-test-set! "comparison-only goal true"
|
||||
(dl-eval "" "?- <(1, 2).")
|
||||
(list {}))
|
||||
|
||||
(dl-bt-test-set! "comparison-only goal false"
|
||||
(dl-eval "" "?- <(2, 1).")
|
||||
(list))
|
||||
|
||||
(dl-bt-test-set! "is goal binds"
|
||||
(dl-eval "" "?- is(N, +(2, 3)).")
|
||||
(list {:N 5}))
|
||||
|
||||
;; Bounded successor: a recursive rule with a comparison
|
||||
;; guard terminates because the Herbrand base is effectively
|
||||
;; bounded.
|
||||
(dl-bt-test-set! "bounded successor"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"nat(0).
|
||||
nat(Y) :- nat(X), is(Y, +(X, 1)), <(Y, 5).")
|
||||
(list (quote nat) (quote X)))
|
||||
(list {:X 0} {:X 1} {:X 2} {:X 3} {:X 4}))
|
||||
|
||||
(dl-bt-test!
|
||||
"unsafe — comparison without binder"
|
||||
(dl-bt-throws? (fn () (dl-program "p(X) :- <(X, 5).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — comparison both unbound"
|
||||
(dl-bt-throws? (fn () (dl-program "p(X, Y) :- <(X, Y), q(X).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — is uses unbound RHS var"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "p(X, Y) :- q(X), is(Y, +(X, Z)).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — is on its own"
|
||||
(dl-bt-throws? (fn () (dl-program "p(Y) :- is(Y, +(X, 1)).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — = between two unbound"
|
||||
(dl-bt-throws? (fn () (dl-program "p(X, Y) :- =(X, Y).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"safe — is binds head var"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "n(1). p(Y) :- n(X), is(Y, +(X, 1)).")))
|
||||
false)
|
||||
(dl-bt-test!
|
||||
"safe — comparison after binder"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "n(1). big(X) :- n(X), >=(X, 0).")))
|
||||
false)
|
||||
(dl-bt-test!
|
||||
"safe — = binds head var"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "p(a). p(b). x(Y) :- p(X), =(Y, X).")))
|
||||
false)
|
||||
|
||||
;; Division by zero raises with a clear error. Without this guard
|
||||
;; SX's `/` returned IEEE infinity, which then silently flowed
|
||||
;; through comparisons and aggregations.
|
||||
(dl-bt-test!
|
||||
"is — division by zero raises"
|
||||
(dl-bt-throws?
|
||||
(fn ()
|
||||
(dl-eval "p(10). q(R) :- p(X), is(R, /(X, 0))." "?- q(R).")))
|
||||
true)
|
||||
|
||||
;; Comparison ops `<`, `<=`, `>`, `>=` require both operands to
|
||||
;; have the same primitive type. Cross-type comparisons used to
|
||||
;; silently return false (for some pairs) or raise a confusing
|
||||
;; host-level error (for others) — now they all raise with a
|
||||
;; message that names the offending values.
|
||||
(dl-bt-test!
|
||||
"comparison — string vs number raises"
|
||||
(dl-bt-throws?
|
||||
(fn ()
|
||||
(dl-eval "p(\"hello\"). q(X) :- p(X), <(X, 5)." "?- q(X).")))
|
||||
true)
|
||||
|
||||
;; `!=` is the exception — it's a polymorphic inequality test
|
||||
;; (uses dl-tuple-equal? underneath) so cross-type pairs are
|
||||
;; legitimate (and trivially unequal).
|
||||
(dl-bt-test-set! "!= works across types"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(\"1\"). q(X) :- p(X), !=(X, 1).")
|
||||
(quote (q X)))
|
||||
(list {:X "1"})))))
|
||||
|
||||
(define
|
||||
dl-builtins-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-bt-pass 0)
|
||||
(set! dl-bt-fail 0)
|
||||
(set! dl-bt-failures (list))
|
||||
(dl-bt-run-all!)
|
||||
{:failures dl-bt-failures :total (+ dl-bt-pass dl-bt-fail) :passed dl-bt-pass :failed dl-bt-fail})))
|
||||
@@ -1,321 +0,0 @@
|
||||
;; lib/datalog/tests/demo.sx — Phase 10 demo programs.
|
||||
|
||||
(define dl-demo-pass 0)
|
||||
(define dl-demo-fail 0)
|
||||
(define dl-demo-failures (list))
|
||||
|
||||
(define
|
||||
dl-demo-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-demo-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let ((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-demo-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-demo-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-demo-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-demo-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-demo-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i)))
|
||||
(not (dl-demo-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-demo-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-demo-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and
|
||||
(= (len a) (len b))
|
||||
(dl-demo-subset? a b)
|
||||
(dl-demo-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-demo-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-demo-contains? ys (first xs))) false)
|
||||
(else (dl-demo-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-demo-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-demo-deep=? (first xs) target) true)
|
||||
(else (dl-demo-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-demo-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-demo-set=? got expected)
|
||||
(set! dl-demo-pass (+ dl-demo-pass 1))
|
||||
(do
|
||||
(set! dl-demo-fail (+ dl-demo-fail 1))
|
||||
(append!
|
||||
dl-demo-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-demo-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
;; ── Federation ──────────────────────────────────────────
|
||||
(dl-demo-test-set! "mutuals"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote ((follows alice bob) (follows bob alice)
|
||||
(follows bob carol) (follows carol dave)))
|
||||
dl-demo-federation-rules)
|
||||
(quote (mutual alice X)))
|
||||
(list {:X (quote bob)}))
|
||||
|
||||
(dl-demo-test-set! "reachable transitive"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote ((follows alice bob) (follows bob carol) (follows carol dave)))
|
||||
dl-demo-federation-rules)
|
||||
(quote (reachable alice X)))
|
||||
(list {:X (quote bob)} {:X (quote carol)} {:X (quote dave)}))
|
||||
|
||||
(dl-demo-test-set! "foaf"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote ((follows alice bob) (follows bob carol) (follows alice dave)))
|
||||
dl-demo-federation-rules)
|
||||
(quote (foaf alice X)))
|
||||
(list {:X (quote carol)}))
|
||||
|
||||
;; ── Content ─────────────────────────────────────────────
|
||||
(dl-demo-test-set! "popular posts"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((authored alice p1) (authored bob p2) (authored carol p3)
|
||||
(liked u1 p1) (liked u2 p1) (liked u3 p1)
|
||||
(liked u1 p2)))
|
||||
dl-demo-content-rules)
|
||||
(quote (popular P)))
|
||||
(list {:P (quote p1)}))
|
||||
|
||||
(dl-demo-test-set! "interesting feed"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((follows me alice) (follows me bob)
|
||||
(authored alice p1) (authored bob p2)
|
||||
(liked u1 p1) (liked u2 p1) (liked u3 p1)
|
||||
(liked u4 p2)))
|
||||
dl-demo-content-rules)
|
||||
(quote (interesting me P)))
|
||||
(list {:P (quote p1)}))
|
||||
|
||||
(dl-demo-test-set! "post likes count"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((authored alice p1)
|
||||
(liked u1 p1) (liked u2 p1) (liked u3 p1)))
|
||||
dl-demo-content-rules)
|
||||
(quote (post-likes p1 N)))
|
||||
(list {:N 3}))
|
||||
|
||||
;; ── Permissions ─────────────────────────────────────────
|
||||
(dl-demo-test-set! "direct group access"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((member alice editors)
|
||||
(allowed editors blog)))
|
||||
dl-demo-perm-rules)
|
||||
(quote (can-access X blog)))
|
||||
(list {:X (quote alice)}))
|
||||
|
||||
(dl-demo-test-set! "subgroup access"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((member bob writers)
|
||||
(subgroup writers editors)
|
||||
(allowed editors blog)))
|
||||
dl-demo-perm-rules)
|
||||
(quote (can-access X blog)))
|
||||
(list {:X (quote bob)}))
|
||||
|
||||
(dl-demo-test-set! "transitive subgroup"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((member carol drafters)
|
||||
(subgroup drafters writers)
|
||||
(subgroup writers editors)
|
||||
(allowed editors blog)))
|
||||
dl-demo-perm-rules)
|
||||
(quote (can-access X blog)))
|
||||
(list {:X (quote carol)}))
|
||||
|
||||
;; ── Cooking posts (canonical Phase 10 example) ─────────
|
||||
(dl-demo-test-set! "cooking posts by network"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((follows me alice) (follows alice bob) (follows alice carol)
|
||||
(authored alice p1) (authored bob p2)
|
||||
(authored carol p3) (authored carol p4)
|
||||
(tagged p1 travel) (tagged p2 cooking)
|
||||
(tagged p3 cooking) (tagged p4 books)))
|
||||
dl-demo-cooking-rules)
|
||||
(quote (cooking-post-by-network me P)))
|
||||
(list {:P (quote p2)} {:P (quote p3)}))
|
||||
|
||||
(dl-demo-test-set! "cooking — direct follow only"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((follows me bob)
|
||||
(authored bob p1) (authored bob p2)
|
||||
(tagged p1 cooking) (tagged p2 books)))
|
||||
dl-demo-cooking-rules)
|
||||
(quote (cooking-post-by-network me P)))
|
||||
(list {:P (quote p1)}))
|
||||
|
||||
(dl-demo-test-set! "cooking — none in network"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((follows me bob)
|
||||
(authored bob p1) (tagged p1 books)))
|
||||
dl-demo-cooking-rules)
|
||||
(quote (cooking-post-by-network me P)))
|
||||
(list))
|
||||
|
||||
;; ── Tag co-occurrence ──────────────────────────────────
|
||||
(dl-demo-test-set! "cotagged posts"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((tagged p1 cooking) (tagged p1 vegetarian)
|
||||
(tagged p2 cooking) (tagged p2 quick)
|
||||
(tagged p3 vegetarian)))
|
||||
dl-demo-tag-cooccur-rules)
|
||||
(quote (cotagged P cooking vegetarian)))
|
||||
(list {:P (quote p1)}))
|
||||
|
||||
(dl-demo-test-set! "tag pair count"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((tagged p1 cooking) (tagged p1 vegetarian)
|
||||
(tagged p2 cooking) (tagged p2 quick)
|
||||
(tagged p3 cooking) (tagged p3 vegetarian)))
|
||||
dl-demo-tag-cooccur-rules)
|
||||
(quote (tag-pair-count cooking vegetarian N)))
|
||||
(list {:N 2}))
|
||||
|
||||
;; ── Shortest path on a weighted DAG ──────────────────
|
||||
(dl-demo-test-set! "shortest a→d via DAG"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote ((edge a b 5) (edge b c 3) (edge a c 10) (edge c d 2)))
|
||||
dl-demo-shortest-path-rules)
|
||||
(quote (shortest a d W)))
|
||||
(list {:W 10}))
|
||||
|
||||
(dl-demo-test-set! "shortest a→c picks 2-hop"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote ((edge a b 5) (edge b c 3) (edge a c 10)))
|
||||
dl-demo-shortest-path-rules)
|
||||
(quote (shortest a c W)))
|
||||
(list {:W 8}))
|
||||
|
||||
(dl-demo-test-set! "shortest unreachable empty"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote ((edge a b 5) (edge b c 3)))
|
||||
dl-demo-shortest-path-rules)
|
||||
(quote (shortest a d W)))
|
||||
(list))
|
||||
|
||||
;; ── Org chart + headcount ─────────────────────────────
|
||||
(dl-demo-test-set! "ceo subordinate transitive"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((manager ic1 mgr1) (manager ic2 mgr1)
|
||||
(manager mgr1 vp1) (manager ic3 vp1)
|
||||
(manager vp1 ceo)))
|
||||
dl-demo-org-rules)
|
||||
(quote (subordinate ceo X)))
|
||||
(list
|
||||
{:X (quote vp1)} {:X (quote mgr1)} {:X (quote ic1)}
|
||||
{:X (quote ic2)} {:X (quote ic3)}))
|
||||
|
||||
(dl-demo-test-set! "ceo headcount = 5"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((manager ic1 mgr1) (manager ic2 mgr1)
|
||||
(manager mgr1 vp1) (manager ic3 vp1)
|
||||
(manager vp1 ceo)))
|
||||
dl-demo-org-rules)
|
||||
(quote (headcount ceo N)))
|
||||
(list {:N 5}))
|
||||
|
||||
(dl-demo-test-set! "mgr1 headcount = 2"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote
|
||||
((manager ic1 mgr1) (manager ic2 mgr1)
|
||||
(manager mgr1 vp1) (manager ic3 vp1)
|
||||
(manager vp1 ceo)))
|
||||
dl-demo-org-rules)
|
||||
(quote (headcount mgr1 N)))
|
||||
(list {:N 2}))
|
||||
|
||||
(dl-demo-test-set! "no access without grant"
|
||||
(dl-query
|
||||
(dl-demo-make
|
||||
(quote ((member dave outsiders) (allowed editors blog)))
|
||||
dl-demo-perm-rules)
|
||||
(quote (can-access X blog)))
|
||||
(list)))))
|
||||
|
||||
(define
|
||||
dl-demo-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-demo-pass 0)
|
||||
(set! dl-demo-fail 0)
|
||||
(set! dl-demo-failures (list))
|
||||
(dl-demo-run-all!)
|
||||
{:passed dl-demo-pass
|
||||
:failed dl-demo-fail
|
||||
:total (+ dl-demo-pass dl-demo-fail)
|
||||
:failures dl-demo-failures})))
|
||||
@@ -1,463 +0,0 @@
|
||||
;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
|
||||
|
||||
(define dl-et-pass 0)
|
||||
(define dl-et-fail 0)
|
||||
(define dl-et-failures (list))
|
||||
|
||||
;; Same deep-equal helper used in other suites.
|
||||
(define
|
||||
dl-et-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-et-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-et-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-et-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-et-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-et-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
;; Set-equality on lists (order-independent, uses dl-et-deep=?).
|
||||
(define
|
||||
dl-et-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-et-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-et-contains? ys (first xs))) false)
|
||||
(else (dl-et-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-et-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-et-deep=? (first xs) target) true)
|
||||
(else (dl-et-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-et-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-et-deep=? got expected)
|
||||
(set! dl-et-pass (+ dl-et-pass 1))
|
||||
(do
|
||||
(set! dl-et-fail (+ dl-et-fail 1))
|
||||
(append!
|
||||
dl-et-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-et-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-et-set=? got expected)
|
||||
(set! dl-et-pass (+ dl-et-pass 1))
|
||||
(do
|
||||
(set! dl-et-fail (+ dl-et-fail 1))
|
||||
(append!
|
||||
dl-et-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): "
|
||||
expected
|
||||
"\n got: "
|
||||
got))))))
|
||||
|
||||
(define
|
||||
dl-et-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
||||
|
||||
(define
|
||||
dl-et-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-et-test-set!
|
||||
"fact lookup any"
|
||||
(dl-query
|
||||
(dl-program "parent(tom, bob). parent(bob, ann).")
|
||||
(list (quote parent) (quote X) (quote Y)))
|
||||
(list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
|
||||
(dl-et-test-set!
|
||||
"fact lookup constant arg"
|
||||
(dl-query
|
||||
(dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
|
||||
(list (quote parent) (quote tom) (quote Y)))
|
||||
(list {:Y (quote bob)} {:Y (quote liz)}))
|
||||
(dl-et-test-set!
|
||||
"no match"
|
||||
(dl-query
|
||||
(dl-program "parent(tom, bob).")
|
||||
(list (quote parent) (quote nobody) (quote X)))
|
||||
(list))
|
||||
(dl-et-test-set!
|
||||
"ancestor closure"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(tom, bob). parent(bob, ann). parent(ann, pat).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
||||
(list (quote ancestor) (quote tom) (quote X)))
|
||||
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
||||
(dl-et-test-set!
|
||||
"sibling"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n sibling(X, Y) :- parent(P, X), parent(P, Y).")
|
||||
(list (quote sibling) (quote bob) (quote Y)))
|
||||
(list {:Y (quote bob)} {:Y (quote liz)}))
|
||||
(dl-et-test-set!
|
||||
"same-generation"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n person(tom). person(bob). person(liz). person(ann). person(joe).\n sg(X, X) :- person(X).\n sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
|
||||
(list (quote sg) (quote ann) (quote X)))
|
||||
(list {:X (quote ann)} {:X (quote joe)}))
|
||||
(dl-et-test!
|
||||
"ancestor count"
|
||||
(let
|
||||
((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(do (dl-saturate! db) (len (dl-relation db "ancestor"))))
|
||||
6)
|
||||
(dl-et-test-set!
|
||||
"grandparent"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(a, b). parent(b, c). parent(c, d).\n grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
|
||||
(list (quote grandparent) (quote X) (quote Y)))
|
||||
(list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
|
||||
(dl-et-test!
|
||||
"no recursion infinite loop"
|
||||
(let
|
||||
((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n reach(X, Y) :- edge(X, Y).\n reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
|
||||
(do (dl-saturate! db) (len (dl-relation db "reach"))))
|
||||
9)
|
||||
;; Rule-shape sanity: empty-list head and non-list body raise
|
||||
;; clear errors rather than crashing inside the saturator.
|
||||
(dl-et-test! "empty head rejected"
|
||||
(dl-et-throws?
|
||||
(fn ()
|
||||
(dl-add-rule! (dl-make-db)
|
||||
{:head (list) :body (list)})))
|
||||
true)
|
||||
|
||||
(dl-et-test! "non-list body rejected"
|
||||
(dl-et-throws?
|
||||
(fn ()
|
||||
(dl-add-rule! (dl-make-db)
|
||||
{:head (list (quote p) (quote X)) :body 42})))
|
||||
true)
|
||||
|
||||
;; Reserved relation names rejected as rule/fact heads.
|
||||
(dl-et-test!
|
||||
"reserved name `not` as head rejected"
|
||||
(dl-et-throws? (fn () (dl-program "not(X) :- p(X).")))
|
||||
true)
|
||||
|
||||
(dl-et-test!
|
||||
"reserved name `count` as head rejected"
|
||||
(dl-et-throws?
|
||||
(fn () (dl-program "count(N, X, p(X)) :- p(X).")))
|
||||
true)
|
||||
|
||||
(dl-et-test!
|
||||
"reserved name `<` as head rejected"
|
||||
(dl-et-throws? (fn () (dl-program "<(X, 5) :- p(X).")))
|
||||
true)
|
||||
|
||||
(dl-et-test!
|
||||
"reserved name `is` as head rejected"
|
||||
(dl-et-throws? (fn () (dl-program "is(N, +(1, 2)) :- p(N).")))
|
||||
true)
|
||||
|
||||
;; Body literal with a reserved-name positive head is rejected.
|
||||
;; The parser only treats outer-level `not(P)` as negation; nested
|
||||
;; `not(not(P))` would otherwise silently parse as a positive call
|
||||
;; to a relation named `not` and succeed vacuously. The safety
|
||||
;; checker now flags this so the user gets a clear error.
|
||||
;; Body literal with a reserved-name positive head is rejected.
|
||||
;; The parser only treats outer-level `not(P)` as negation; nested
|
||||
;; `not(not(P))` would otherwise silently parse as a positive call
|
||||
;; to a relation named `not` and succeed vacuously — so the safety
|
||||
;; checker now flags this to give the user a clear error.
|
||||
(dl-et-test!
|
||||
"nested not(not(...)) rejected"
|
||||
(dl-et-throws?
|
||||
(fn ()
|
||||
(dl-program
|
||||
"banned(a). u(a). vip(X) :- u(X), not(not(banned(X))).")))
|
||||
true)
|
||||
|
||||
;; A dict body literal that isn't `{:neg ...}` is almost always a
|
||||
;; typo — it would otherwise silently fall through to a confusing
|
||||
;; head-var-unbound safety error. Now caught with a clear message.
|
||||
(dl-et-test!
|
||||
"dict body lit without :neg rejected"
|
||||
(dl-et-throws?
|
||||
(fn ()
|
||||
(let ((db (dl-make-db)))
|
||||
(dl-add-rule! db
|
||||
{:head (list (quote p) (quote X))
|
||||
:body (list {:weird "stuff"})}))))
|
||||
true)
|
||||
|
||||
;; Facts may only have simple-term args (number / string / symbol).
|
||||
;; A compound arg like `+(1, 2)` would otherwise be silently
|
||||
;; stored as the unreduced expression `(+ 1 2)` because dl-ground?
|
||||
;; sees no free variables.
|
||||
(dl-et-test!
|
||||
"compound arg in fact rejected"
|
||||
(dl-et-throws? (fn () (dl-program "p(+(1, 2)).")))
|
||||
true)
|
||||
|
||||
;; Rule heads may only have variable or constant args — no
|
||||
;; compounds. Compound heads would be saturated as unreduced
|
||||
;; tuples rather than the arithmetic result the user expected.
|
||||
(dl-et-test!
|
||||
"compound arg in rule head rejected"
|
||||
(dl-et-throws?
|
||||
(fn () (dl-program "n(3). double(*(X, 2)) :- n(X).")))
|
||||
true)
|
||||
|
||||
;; The anonymous-variable renamer used to start at `_anon1`
|
||||
;; unconditionally; a rule that wrote `q(_anon1) :- p(_anon1, _)`
|
||||
;; (the user picking the same name the renamer would generate)
|
||||
;; would see the `_` renamed to `_anon1` too, collapsing the
|
||||
;; two positions in `p(_anon1, _)` to a single var. Now the
|
||||
;; renamer scans the rule for the max `_anon<N>` and starts past
|
||||
;; it, so user-written names of that form are preserved.
|
||||
(dl-et-test-set! "anonymous-rename avoids user `_anon` collision"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(a, b). p(c, d). q(_anon1) :- p(_anon1, _).")
|
||||
(quote (q X)))
|
||||
(list {:X (quote a)} {:X (quote c)}))
|
||||
|
||||
(dl-et-test!
|
||||
"unsafe head var"
|
||||
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
|
||||
true)
|
||||
(dl-et-test!
|
||||
"unsafe — empty body"
|
||||
(dl-et-throws? (fn () (dl-program "p(X) :- .")))
|
||||
true)
|
||||
;; Underscore in head is unsafe — it's a fresh existential per
|
||||
;; occurrence after Phase 5d's anonymous-var renaming, and there's
|
||||
;; nothing in the body to bind it. (Old behavior accepted this by
|
||||
;; treating '_' as a literal name to skip; the renaming made it an
|
||||
;; ordinary unbound variable.)
|
||||
(dl-et-test!
|
||||
"underscore in head — unsafe"
|
||||
(dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
|
||||
true)
|
||||
(dl-et-test!
|
||||
"underscore in body only — safe"
|
||||
(dl-et-throws? (fn () (dl-program "p(X) :- q(X, _).")))
|
||||
false)
|
||||
(dl-et-test!
|
||||
"var only in head — unsafe"
|
||||
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
|
||||
true)
|
||||
(dl-et-test!
|
||||
"head var bound by body"
|
||||
(dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
|
||||
false)
|
||||
(dl-et-test!
|
||||
"head subset of body"
|
||||
(dl-et-throws?
|
||||
(fn
|
||||
()
|
||||
(dl-program
|
||||
"edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
|
||||
false)
|
||||
|
||||
;; Anonymous variables: each occurrence must be independent.
|
||||
(dl-et-test-set! "anon vars in rule are independent"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(a, b). p(c, d). q(X) :- p(X, _), p(_, Y).")
|
||||
(list (quote q) (quote X)))
|
||||
(list {:X (quote a)} {:X (quote c)}))
|
||||
|
||||
(dl-et-test-set! "anon vars in goal are independent"
|
||||
(dl-query
|
||||
(dl-program "p(1, 2, 3). p(4, 5, 6).")
|
||||
(list (quote p) (quote _) (quote X) (quote _)))
|
||||
(list {:X 2} {:X 5}))
|
||||
|
||||
;; dl-summary: relation -> tuple-count for inspection.
|
||||
(dl-et-test! "dl-summary basic"
|
||||
(dl-summary
|
||||
(let
|
||||
((db (dl-program "p(1). p(2). q(3).")))
|
||||
(do (dl-saturate! db) db)))
|
||||
{:p 2 :q 1})
|
||||
|
||||
(dl-et-test! "dl-summary empty IDB shown"
|
||||
(dl-summary
|
||||
(let
|
||||
((db (dl-program "r(X) :- s(X).")))
|
||||
(do (dl-saturate! db) db)))
|
||||
{:r 0})
|
||||
|
||||
(dl-et-test! "dl-summary mixed EDB and IDB"
|
||||
(dl-summary
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(a, b).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(do (dl-saturate! db) db)))
|
||||
{:parent 1 :ancestor 1})
|
||||
|
||||
(dl-et-test! "dl-summary empty db"
|
||||
(dl-summary (dl-make-db))
|
||||
{})
|
||||
|
||||
;; Strategy hook: default semi-naive; :magic accepted but
|
||||
;; falls back to semi-naive (the transformation itself is
|
||||
;; deferred — Phase 6 in plan).
|
||||
(dl-et-test! "default strategy"
|
||||
(dl-get-strategy (dl-make-db))
|
||||
:semi-naive)
|
||||
|
||||
(dl-et-test! "set strategy"
|
||||
(let ((db (dl-make-db)))
|
||||
(do (dl-set-strategy! db :magic) (dl-get-strategy db)))
|
||||
:magic)
|
||||
|
||||
;; Unknown strategy values are rejected so typos don't silently
|
||||
;; fall back to the default.
|
||||
(dl-et-test!
|
||||
"unknown strategy rejected"
|
||||
(dl-et-throws?
|
||||
(fn ()
|
||||
(let ((db (dl-make-db)))
|
||||
(dl-set-strategy! db :semi_naive))))
|
||||
true)
|
||||
|
||||
;; dl-saturated?: no-work-left predicate.
|
||||
(dl-et-test! "saturated? after saturation"
|
||||
(let ((db (dl-program
|
||||
"parent(a, b).
|
||||
ancestor(X, Y) :- parent(X, Y).")))
|
||||
(do (dl-saturate! db) (dl-saturated? db)))
|
||||
true)
|
||||
|
||||
(dl-et-test! "saturated? before saturation"
|
||||
(let ((db (dl-program
|
||||
"parent(a, b).
|
||||
ancestor(X, Y) :- parent(X, Y).")))
|
||||
(dl-saturated? db))
|
||||
false)
|
||||
|
||||
;; Disjunction via multiple rules — Datalog has no `;` in
|
||||
;; body, so disjunction is expressed as separate rules with
|
||||
;; the same head. Here plant_based(X) is satisfied by either
|
||||
;; vegan(X) or vegetarian(X).
|
||||
(dl-et-test-set! "disjunction via multiple rules"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"vegan(alice). vegetarian(bob). meat_eater(carol).
|
||||
plant_based(X) :- vegan(X).
|
||||
plant_based(X) :- vegetarian(X).")
|
||||
(list (quote plant_based) (quote X)))
|
||||
(list {:X (quote alice)} {:X (quote bob)}))
|
||||
|
||||
;; Bipartite-style join: pair-of-friends who share a hobby.
|
||||
;; Three-relation join exercising the planner's join order.
|
||||
(dl-et-test-set! "bipartite friends-with-hobby"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"hobby(alice, climb). hobby(bob, paint).
|
||||
hobby(carol, climb).
|
||||
friend(alice, carol). friend(bob, alice).
|
||||
match(A, B, H) :- friend(A, B), hobby(A, H), hobby(B, H).")
|
||||
(list (quote match) (quote A) (quote B) (quote H)))
|
||||
(list {:A (quote alice) :B (quote carol) :H (quote climb)}))
|
||||
|
||||
;; Repeated variable (diagonal): p(X, X) only matches tuples
|
||||
;; whose two args are equal. The unifier handles this via the
|
||||
;; subst chain — first occurrence binds X, second occurrence
|
||||
;; checks against the binding.
|
||||
(dl-et-test-set! "diagonal query"
|
||||
(dl-query
|
||||
(dl-program "p(1, 1). p(2, 3). p(4, 4). p(5, 5).")
|
||||
(list (quote p) (quote X) (quote X)))
|
||||
(list {:X 1} {:X 4} {:X 5}))
|
||||
|
||||
;; A relation can be both EDB-seeded and rule-derived;
|
||||
;; saturate combines facts + derivations.
|
||||
(dl-et-test-set! "mixed EDB + IDB same relation"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"link(a, b). link(c, d). link(e, c).
|
||||
via(a, e).
|
||||
link(X, Y) :- via(X, M), link(M, Y).")
|
||||
(list (quote link) (quote a) (quote X)))
|
||||
(list {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
(dl-et-test! "saturated? after assert"
|
||||
(let ((db (dl-program
|
||||
"parent(a, b).
|
||||
ancestor(X, Y) :- parent(X, Y).")))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(dl-add-fact! db (list (quote parent) (quote b) (quote c)))
|
||||
(dl-saturated? db)))
|
||||
false)
|
||||
|
||||
(dl-et-test-set! "magic-set still derives correctly"
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(a, b). parent(b, c).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(do
|
||||
(dl-set-strategy! db :magic)
|
||||
(dl-query db (list (quote ancestor) (quote a) (quote X)))))
|
||||
(list {:X (quote b)} {:X (quote c)})))))
|
||||
|
||||
(define
|
||||
dl-eval-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-et-pass 0)
|
||||
(set! dl-et-fail 0)
|
||||
(set! dl-et-failures (list))
|
||||
(dl-et-run-all!)
|
||||
{:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))
|
||||
@@ -1,528 +0,0 @@
|
||||
;; lib/datalog/tests/magic.sx — adornment + SIPS analysis tests.
|
||||
|
||||
(define dl-mt-pass 0)
|
||||
(define dl-mt-fail 0)
|
||||
(define dl-mt-failures (list))
|
||||
|
||||
(define
|
||||
dl-mt-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-mt-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let ((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-mt-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-mt-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-mt-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-mt-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-mt-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i)))
|
||||
(not (dl-mt-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-mt-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-mt-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-mt-deep=? got expected)
|
||||
(set! dl-mt-pass (+ dl-mt-pass 1))
|
||||
(do
|
||||
(set! dl-mt-fail (+ dl-mt-fail 1))
|
||||
(append!
|
||||
dl-mt-failures
|
||||
(str
|
||||
name
|
||||
"\n expected: " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-mt-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
;; Goal adornment.
|
||||
(dl-mt-test! "adorn 0-ary"
|
||||
(dl-adorn-goal (list (quote ready)))
|
||||
"")
|
||||
(dl-mt-test! "adorn all bound"
|
||||
(dl-adorn-goal (list (quote p) 1 2 3))
|
||||
"bbb")
|
||||
(dl-mt-test! "adorn all free"
|
||||
(dl-adorn-goal (list (quote p) (quote X) (quote Y)))
|
||||
"ff")
|
||||
(dl-mt-test! "adorn mixed"
|
||||
(dl-adorn-goal (list (quote ancestor) (quote tom) (quote X)))
|
||||
"bf")
|
||||
(dl-mt-test! "adorn const var const"
|
||||
(dl-adorn-goal (list (quote p) (quote a) (quote X) (quote b)))
|
||||
"bfb")
|
||||
|
||||
;; dl-adorn-lit with explicit bound set.
|
||||
(dl-mt-test! "adorn lit with bound"
|
||||
(dl-adorn-lit (list (quote p) (quote X) (quote Y)) (list "X"))
|
||||
"bf")
|
||||
|
||||
;; Rule SIPS — chain ancestor.
|
||||
(dl-mt-test! "sips chain ancestor bf"
|
||||
(dl-rule-sips
|
||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
||||
:body (list (list (quote parent) (quote X) (quote Y))
|
||||
(list (quote ancestor) (quote Y) (quote Z)))}
|
||||
"bf")
|
||||
(list
|
||||
{:lit (list (quote parent) (quote X) (quote Y)) :adornment "bf"}
|
||||
{:lit (list (quote ancestor) (quote Y) (quote Z)) :adornment "bf"}))
|
||||
|
||||
;; SIPS — head fully bound.
|
||||
(dl-mt-test! "sips head bb"
|
||||
(dl-rule-sips
|
||||
{:head (list (quote q) (quote X) (quote Y))
|
||||
:body (list (list (quote p) (quote X) (quote Z))
|
||||
(list (quote r) (quote Z) (quote Y)))}
|
||||
"bb")
|
||||
(list
|
||||
{:lit (list (quote p) (quote X) (quote Z)) :adornment "bf"}
|
||||
{:lit (list (quote r) (quote Z) (quote Y)) :adornment "bb"}))
|
||||
|
||||
;; SIPS — comparison; vars must be bound by prior body lit.
|
||||
(dl-mt-test! "sips with comparison"
|
||||
(dl-rule-sips
|
||||
{:head (list (quote q) (quote X))
|
||||
:body (list (list (quote p) (quote X))
|
||||
(list (string->symbol "<") (quote X) 5))}
|
||||
"f")
|
||||
(list
|
||||
{:lit (list (quote p) (quote X)) :adornment "f"}
|
||||
{:lit (list (string->symbol "<") (quote X) 5) :adornment "bb"}))
|
||||
|
||||
;; SIPS — `is` binds its left arg.
|
||||
(dl-mt-test! "sips with is"
|
||||
(dl-rule-sips
|
||||
{:head (list (quote q) (quote X) (quote Y))
|
||||
:body (list (list (quote p) (quote X))
|
||||
(list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1)))}
|
||||
"ff")
|
||||
(list
|
||||
{:lit (list (quote p) (quote X)) :adornment "f"}
|
||||
{:lit (list (quote is) (quote Y)
|
||||
(list (string->symbol "+") (quote X) 1))
|
||||
:adornment "fb"}))
|
||||
|
||||
;; Magic predicate naming.
|
||||
(dl-mt-test! "magic-rel-name"
|
||||
(dl-magic-rel-name "ancestor" "bf")
|
||||
"magic_ancestor^bf")
|
||||
|
||||
;; Bound-args extraction.
|
||||
(dl-mt-test! "bound-args bf"
|
||||
(dl-bound-args (list (quote ancestor) (quote tom) (quote X)) "bf")
|
||||
(list (quote tom)))
|
||||
|
||||
(dl-mt-test! "bound-args mixed"
|
||||
(dl-bound-args (list (quote p) 1 (quote Y) 3) "bfb")
|
||||
(list 1 3))
|
||||
|
||||
(dl-mt-test! "bound-args all-free"
|
||||
(dl-bound-args (list (quote p) (quote X) (quote Y)) "ff")
|
||||
(list))
|
||||
|
||||
;; Magic literal construction.
|
||||
(dl-mt-test! "magic-lit"
|
||||
(dl-magic-lit "ancestor" "bf" (list (quote tom)))
|
||||
(list (string->symbol "magic_ancestor^bf") (quote tom)))
|
||||
|
||||
;; Magic-sets rewriter: structural sanity.
|
||||
(dl-mt-test! "rewrite ancestor produces seed"
|
||||
(let
|
||||
((rules
|
||||
(list
|
||||
{:head (list (quote ancestor) (quote X) (quote Y))
|
||||
:body (list (list (quote parent) (quote X) (quote Y)))}
|
||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
||||
:body
|
||||
(list (list (quote parent) (quote X) (quote Y))
|
||||
(list (quote ancestor) (quote Y) (quote Z)))})))
|
||||
(get
|
||||
(dl-magic-rewrite rules "ancestor" "bf" (list (quote a)))
|
||||
:seed))
|
||||
(list (string->symbol "magic_ancestor^bf") (quote a)))
|
||||
|
||||
;; Equivalence: rewritten program derives same ancestor tuples.
|
||||
;; In a chain a→b→c→d, magic-rewritten run still derives all
|
||||
;; ancestor pairs reachable from any node a/b/c/d propagated via
|
||||
;; magic_ancestor^bf — i.e. the full closure (6 tuples). Magic
|
||||
;; saves work only when the EDB has irrelevant nodes outside
|
||||
;; the seed's transitive cone.
|
||||
(dl-mt-test! "magic-rewritten ancestor count"
|
||||
(let
|
||||
((rules
|
||||
(list
|
||||
{:head (list (quote ancestor) (quote X) (quote Y))
|
||||
:body (list (list (quote parent) (quote X) (quote Y)))}
|
||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
||||
:body
|
||||
(list (list (quote parent) (quote X) (quote Y))
|
||||
(list (quote ancestor) (quote Y) (quote Z)))}))
|
||||
(edb (list
|
||||
(list (quote parent) (quote a) (quote b))
|
||||
(list (quote parent) (quote b) (quote c))
|
||||
(list (quote parent) (quote c) (quote d)))))
|
||||
(let
|
||||
((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
|
||||
(db (dl-make-db)))
|
||||
(do
|
||||
(for-each (fn (f) (dl-add-fact! db f)) edb)
|
||||
(dl-add-fact! db (get rewritten :seed))
|
||||
(for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
|
||||
(dl-saturate! db)
|
||||
(len (dl-relation db "ancestor")))))
|
||||
6)
|
||||
|
||||
;; dl-magic-query: end-to-end driver, doesn't mutate caller's db.
|
||||
;; Magic over a rule with negated body literal — propagation
|
||||
;; rules generated only for positive lits; negated lits pass
|
||||
;; through unchanged.
|
||||
(dl-mt-test! "magic over rule with negation"
|
||||
(let
|
||||
((db (dl-program
|
||||
"u(a). u(b). u(c). banned(b).
|
||||
active(X) :- u(X), not(banned(X)).")))
|
||||
(let
|
||||
((semi (dl-query db (list (quote active) (quote X))))
|
||||
(magic (dl-magic-query db (list (quote active) (quote X)))))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; All-bound query (existence check) generates an "bb"
|
||||
;; adornment chain. Verifies the rewriter walks multiple
|
||||
;; (rel, adn) pairs through the worklist.
|
||||
(dl-mt-test! "magic existence check via bb"
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(a, b). parent(b, c). parent(c, d).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(let
|
||||
((found (dl-magic-query
|
||||
db (list (quote ancestor) (quote a) (quote c))))
|
||||
(missing (dl-magic-query
|
||||
db (list (quote ancestor) (quote a) (quote z)))))
|
||||
(and (= (len found) 1) (= (len missing) 0))))
|
||||
true)
|
||||
|
||||
;; Magic equivalence on the federation demo.
|
||||
(dl-mt-test! "magic ≡ semi on foaf demo"
|
||||
(let
|
||||
((db (dl-program-data
|
||||
(quote ((follows alice bob)
|
||||
(follows bob carol)
|
||||
(follows alice dave)))
|
||||
dl-demo-federation-rules)))
|
||||
(let
|
||||
((semi (dl-query db (quote (foaf alice X))))
|
||||
(magic (dl-magic-query db (quote (foaf alice X)))))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; Shape validation: dl-magic-query rejects non-list / non-
|
||||
;; dict goal shapes cleanly rather than crashing in `rest`.
|
||||
(dl-mt-test! "magic rejects string goal"
|
||||
(let ((threw false))
|
||||
(do
|
||||
(guard (e (#t (set! threw true)))
|
||||
(dl-magic-query (dl-make-db) "foo"))
|
||||
threw))
|
||||
true)
|
||||
|
||||
(dl-mt-test! "magic rejects bare dict goal"
|
||||
(let ((threw false))
|
||||
(do
|
||||
(guard (e (#t (set! threw true)))
|
||||
(dl-magic-query (dl-make-db) {:foo "bar"}))
|
||||
threw))
|
||||
true)
|
||||
|
||||
;; 3-stratum program under magic — distinct rule heads at
|
||||
;; strata 0/1/2 must all rewrite via the worklist.
|
||||
(dl-mt-test! "magic 3-stratum program"
|
||||
(let
|
||||
((db (dl-program
|
||||
"a(1). a(2). a(3). b(2).
|
||||
c(X) :- a(X), not(b(X)).
|
||||
d(X) :- c(X), not(banned(X)).
|
||||
banned(3).")))
|
||||
(let
|
||||
((semi (dl-query db (list (quote d) (quote X))))
|
||||
(magic (dl-magic-query db (list (quote d) (quote X)))))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; Aggregate -> derived -> threshold chain via magic.
|
||||
(dl-mt-test! "magic aggregate-derived chain"
|
||||
(let
|
||||
((db (dl-program
|
||||
"src(1). src(2). src(3).
|
||||
cnt(N) :- count(N, X, src(X)).
|
||||
active(N) :- cnt(N), >=(N, 2).")))
|
||||
(let
|
||||
((semi (dl-query db (list (quote active) (quote N))))
|
||||
(magic (dl-magic-query db (list (quote active) (quote N)))))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; Multi-relation rewrite chain: query r4 → propagate to r3,
|
||||
;; r2, r1, a. The worklist must process all of them; an
|
||||
;; earlier bug stopped after only the head pair.
|
||||
(dl-mt-test! "magic chain through 4 rule levels"
|
||||
(let
|
||||
((db (dl-program
|
||||
"a(1). a(2). r1(X) :- a(X). r2(X) :- r1(X).
|
||||
r3(X) :- r2(X). r4(X) :- r3(X).")))
|
||||
(= 2 (len (dl-magic-query db (list (quote r4) (quote X))))))
|
||||
true)
|
||||
|
||||
;; Shortest-path demo via magic — exercises the rewriter
|
||||
;; against rules that mix recursive positive lits with an
|
||||
;; aggregate body literal.
|
||||
(dl-mt-test! "magic on shortest-path demo"
|
||||
(let
|
||||
((db (dl-program-data
|
||||
(quote ((edge a b 5) (edge b c 3) (edge a c 10)))
|
||||
dl-demo-shortest-path-rules)))
|
||||
(let
|
||||
((semi (dl-query db (quote (shortest a c W))))
|
||||
(magic (dl-magic-query db (quote (shortest a c W)))))
|
||||
(and (= (len semi) (len magic))
|
||||
(= (len semi) 1))))
|
||||
true)
|
||||
|
||||
;; Same relation called with different adornment patterns
|
||||
;; in different rules. The worklist must enqueue and process
|
||||
;; each (rel, adornment) pair.
|
||||
(dl-mt-test! "magic with multi-adornment same relation"
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(p1, alice). parent(p2, bob).
|
||||
parent(g, p1). parent(g, p2).
|
||||
sibling(P1, P2) :- parent(G, P1), parent(G, P2),
|
||||
!=(P1, P2).
|
||||
cousin(X, Y) :- parent(P1, X), parent(P2, Y),
|
||||
sibling(P1, P2).")))
|
||||
(let
|
||||
((semi (dl-query db (list (quote cousin) (quote alice) (quote Y))))
|
||||
(magic (dl-magic-query db (list (quote cousin) (quote alice) (quote Y)))))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; Magic over a rule whose body contains an aggregate.
|
||||
;; The rewriter passes aggregate body lits through unchanged
|
||||
;; (no propagation generated for them), so semi-naive's count
|
||||
;; logic still fires correctly under the rewritten program.
|
||||
(dl-mt-test! "magic over rule with aggregate body"
|
||||
(let
|
||||
((db (dl-program
|
||||
"post(p1). post(p2). post(p3).
|
||||
liked(u1, p1). liked(u2, p1). liked(u3, p1).
|
||||
liked(u1, p2).
|
||||
rich(P) :- post(P), count(N, U, liked(U, P)),
|
||||
>=(N, 2).")))
|
||||
(let
|
||||
((semi (dl-query db (list (quote rich) (quote P))))
|
||||
(magic (dl-magic-query db (list (quote rich) (quote P)))))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; Mixed EDB + IDB: a relation can be both EDB-seeded and
|
||||
;; rule-derived. dl-magic-query must include the EDB portion
|
||||
;; even though the relation has rules.
|
||||
(dl-mt-test! "magic mixed EDB+IDB"
|
||||
(len
|
||||
(dl-magic-query
|
||||
(dl-program
|
||||
"link(a, b). link(c, d). link(e, c).
|
||||
via(a, e).
|
||||
link(X, Y) :- via(X, M), link(M, Y).")
|
||||
(list (quote link) (quote a) (quote X))))
|
||||
2)
|
||||
|
||||
;; dl-magic-query falls back to dl-query for built-in,
|
||||
;; aggregate, and negation goals (the magic seed would
|
||||
;; otherwise be non-ground).
|
||||
(dl-mt-test! "magic-query falls back on aggregate"
|
||||
(let
|
||||
((r (dl-magic-query
|
||||
(dl-program "p(1). p(2). p(3).")
|
||||
(list (quote count) (quote N) (quote X)
|
||||
(list (quote p) (quote X))))))
|
||||
(and (= (len r) 1) (= (get (first r) "N") 3)))
|
||||
true)
|
||||
|
||||
(dl-mt-test! "magic-query equivalent to dl-query"
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(a, b). parent(b, c). parent(c, d).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(let
|
||||
((semi (dl-query db (list (quote ancestor) (quote a) (quote X))))
|
||||
(magic (dl-magic-query
|
||||
db (list (quote ancestor) (quote a) (quote X)))))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
;; The magic rewriter passes aggregate body lits through
|
||||
;; unchanged, so an aggregate over an IDB relation would see an
|
||||
;; empty inner-goal in the magic db unless the IDB is already
|
||||
;; materialised. dl-magic-query now pre-saturates the source db
|
||||
;; to guarantee equivalence with dl-query for every stratified
|
||||
;; program. Previously this returned `({:N 0})` because `active`
|
||||
;; (IDB, derived through negation) was never derived in the
|
||||
;; magic db.
|
||||
(dl-mt-test! "magic over aggregate-of-IDB matches vanilla"
|
||||
(let
|
||||
((src
|
||||
"u(a). u(b). u(c). u(d). banned(b). banned(d).
|
||||
active(X) :- u(X), not(banned(X)).
|
||||
n(N) :- count(N, X, active(X))."))
|
||||
(let
|
||||
((vanilla (dl-eval src "?- n(N)."))
|
||||
(magic (dl-eval-magic src "?- n(N).")))
|
||||
(and (= (len vanilla) 1)
|
||||
(= (len magic) 1)
|
||||
(= (get (first vanilla) "N")
|
||||
(get (first magic) "N")))))
|
||||
true)
|
||||
|
||||
;; magic-query doesn't mutate caller db.
|
||||
(dl-mt-test! "magic-query preserves caller db"
|
||||
(let
|
||||
((db (dl-program
|
||||
"parent(a, b). parent(b, c).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(let
|
||||
((rules-before (len (dl-rules db))))
|
||||
(do
|
||||
(dl-magic-query db (list (quote ancestor) (quote a) (quote X)))
|
||||
(= rules-before (len (dl-rules db))))))
|
||||
true)
|
||||
|
||||
;; Magic-sets benefit: query touches only one cluster of a
|
||||
;; multi-component graph. Semi-naive derives the full closure
|
||||
;; over both clusters; magic only the seeded one.
|
||||
;; Magic-vs-semi work shape: chain of 12. Semi-naive
|
||||
;; derives the full closure (78 = 12·13/2). A magic query
|
||||
;; rooted at node 0 returns the 12 descendants only —
|
||||
;; demonstrating that magic limits derivation to the
|
||||
;; query's transitive cone.
|
||||
(dl-mt-test! "magic vs semi work-shape on chain-12"
|
||||
(let
|
||||
((source (str
|
||||
"parent(0, 1). parent(1, 2). parent(2, 3). "
|
||||
"parent(3, 4). parent(4, 5). parent(5, 6). "
|
||||
"parent(6, 7). parent(7, 8). parent(8, 9). "
|
||||
"parent(9, 10). parent(10, 11). parent(11, 12). "
|
||||
"ancestor(X, Y) :- parent(X, Y). "
|
||||
"ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(let
|
||||
((db1 (dl-make-db)) (db2 (dl-make-db)))
|
||||
(do
|
||||
(dl-load-program! db1 source)
|
||||
(dl-saturate! db1)
|
||||
(dl-load-program! db2 source)
|
||||
(let
|
||||
((semi-count (len (dl-relation db1 "ancestor")))
|
||||
(magic-count
|
||||
(len (dl-magic-query
|
||||
db2 (list (quote ancestor) 0 (quote X))))))
|
||||
;; Magic returns only descendants of 0 (12 of them).
|
||||
(and (= semi-count 78) (= magic-count 12))))))
|
||||
true)
|
||||
|
||||
;; Magic + arithmetic: rules with `is` clauses pass through
|
||||
;; the rewriter unchanged (built-ins aren't propagated).
|
||||
(dl-mt-test! "magic preserves arithmetic"
|
||||
(let
|
||||
((source "n(1). n(2). n(3).
|
||||
doubled(X, Y) :- n(X), is(Y, *(X, 2))."))
|
||||
(let
|
||||
((semi (dl-eval source "?- doubled(2, Y)."))
|
||||
(magic (dl-eval-magic source "?- doubled(2, Y).")))
|
||||
(= (len semi) (len magic))))
|
||||
true)
|
||||
|
||||
(dl-mt-test! "magic skips irrelevant clusters"
|
||||
(let
|
||||
;; Two disjoint chains. Query is rooted in cluster 1.
|
||||
((db (dl-program
|
||||
"parent(a, b). parent(b, c).
|
||||
parent(x, y). parent(y, z).
|
||||
ancestor(X, Y) :- parent(X, Y).
|
||||
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(let
|
||||
((semi-count (len (dl-relation db "ancestor")))
|
||||
(magic-results
|
||||
(dl-magic-query
|
||||
db (list (quote ancestor) (quote a) (quote X)))))
|
||||
;; Semi-naive derives 6 (3 in each cluster). Magic
|
||||
;; gives 3 query results (a's reachable: b, c).
|
||||
(and (= semi-count 6) (= (len magic-results) 2)))))
|
||||
true)
|
||||
|
||||
(dl-mt-test! "magic-rewritten finds same answers"
|
||||
(let
|
||||
((rules
|
||||
(list
|
||||
{:head (list (quote ancestor) (quote X) (quote Y))
|
||||
:body (list (list (quote parent) (quote X) (quote Y)))}
|
||||
{:head (list (quote ancestor) (quote X) (quote Z))
|
||||
:body
|
||||
(list (list (quote parent) (quote X) (quote Y))
|
||||
(list (quote ancestor) (quote Y) (quote Z)))}))
|
||||
(edb (list
|
||||
(list (quote parent) (quote a) (quote b))
|
||||
(list (quote parent) (quote b) (quote c)))))
|
||||
(let
|
||||
((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
|
||||
(db (dl-make-db)))
|
||||
(do
|
||||
(for-each (fn (f) (dl-add-fact! db f)) edb)
|
||||
(dl-add-fact! db (get rewritten :seed))
|
||||
(for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
|
||||
(dl-saturate! db)
|
||||
(len (dl-query db (list (quote ancestor) (quote a) (quote X)))))))
|
||||
2))))
|
||||
|
||||
(define
|
||||
dl-magic-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-mt-pass 0)
|
||||
(set! dl-mt-fail 0)
|
||||
(set! dl-mt-failures (list))
|
||||
(dl-mt-run-all!)
|
||||
{:passed dl-mt-pass
|
||||
:failed dl-mt-fail
|
||||
:total (+ dl-mt-pass dl-mt-fail)
|
||||
:failures dl-mt-failures})))
|
||||
@@ -1,252 +0,0 @@
|
||||
;; lib/datalog/tests/negation.sx — stratified negation tests.
|
||||
|
||||
(define dl-nt-pass 0)
|
||||
(define dl-nt-fail 0)
|
||||
(define dl-nt-failures (list))
|
||||
|
||||
(define
|
||||
dl-nt-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-nt-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let ((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-nt-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-nt-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-nt-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-nt-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-nt-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i)))
|
||||
(not (dl-nt-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-nt-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-nt-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and
|
||||
(= (len a) (len b))
|
||||
(dl-nt-subset? a b)
|
||||
(dl-nt-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-nt-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-nt-contains? ys (first xs))) false)
|
||||
(else (dl-nt-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-nt-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-nt-deep=? (first xs) target) true)
|
||||
(else (dl-nt-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-nt-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-nt-deep=? got expected)
|
||||
(set! dl-nt-pass (+ dl-nt-pass 1))
|
||||
(do
|
||||
(set! dl-nt-fail (+ dl-nt-fail 1))
|
||||
(append!
|
||||
dl-nt-failures
|
||||
(str
|
||||
name
|
||||
"\n expected: " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-nt-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-nt-set=? got expected)
|
||||
(set! dl-nt-pass (+ dl-nt-pass 1))
|
||||
(do
|
||||
(set! dl-nt-fail (+ dl-nt-fail 1))
|
||||
(append!
|
||||
dl-nt-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): " expected
|
||||
"\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-nt-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do
|
||||
(guard
|
||||
(e (#t (set! threw true)))
|
||||
(thunk))
|
||||
threw))))
|
||||
|
||||
(define
|
||||
dl-nt-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
;; Negation against EDB-only relation.
|
||||
(dl-nt-test-set! "not against EDB"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(2). p(3). r(2).
|
||||
q(X) :- p(X), not(r(X)).")
|
||||
(list (quote q) (quote X)))
|
||||
(list {:X 1} {:X 3}))
|
||||
|
||||
;; Negation against derived relation — needs stratification.
|
||||
(dl-nt-test-set! "not against derived rel"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(2). p(3). s(2).
|
||||
r(X) :- s(X).
|
||||
q(X) :- p(X), not(r(X)).")
|
||||
(list (quote q) (quote X)))
|
||||
(list {:X 1} {:X 3}))
|
||||
|
||||
;; Two-step strata: r derives via s; q derives via not r.
|
||||
(dl-nt-test-set! "two-step strata"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"node(a). node(b). node(c). node(d).
|
||||
edge(a, b). edge(b, c). edge(c, a).
|
||||
reach(X, Y) :- edge(X, Y).
|
||||
reach(X, Z) :- edge(X, Y), reach(Y, Z).
|
||||
unreachable(X) :- node(X), not(reach(a, X)).")
|
||||
(list (quote unreachable) (quote X)))
|
||||
(list {:X (quote d)}))
|
||||
|
||||
;; Combine negation with arithmetic and comparison.
|
||||
(dl-nt-test-set! "negation with arithmetic"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3). n(4). n(5). odd(1). odd(3). odd(5).
|
||||
even(X) :- n(X), not(odd(X)).")
|
||||
(list (quote even) (quote X)))
|
||||
(list {:X 2} {:X 4}))
|
||||
|
||||
;; Empty negation result.
|
||||
(dl-nt-test-set! "negation always succeeds"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(2). q(X) :- p(X), not(r(X)).")
|
||||
(list (quote q) (quote X)))
|
||||
(list {:X 1} {:X 2}))
|
||||
|
||||
;; Negation always fails.
|
||||
(dl-nt-test-set! "negation always fails"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1). p(2). r(1). r(2). q(X) :- p(X), not(r(X)).")
|
||||
(list (quote q) (quote X)))
|
||||
(list))
|
||||
|
||||
;; Anonymous `_` in a negated literal is existentially quantified
|
||||
;; — it doesn't need to be bound by an earlier body lit. Without
|
||||
;; this exemption the safety check would reject the common idiom
|
||||
;; `orphan(X) :- person(X), not(parent(X, _))`.
|
||||
(dl-nt-test-set! "negation with anonymous var — orphan idiom"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"person(a). person(b). person(c). parent(a, b).
|
||||
orphan(X) :- person(X), not(parent(X, _)).")
|
||||
(list (quote orphan) (quote X)))
|
||||
(list {:X (quote b)} {:X (quote c)}))
|
||||
|
||||
;; Multiple anonymous vars are each independently existential.
|
||||
(dl-nt-test-set! "negation with multiple anonymous vars"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"u(a). u(b). u(c). edge(a, x). edge(b, y).
|
||||
solo(X) :- u(X), not(edge(X, _)).")
|
||||
(list (quote solo) (quote X)))
|
||||
(list {:X (quote c)}))
|
||||
|
||||
;; Stratifiability checks.
|
||||
(dl-nt-test! "non-stratifiable rejected"
|
||||
(dl-nt-throws?
|
||||
(fn ()
|
||||
(let ((db (dl-make-db)))
|
||||
(do
|
||||
(dl-add-rule!
|
||||
db
|
||||
{:head (list (quote p) (quote X))
|
||||
:body (list (list (quote q) (quote X))
|
||||
{:neg (list (quote r) (quote X))})})
|
||||
(dl-add-rule!
|
||||
db
|
||||
{:head (list (quote r) (quote X))
|
||||
:body (list (list (quote p) (quote X)))})
|
||||
(dl-add-fact! db (list (quote q) 1))
|
||||
(dl-saturate! db)))))
|
||||
true)
|
||||
|
||||
(dl-nt-test! "stratifiable accepted"
|
||||
(dl-nt-throws?
|
||||
(fn ()
|
||||
(dl-program
|
||||
"p(1). p(2). r(2).
|
||||
q(X) :- p(X), not(r(X)).")))
|
||||
false)
|
||||
|
||||
;; Multi-stratum chain.
|
||||
(dl-nt-test-set! "three-level strata"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"a(1). a(2). a(3). a(4).
|
||||
b(X) :- a(X), not(c(X)).
|
||||
c(X) :- d(X).
|
||||
d(2).
|
||||
d(4).")
|
||||
(list (quote b) (quote X)))
|
||||
(list {:X 1} {:X 3}))
|
||||
|
||||
;; Safety violation: negation refers to unbound var.
|
||||
(dl-nt-test! "negation safety violation"
|
||||
(dl-nt-throws?
|
||||
(fn ()
|
||||
(dl-program
|
||||
"p(1). q(X) :- p(X), not(r(Y)).")))
|
||||
true))))
|
||||
|
||||
(define
|
||||
dl-negation-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-nt-pass 0)
|
||||
(set! dl-nt-fail 0)
|
||||
(set! dl-nt-failures (list))
|
||||
(dl-nt-run-all!)
|
||||
{:passed dl-nt-pass
|
||||
:failed dl-nt-fail
|
||||
:total (+ dl-nt-pass dl-nt-fail)
|
||||
:failures dl-nt-failures})))
|
||||
@@ -1,179 +0,0 @@
|
||||
;; lib/datalog/tests/parse.sx — parser unit tests
|
||||
;;
|
||||
;; Run via: bash lib/datalog/conformance.sh
|
||||
;; Or: (load "lib/datalog/tokenizer.sx") (load "lib/datalog/parser.sx")
|
||||
;; (load "lib/datalog/tests/parse.sx") (dl-parse-tests-run!)
|
||||
|
||||
(define dl-pt-pass 0)
|
||||
(define dl-pt-fail 0)
|
||||
(define dl-pt-failures (list))
|
||||
|
||||
;; Order-independent structural equality. Lists compared positionally,
|
||||
;; dicts as sets of (key, value) pairs. Numbers via = (so 30.0 = 30).
|
||||
(define
|
||||
dl-deep-equal?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-deep-equal-list? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and
|
||||
(= (len ka) (len kb))
|
||||
(dl-deep-equal-dict? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-deep-equal-list?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-deep-equal? (nth a i) (nth b i))) false)
|
||||
(else (dl-deep-equal-list? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-deep-equal-dict?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-deep-equal? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-deep-equal-dict? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-pt-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-deep-equal? got expected)
|
||||
(set! dl-pt-pass (+ dl-pt-pass 1))
|
||||
(do
|
||||
(set! dl-pt-fail (+ dl-pt-fail 1))
|
||||
(append!
|
||||
dl-pt-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-pt-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
||||
|
||||
(define
|
||||
dl-pt-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-pt-test! "empty program" (dl-parse "") (list))
|
||||
(dl-pt-test! "fact" (dl-parse "parent(tom, bob).") (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))}))
|
||||
(dl-pt-test!
|
||||
"two facts"
|
||||
(dl-parse "parent(tom, bob). parent(bob, ann).")
|
||||
(list {:body (list) :head (list (quote parent) (quote tom) (quote bob))} {:body (list) :head (list (quote parent) (quote bob) (quote ann))}))
|
||||
(dl-pt-test! "zero-ary fact" (dl-parse "ready.") (list {:body (list) :head (list (quote ready))}))
|
||||
(dl-pt-test!
|
||||
"rule one body lit"
|
||||
(dl-parse "ancestor(X, Y) :- parent(X, Y).")
|
||||
(list {:body (list (list (quote parent) (quote X) (quote Y))) :head (list (quote ancestor) (quote X) (quote Y))}))
|
||||
(dl-pt-test!
|
||||
"recursive rule"
|
||||
(dl-parse "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
||||
(list {:body (list (list (quote parent) (quote X) (quote Y)) (list (quote ancestor) (quote Y) (quote Z))) :head (list (quote ancestor) (quote X) (quote Z))}))
|
||||
(dl-pt-test!
|
||||
"query single"
|
||||
(dl-parse "?- ancestor(tom, X).")
|
||||
(list {:query (list (list (quote ancestor) (quote tom) (quote X)))}))
|
||||
(dl-pt-test!
|
||||
"query multi"
|
||||
(dl-parse "?- p(X), q(X).")
|
||||
(list {:query (list (list (quote p) (quote X)) (list (quote q) (quote X)))}))
|
||||
(dl-pt-test!
|
||||
"negation"
|
||||
(dl-parse "safe(X) :- person(X), not(parent(X, _)).")
|
||||
(list {:body (list (list (quote person) (quote X)) {:neg (list (quote parent) (quote X) (quote _))}) :head (list (quote safe) (quote X))}))
|
||||
(dl-pt-test!
|
||||
"number arg"
|
||||
(dl-parse "age(alice, 30).")
|
||||
(list {:body (list) :head (list (quote age) (quote alice) 30)}))
|
||||
(dl-pt-test!
|
||||
"string arg"
|
||||
(dl-parse "label(x, \"hi\").")
|
||||
(list {:body (list) :head (list (quote label) (quote x) "hi")}))
|
||||
;; Quoted 'atoms' parse as strings — a uppercase-starting name
|
||||
;; in quotes used to misclassify as a variable and reject the
|
||||
;; fact as non-ground.
|
||||
(dl-pt-test!
|
||||
"quoted atom arg parses as string"
|
||||
(dl-parse "p('Hello World').")
|
||||
(list {:body (list) :head (list (quote p) "Hello World")}))
|
||||
(dl-pt-test!
|
||||
"comparison literal"
|
||||
(dl-parse "p(X) :- <(X, 5).")
|
||||
(list {:body (list (list (string->symbol "<") (quote X) 5)) :head (list (quote p) (quote X))}))
|
||||
(dl-pt-test!
|
||||
"is with arith"
|
||||
(dl-parse "succ(X, Y) :- nat(X), is(Y, +(X, 1)).")
|
||||
(list {:body (list (list (quote nat) (quote X)) (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1))) :head (list (quote succ) (quote X) (quote Y))}))
|
||||
(dl-pt-test!
|
||||
"mixed program"
|
||||
(dl-parse "p(a). p(b). q(X) :- p(X). ?- q(Y).")
|
||||
(list {:body (list) :head (list (quote p) (quote a))} {:body (list) :head (list (quote p) (quote b))} {:body (list (list (quote p) (quote X))) :head (list (quote q) (quote X))} {:query (list (list (quote q) (quote Y)))}))
|
||||
(dl-pt-test!
|
||||
"comments skipped"
|
||||
(dl-parse "% comment\nfoo(a).\n/* block */ bar(b).")
|
||||
(list {:body (list) :head (list (quote foo) (quote a))} {:body (list) :head (list (quote bar) (quote b))}))
|
||||
(dl-pt-test!
|
||||
"underscore var"
|
||||
(dl-parse "p(X) :- q(X, _).")
|
||||
(list {:body (list (list (quote q) (quote X) (quote _))) :head (list (quote p) (quote X))}))
|
||||
;; Negative number literals parse as one negative number,
|
||||
;; while subtraction (`-(X, Y)`) compound is preserved.
|
||||
(dl-pt-test!
|
||||
"negative integer literal"
|
||||
(dl-parse "n(-3).")
|
||||
(list {:head (list (quote n) -3) :body (list)}))
|
||||
|
||||
(dl-pt-test!
|
||||
"subtraction compound preserved"
|
||||
(dl-parse "r(X) :- is(X, -(10, 3)).")
|
||||
(list
|
||||
{:head (list (quote r) (quote X))
|
||||
:body (list (list (quote is) (quote X)
|
||||
(list (string->symbol "-") 10 3)))}))
|
||||
|
||||
(dl-pt-test!
|
||||
"number as relation name raises"
|
||||
(dl-pt-throws? (fn () (dl-parse "1(X) :- p(X).")))
|
||||
true)
|
||||
|
||||
(dl-pt-test!
|
||||
"var as relation name raises"
|
||||
(dl-pt-throws? (fn () (dl-parse "P(X).")))
|
||||
true)
|
||||
|
||||
(dl-pt-test!
|
||||
"missing dot raises"
|
||||
(dl-pt-throws? (fn () (dl-parse "p(a)")))
|
||||
true)
|
||||
(dl-pt-test!
|
||||
"trailing comma raises"
|
||||
(dl-pt-throws? (fn () (dl-parse "p(a,).")))
|
||||
true))))
|
||||
|
||||
(define
|
||||
dl-parse-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-pt-pass 0)
|
||||
(set! dl-pt-fail 0)
|
||||
(set! dl-pt-failures (list))
|
||||
(dl-pt-run-all!)
|
||||
{:failures dl-pt-failures :total (+ dl-pt-pass dl-pt-fail) :passed dl-pt-pass :failed dl-pt-fail})))
|
||||
@@ -1,153 +0,0 @@
|
||||
;; lib/datalog/tests/semi_naive.sx — semi-naive correctness vs naive.
|
||||
;;
|
||||
;; Strategy: differential — run both saturators on each program and
|
||||
;; compare the resulting per-relation tuple counts. Counting (not
|
||||
;; element-wise set equality) keeps the suite fast under the bundled
|
||||
;; conformance session; correctness on the inhabitants is covered by
|
||||
;; eval.sx and builtins.sx (which use dl-saturate! by default — the
|
||||
;; semi-naive saturator).
|
||||
|
||||
(define dl-sn-pass 0)
|
||||
(define dl-sn-fail 0)
|
||||
(define dl-sn-failures (list))
|
||||
|
||||
(define
|
||||
dl-sn-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(equal? got expected)
|
||||
(set! dl-sn-pass (+ dl-sn-pass 1))
|
||||
(do
|
||||
(set! dl-sn-fail (+ dl-sn-fail 1))
|
||||
(append!
|
||||
dl-sn-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
;; Load `source` into both a semi-naive and a naive db and return a
|
||||
;; list of (rel-name semi-count naive-count) triples. Both sets must
|
||||
;; have the same union of relation names.
|
||||
(define
|
||||
dl-sn-counts
|
||||
(fn
|
||||
(source)
|
||||
(let
|
||||
((db-s (dl-program source)) (db-n (dl-program source)))
|
||||
(do
|
||||
(dl-saturate! db-s)
|
||||
(dl-saturate-naive! db-n)
|
||||
(let
|
||||
((out (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(append!
|
||||
out
|
||||
(list
|
||||
k
|
||||
(len (dl-relation db-s k))
|
||||
(len (dl-relation db-n k)))))
|
||||
(keys (get db-s :facts)))
|
||||
out))))))
|
||||
|
||||
(define
|
||||
dl-sn-counts-agree?
|
||||
(fn
|
||||
(counts)
|
||||
(cond
|
||||
((= (len counts) 0) true)
|
||||
(else
|
||||
(let
|
||||
((row (first counts)))
|
||||
(and
|
||||
(= (nth row 1) (nth row 2))
|
||||
(dl-sn-counts-agree? (rest counts))))))))
|
||||
|
||||
(define
|
||||
dl-sn-chain-source
|
||||
(fn
|
||||
(n)
|
||||
(let
|
||||
((parts (list "")))
|
||||
(do
|
||||
(define
|
||||
dl-sn-loop
|
||||
(fn
|
||||
(i)
|
||||
(when
|
||||
(< i n)
|
||||
(do
|
||||
(append! parts (str "parent(" i ", " (+ i 1) "). "))
|
||||
(dl-sn-loop (+ i 1))))))
|
||||
(dl-sn-loop 0)
|
||||
(str
|
||||
(join "" parts)
|
||||
"ancestor(X, Y) :- parent(X, Y). "
|
||||
"ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))))
|
||||
|
||||
(define
|
||||
dl-sn-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-sn-test!
|
||||
"ancestor closure counts match"
|
||||
(dl-sn-counts-agree?
|
||||
(dl-sn-counts
|
||||
"parent(a, b). parent(b, c). parent(c, d).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
|
||||
true)
|
||||
(dl-sn-test!
|
||||
"cyclic reach counts match"
|
||||
(dl-sn-counts-agree?
|
||||
(dl-sn-counts
|
||||
"edge(1, 2). edge(2, 3). edge(3, 1). edge(3, 4).\n reach(X, Y) :- edge(X, Y).\n reach(X, Z) :- edge(X, Y), reach(Y, Z)."))
|
||||
true)
|
||||
(dl-sn-test!
|
||||
"same-gen counts match"
|
||||
(dl-sn-counts-agree?
|
||||
(dl-sn-counts
|
||||
"parent(a, b). parent(a, c). parent(b, d). parent(c, e).\n person(a). person(b). person(c). person(d). person(e).\n sg(X, X) :- person(X).\n sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y)."))
|
||||
true)
|
||||
(dl-sn-test!
|
||||
"rules with builtins counts match"
|
||||
(dl-sn-counts-agree?
|
||||
(dl-sn-counts
|
||||
"n(1). n(2). n(3). n(4). n(5).\n small(X) :- n(X), <(X, 5).\n succ(X, Y) :- n(X), <(X, 5), is(Y, +(X, 1))."))
|
||||
true)
|
||||
(dl-sn-test!
|
||||
"static rule fires under semi-naive"
|
||||
(dl-sn-counts-agree?
|
||||
(dl-sn-counts "p(a). p(b). q(X) :- p(X), =(X, a)."))
|
||||
true)
|
||||
;; Chain length 12 — multiple semi-naive iterations against
|
||||
;; the recursive ancestor rule (differential vs naive).
|
||||
(dl-sn-test!
|
||||
"chain-12 ancestor counts match"
|
||||
(dl-sn-counts-agree? (dl-sn-counts (dl-sn-chain-source 12)))
|
||||
true)
|
||||
;; Chain length 25 — semi-naive only — first-arg index makes
|
||||
;; this tractable in conformance budget.
|
||||
(dl-sn-test!
|
||||
"chain-25 ancestor count value (semi only)"
|
||||
(let
|
||||
((db (dl-program (dl-sn-chain-source 25))))
|
||||
(do (dl-saturate! db) (len (dl-relation db "ancestor"))))
|
||||
325)
|
||||
(dl-sn-test!
|
||||
"query through semi saturate"
|
||||
(let
|
||||
((db (dl-program "parent(a, b). parent(b, c).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(len (dl-query db (list (quote ancestor) (quote a) (quote X)))))
|
||||
2))))
|
||||
|
||||
(define
|
||||
dl-semi-naive-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-sn-pass 0)
|
||||
(set! dl-sn-fail 0)
|
||||
(set! dl-sn-failures (list))
|
||||
(dl-sn-run-all!)
|
||||
{:failures dl-sn-failures :total (+ dl-sn-pass dl-sn-fail) :passed dl-sn-pass :failed dl-sn-fail})))
|
||||
@@ -1,189 +0,0 @@
|
||||
;; lib/datalog/tests/tokenize.sx — tokenizer unit tests
|
||||
;;
|
||||
;; Run via: bash lib/datalog/conformance.sh
|
||||
;; Or: (load "lib/datalog/tokenizer.sx") (load "lib/datalog/tests/tokenize.sx")
|
||||
;; (dl-tokenize-tests-run!)
|
||||
|
||||
(define dl-tk-pass 0)
|
||||
(define dl-tk-fail 0)
|
||||
(define dl-tk-failures (list))
|
||||
|
||||
(define
|
||||
dl-tk-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! dl-tk-pass (+ dl-tk-pass 1))
|
||||
(do
|
||||
(set! dl-tk-fail (+ dl-tk-fail 1))
|
||||
(append!
|
||||
dl-tk-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define dl-tk-types (fn (toks) (map (fn (t) (get t :type)) toks)))
|
||||
(define dl-tk-values (fn (toks) (map (fn (t) (get t :value)) toks)))
|
||||
|
||||
(define
|
||||
dl-tk-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-tk-test! "empty" (dl-tk-types (dl-tokenize "")) (list "eof"))
|
||||
(dl-tk-test!
|
||||
"atom dot"
|
||||
(dl-tk-types (dl-tokenize "foo."))
|
||||
(list "atom" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"atom dot value"
|
||||
(dl-tk-values (dl-tokenize "foo."))
|
||||
(list "foo" "." nil))
|
||||
(dl-tk-test!
|
||||
"var"
|
||||
(dl-tk-types (dl-tokenize "X."))
|
||||
(list "var" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"underscore var"
|
||||
(dl-tk-types (dl-tokenize "_x."))
|
||||
(list "var" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"integer"
|
||||
(dl-tk-values (dl-tokenize "42"))
|
||||
(list 42 nil))
|
||||
(dl-tk-test!
|
||||
"decimal"
|
||||
(dl-tk-values (dl-tokenize "3.14"))
|
||||
(list 3.14 nil))
|
||||
(dl-tk-test!
|
||||
"string"
|
||||
(dl-tk-values (dl-tokenize "\"hello\""))
|
||||
(list "hello" nil))
|
||||
;; Quoted 'atoms' tokenize as strings — see the type-table
|
||||
;; comment in lib/datalog/tokenizer.sx for the rationale.
|
||||
(dl-tk-test!
|
||||
"quoted atom as string"
|
||||
(dl-tk-types (dl-tokenize "'two words'"))
|
||||
(list "string" "eof"))
|
||||
(dl-tk-test!
|
||||
"quoted atom value"
|
||||
(dl-tk-values (dl-tokenize "'two words'"))
|
||||
(list "two words" nil))
|
||||
;; A quoted atom whose name would otherwise be a variable
|
||||
;; (uppercase / leading underscore) is now safely a string —
|
||||
;; this was the bug that motivated the type change.
|
||||
(dl-tk-test!
|
||||
"quoted Uppercase as string"
|
||||
(dl-tk-types (dl-tokenize "'Hello'"))
|
||||
(list "string" "eof"))
|
||||
(dl-tk-test! ":-" (dl-tk-values (dl-tokenize ":-")) (list ":-" nil))
|
||||
(dl-tk-test! "?-" (dl-tk-values (dl-tokenize "?-")) (list "?-" nil))
|
||||
(dl-tk-test! "<=" (dl-tk-values (dl-tokenize "<=")) (list "<=" nil))
|
||||
(dl-tk-test! ">=" (dl-tk-values (dl-tokenize ">=")) (list ">=" nil))
|
||||
(dl-tk-test! "!=" (dl-tk-values (dl-tokenize "!=")) (list "!=" nil))
|
||||
(dl-tk-test!
|
||||
"single op values"
|
||||
(dl-tk-values (dl-tokenize "< > = + - * /"))
|
||||
(list "<" ">" "=" "+" "-" "*" "/" nil))
|
||||
(dl-tk-test!
|
||||
"single op types"
|
||||
(dl-tk-types (dl-tokenize "< > = + - * /"))
|
||||
(list "op" "op" "op" "op" "op" "op" "op" "eof"))
|
||||
(dl-tk-test!
|
||||
"punct"
|
||||
(dl-tk-values (dl-tokenize "( ) , ."))
|
||||
(list "(" ")" "," "." nil))
|
||||
(dl-tk-test!
|
||||
"fact tokens"
|
||||
(dl-tk-types (dl-tokenize "parent(tom, bob)."))
|
||||
(list "atom" "punct" "atom" "punct" "atom" "punct" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"rule shape"
|
||||
(dl-tk-types (dl-tokenize "p(X) :- q(X)."))
|
||||
(list
|
||||
"atom"
|
||||
"punct"
|
||||
"var"
|
||||
"punct"
|
||||
"op"
|
||||
"atom"
|
||||
"punct"
|
||||
"var"
|
||||
"punct"
|
||||
"punct"
|
||||
"eof"))
|
||||
(dl-tk-test!
|
||||
"comparison literal"
|
||||
(dl-tk-values (dl-tokenize "<(X, 5)"))
|
||||
(list "<" "(" "X" "," 5 ")" nil))
|
||||
(dl-tk-test!
|
||||
"is form"
|
||||
(dl-tk-values (dl-tokenize "is(Y, +(X, 1))"))
|
||||
(list "is" "(" "Y" "," "+" "(" "X" "," 1 ")" ")" nil))
|
||||
(dl-tk-test!
|
||||
"line comment"
|
||||
(dl-tk-types (dl-tokenize "% comment line\nfoo."))
|
||||
(list "atom" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"block comment"
|
||||
(dl-tk-types (dl-tokenize "/* a\nb */ x."))
|
||||
(list "atom" "punct" "eof"))
|
||||
;; Unexpected characters surface at tokenize time rather
|
||||
;; than being silently consumed (previously `?(X)` parsed as
|
||||
;; if the leading `?` weren't there).
|
||||
(dl-tk-test!
|
||||
"unexpected char raises"
|
||||
(let ((threw false))
|
||||
(do
|
||||
(guard (e (#t (set! threw true)))
|
||||
(dl-tokenize "?(X)"))
|
||||
threw))
|
||||
true)
|
||||
|
||||
;; Unterminated string / quoted-atom must raise.
|
||||
(dl-tk-test!
|
||||
"unterminated string raises"
|
||||
(let ((threw false))
|
||||
(do
|
||||
(guard (e (#t (set! threw true)))
|
||||
(dl-tokenize "\"unclosed"))
|
||||
threw))
|
||||
true)
|
||||
|
||||
(dl-tk-test!
|
||||
"unterminated quoted atom raises"
|
||||
(let ((threw false))
|
||||
(do
|
||||
(guard (e (#t (set! threw true)))
|
||||
(dl-tokenize "'unclosed"))
|
||||
threw))
|
||||
true)
|
||||
|
||||
;; Unterminated block comment must raise — previously it was
|
||||
;; silently consumed to EOF.
|
||||
(dl-tk-test!
|
||||
"unterminated block comment raises"
|
||||
(let ((threw false))
|
||||
(do
|
||||
(guard (e (#t (set! threw true)))
|
||||
(dl-tokenize "/* unclosed comment"))
|
||||
threw))
|
||||
true)
|
||||
(dl-tk-test!
|
||||
"whitespace"
|
||||
(dl-tk-types (dl-tokenize " foo ,\t bar ."))
|
||||
(list "atom" "punct" "atom" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"positions"
|
||||
(map (fn (t) (get t :pos)) (dl-tokenize "foo bar"))
|
||||
(list 0 4 7)))))
|
||||
|
||||
(define
|
||||
dl-tokenize-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-tk-pass 0)
|
||||
(set! dl-tk-fail 0)
|
||||
(set! dl-tk-failures (list))
|
||||
(dl-tk-run-all!)
|
||||
{:failures dl-tk-failures :total (+ dl-tk-pass dl-tk-fail) :passed dl-tk-pass :failed dl-tk-fail})))
|
||||
@@ -1,194 +0,0 @@
|
||||
;; lib/datalog/tests/unify.sx — unification + substitution tests.
|
||||
|
||||
(define dl-ut-pass 0)
|
||||
(define dl-ut-fail 0)
|
||||
(define dl-ut-failures (list))
|
||||
|
||||
(define
|
||||
dl-ut-deep-equal?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-ut-deq-list? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-ut-deq-dict? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-ut-deq-list?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-ut-deep-equal? (nth a i) (nth b i))) false)
|
||||
(else (dl-ut-deq-list? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-ut-deq-dict?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-ut-deep-equal? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-ut-deq-dict? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-ut-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-ut-deep-equal? got expected)
|
||||
(set! dl-ut-pass (+ dl-ut-pass 1))
|
||||
(do
|
||||
(set! dl-ut-fail (+ dl-ut-fail 1))
|
||||
(append!
|
||||
dl-ut-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-ut-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-ut-test! "var? uppercase" (dl-var? (quote X)) true)
|
||||
(dl-ut-test! "var? underscore" (dl-var? (quote _foo)) true)
|
||||
(dl-ut-test! "var? lowercase" (dl-var? (quote tom)) false)
|
||||
(dl-ut-test! "var? number" (dl-var? 5) false)
|
||||
(dl-ut-test! "var? string" (dl-var? "hi") false)
|
||||
(dl-ut-test! "var? list" (dl-var? (list 1)) false)
|
||||
(dl-ut-test!
|
||||
"atom-atom match"
|
||||
(dl-unify (quote tom) (quote tom) (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test!
|
||||
"atom-atom fail"
|
||||
(dl-unify (quote tom) (quote bob) (dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"num-num match"
|
||||
(dl-unify 5 5 (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test!
|
||||
"num-num fail"
|
||||
(dl-unify 5 6 (dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"string match"
|
||||
(dl-unify "hi" "hi" (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test! "string fail" (dl-unify "hi" "bye" (dl-empty-subst)) nil)
|
||||
(dl-ut-test!
|
||||
"var-atom binds"
|
||||
(dl-unify (quote X) (quote tom) (dl-empty-subst))
|
||||
{:X (quote tom)})
|
||||
(dl-ut-test!
|
||||
"atom-var binds"
|
||||
(dl-unify (quote tom) (quote X) (dl-empty-subst))
|
||||
{:X (quote tom)})
|
||||
(dl-ut-test!
|
||||
"var-var same"
|
||||
(dl-unify (quote X) (quote X) (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test!
|
||||
"var-var bind"
|
||||
(let
|
||||
((s (dl-unify (quote X) (quote Y) (dl-empty-subst))))
|
||||
(dl-walk (quote X) s))
|
||||
(quote Y))
|
||||
(dl-ut-test!
|
||||
"tuple match"
|
||||
(dl-unify
|
||||
(list (quote parent) (quote X) (quote bob))
|
||||
(list (quote parent) (quote tom) (quote Y))
|
||||
(dl-empty-subst))
|
||||
{:X (quote tom) :Y (quote bob)})
|
||||
(dl-ut-test!
|
||||
"tuple arity mismatch"
|
||||
(dl-unify
|
||||
(list (quote p) (quote X))
|
||||
(list (quote p) (quote a) (quote b))
|
||||
(dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"tuple head mismatch"
|
||||
(dl-unify
|
||||
(list (quote p) (quote X))
|
||||
(list (quote q) (quote X))
|
||||
(dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"walk chain"
|
||||
(let
|
||||
((s1 (dl-unify (quote X) (quote Y) (dl-empty-subst))))
|
||||
(let
|
||||
((s2 (dl-unify (quote Y) (quote tom) s1)))
|
||||
(dl-walk (quote X) s2)))
|
||||
(quote tom))
|
||||
|
||||
;; Walk with circular substitution must not infinite-loop.
|
||||
;; Cycles return the current term unchanged.
|
||||
(dl-ut-test!
|
||||
"walk circular subst no hang"
|
||||
(let ((s (dl-bind (quote B) (quote A)
|
||||
(dl-bind (quote A) (quote B) (dl-empty-subst)))))
|
||||
(dl-walk (quote A) s))
|
||||
(quote A))
|
||||
(dl-ut-test!
|
||||
"apply subst on tuple"
|
||||
(let
|
||||
((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
|
||||
(dl-apply-subst (list (quote parent) (quote X) (quote Y)) s))
|
||||
(list (quote parent) (quote tom) (quote Y)))
|
||||
(dl-ut-test!
|
||||
"ground? all const"
|
||||
(dl-ground?
|
||||
(list (quote p) (quote tom) 5)
|
||||
(dl-empty-subst))
|
||||
true)
|
||||
(dl-ut-test!
|
||||
"ground? unbound var"
|
||||
(dl-ground? (list (quote p) (quote X)) (dl-empty-subst))
|
||||
false)
|
||||
(dl-ut-test!
|
||||
"ground? bound var"
|
||||
(let
|
||||
((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
|
||||
(dl-ground? (list (quote p) (quote X)) s))
|
||||
true)
|
||||
(dl-ut-test!
|
||||
"ground? bare var"
|
||||
(dl-ground? (quote X) (dl-empty-subst))
|
||||
false)
|
||||
(dl-ut-test!
|
||||
"vars-of basic"
|
||||
(dl-vars-of
|
||||
(list (quote p) (quote X) (quote tom) (quote Y) (quote X)))
|
||||
(list "X" "Y"))
|
||||
(dl-ut-test!
|
||||
"vars-of ground"
|
||||
(dl-vars-of (list (quote p) (quote tom) (quote bob)))
|
||||
(list))
|
||||
(dl-ut-test!
|
||||
"vars-of nested compound"
|
||||
(dl-vars-of
|
||||
(list
|
||||
(quote is)
|
||||
(quote Z)
|
||||
(list (string->symbol "+") (quote X) 1)))
|
||||
(list "Z" "X")))))
|
||||
|
||||
(define
|
||||
dl-unify-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-ut-pass 0)
|
||||
(set! dl-ut-fail 0)
|
||||
(set! dl-ut-failures (list))
|
||||
(dl-ut-run-all!)
|
||||
{:failures dl-ut-failures :total (+ dl-ut-pass dl-ut-fail) :passed dl-ut-pass :failed dl-ut-fail})))
|
||||
@@ -1,269 +0,0 @@
|
||||
;; lib/datalog/tokenizer.sx — Datalog source → token stream
|
||||
;;
|
||||
;; Tokens: {:type T :value V :pos P}
|
||||
;; Types:
|
||||
;; "atom" — lowercase-start bare identifier
|
||||
;; "var" — uppercase-start or _-start ident (value is the name)
|
||||
;; "number" — numeric literal (decoded to number)
|
||||
;; "string" — "..." string literal OR quoted 'atom' (treated as a
|
||||
;; string value to avoid the var-vs-atom ambiguity that
|
||||
;; would arise from a quoted atom whose name starts with
|
||||
;; an uppercase letter or underscore)
|
||||
;; "punct" — ( ) , .
|
||||
;; "op" — :- ?- <= >= != < > = + - * /
|
||||
;; "eof"
|
||||
;;
|
||||
;; Datalog has no function symbols in arg position; the parser still
|
||||
;; accepts nested compounds for arithmetic ((is X (+ A B))) but safety
|
||||
;; analysis rejects non-arithmetic nesting at rule-load time.
|
||||
|
||||
(define dl-make-token (fn (type value pos) {:type type :value value :pos pos}))
|
||||
|
||||
(define dl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
|
||||
(define dl-lower? (fn (c) (and (>= c "a") (<= c "z"))))
|
||||
(define dl-upper? (fn (c) (and (>= c "A") (<= c "Z"))))
|
||||
|
||||
(define
|
||||
dl-ident-char?
|
||||
(fn (c) (or (dl-lower? c) (dl-upper? c) (dl-digit? c) (= c "_"))))
|
||||
|
||||
(define dl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
dl-tokenize
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define
|
||||
dl-peek
|
||||
(fn
|
||||
(offset)
|
||||
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||
(define cur (fn () (dl-peek 0)))
|
||||
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define
|
||||
at?
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((sl (len s)))
|
||||
(and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
|
||||
(define
|
||||
dl-emit!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (dl-make-token type value start))))
|
||||
(define
|
||||
skip-line-comment!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (not (= (cur) "\n")))
|
||||
(do (advance! 1) (skip-line-comment!)))))
|
||||
(define
|
||||
skip-block-comment!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len)
|
||||
(error (str "Tokenizer: unterminated block comment "
|
||||
"(started at position " pos ")")))
|
||||
((and (= (cur) "*") (< (+ pos 1) src-len) (= (dl-peek 1) "/"))
|
||||
(advance! 2))
|
||||
(else (do (advance! 1) (skip-block-comment!))))))
|
||||
(define
|
||||
skip-ws!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((dl-ws? (cur)) (do (advance! 1) (skip-ws!)))
|
||||
((= (cur) "%")
|
||||
(do (advance! 1) (skip-line-comment!) (skip-ws!)))
|
||||
((and (= (cur) "/") (< (+ pos 1) src-len) (= (dl-peek 1) "*"))
|
||||
(do (advance! 2) (skip-block-comment!) (skip-ws!)))
|
||||
(else nil))))
|
||||
(define
|
||||
read-ident
|
||||
(fn
|
||||
(start)
|
||||
(do
|
||||
(when
|
||||
(and (< pos src-len) (dl-ident-char? (cur)))
|
||||
(do (advance! 1) (read-ident start)))
|
||||
(slice src start pos))))
|
||||
(define
|
||||
read-decimal-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (dl-digit? (cur)))
|
||||
(do (advance! 1) (read-decimal-digits!)))))
|
||||
(define
|
||||
read-number
|
||||
(fn
|
||||
(start)
|
||||
(do
|
||||
(read-decimal-digits!)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(= (cur) ".")
|
||||
(< (+ pos 1) src-len)
|
||||
(dl-digit? (dl-peek 1)))
|
||||
(do (advance! 1) (read-decimal-digits!)))
|
||||
(parse-number (slice src start pos)))))
|
||||
(define
|
||||
read-quoted
|
||||
(fn
|
||||
(quote-char)
|
||||
(let
|
||||
((chars (list)))
|
||||
(advance! 1)
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len)
|
||||
(error
|
||||
(str "Tokenizer: unterminated "
|
||||
(if (= quote-char "'") "quoted atom" "string")
|
||||
" (started near position " pos ")")))
|
||||
((= (cur) "\\")
|
||||
(do
|
||||
(advance! 1)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((ch (cur)))
|
||||
(do
|
||||
(cond
|
||||
((= ch "n") (append! chars "\n"))
|
||||
((= ch "t") (append! chars "\t"))
|
||||
((= ch "r") (append! chars "\r"))
|
||||
((= ch "\\") (append! chars "\\"))
|
||||
((= ch "'") (append! chars "'"))
|
||||
((= ch "\"") (append! chars "\""))
|
||||
(else (append! chars ch)))
|
||||
(advance! 1))))
|
||||
(loop)))
|
||||
((= (cur) quote-char) (advance! 1))
|
||||
(else
|
||||
(do (append! chars (cur)) (advance! 1) (loop))))))
|
||||
(loop)
|
||||
(join "" chars))))
|
||||
(define
|
||||
scan!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(skip-ws!)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((ch (cur)) (start pos))
|
||||
(cond
|
||||
((at? ":-")
|
||||
(do
|
||||
(dl-emit! "op" ":-" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? "?-")
|
||||
(do
|
||||
(dl-emit! "op" "?-" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? "<=")
|
||||
(do
|
||||
(dl-emit! "op" "<=" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? ">=")
|
||||
(do
|
||||
(dl-emit! "op" ">=" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? "!=")
|
||||
(do
|
||||
(dl-emit! "op" "!=" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((dl-digit? ch)
|
||||
(do
|
||||
(dl-emit! "number" (read-number start) start)
|
||||
(scan!)))
|
||||
((= ch "'")
|
||||
;; Quoted 'atoms' tokenize as strings so a name
|
||||
;; like 'Hello World' doesn't get misclassified
|
||||
;; as a variable by dl-var? (which inspects the
|
||||
;; symbol's first character).
|
||||
(do (dl-emit! "string" (read-quoted "'") start) (scan!)))
|
||||
((= ch "\"")
|
||||
(do (dl-emit! "string" (read-quoted "\"") start) (scan!)))
|
||||
((dl-lower? ch)
|
||||
(do (dl-emit! "atom" (read-ident start) start) (scan!)))
|
||||
((or (dl-upper? ch) (= ch "_"))
|
||||
(do (dl-emit! "var" (read-ident start) start) (scan!)))
|
||||
((= ch "(")
|
||||
(do
|
||||
(dl-emit! "punct" "(" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ")")
|
||||
(do
|
||||
(dl-emit! "punct" ")" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ",")
|
||||
(do
|
||||
(dl-emit! "punct" "," start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ".")
|
||||
(do
|
||||
(dl-emit! "punct" "." start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "<")
|
||||
(do
|
||||
(dl-emit! "op" "<" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ">")
|
||||
(do
|
||||
(dl-emit! "op" ">" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "=")
|
||||
(do
|
||||
(dl-emit! "op" "=" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "+")
|
||||
(do
|
||||
(dl-emit! "op" "+" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "-")
|
||||
(do
|
||||
(dl-emit! "op" "-" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "*")
|
||||
(do
|
||||
(dl-emit! "op" "*" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "/")
|
||||
(do
|
||||
(dl-emit! "op" "/" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
(else (error
|
||||
(str "Tokenizer: unexpected character '" ch
|
||||
"' at position " start)))))))))
|
||||
(scan!)
|
||||
(dl-emit! "eof" nil pos)
|
||||
tokens)))
|
||||
@@ -1,171 +0,0 @@
|
||||
;; lib/datalog/unify.sx — unification + substitution for Datalog terms.
|
||||
;;
|
||||
;; Term taxonomy (after parsing):
|
||||
;; variable — SX symbol whose first char is uppercase A–Z or '_'.
|
||||
;; constant — SX symbol whose first char is lowercase a–z (atom name).
|
||||
;; number — numeric literal.
|
||||
;; string — string literal.
|
||||
;; compound — SX list (functor arg ... arg). In core Datalog these
|
||||
;; only appear as arithmetic expressions (see Phase 4
|
||||
;; safety analysis); compound-against-compound unification
|
||||
;; is supported anyway for completeness.
|
||||
;;
|
||||
;; Substitutions are immutable dicts keyed by variable name (string).
|
||||
;; A failed unification returns nil; success returns the extended subst.
|
||||
|
||||
(define dl-empty-subst (fn () {}))
|
||||
|
||||
(define
|
||||
dl-var?
|
||||
(fn
|
||||
(term)
|
||||
(and
|
||||
(symbol? term)
|
||||
(let
|
||||
((name (symbol->string term)))
|
||||
(and
|
||||
(> (len name) 0)
|
||||
(let
|
||||
((c (slice name 0 1)))
|
||||
(or (and (>= c "A") (<= c "Z")) (= c "_"))))))))
|
||||
|
||||
;; Walk: chase variable bindings until we hit a non-variable or an unbound
|
||||
;; variable. The result is either a non-variable term or an unbound var.
|
||||
(define
|
||||
dl-walk
|
||||
(fn (term subst) (dl-walk-aux term subst (list))))
|
||||
|
||||
;; Internal: walk with a visited-var set so circular substitutions
|
||||
;; (from raw dl-bind misuse) don't infinite-loop. Cycles return the
|
||||
;; current term unchanged.
|
||||
(define
|
||||
dl-walk-aux
|
||||
(fn
|
||||
(term subst visited)
|
||||
(if
|
||||
(dl-var? term)
|
||||
(let
|
||||
((name (symbol->string term)))
|
||||
(cond
|
||||
((dl-member? name visited) term)
|
||||
((and (dict? subst) (has-key? subst name))
|
||||
(let ((seen (list)))
|
||||
(do
|
||||
(for-each (fn (v) (append! seen v)) visited)
|
||||
(append! seen name)
|
||||
(dl-walk-aux (get subst name) subst seen))))
|
||||
(else term)))
|
||||
term)))
|
||||
|
||||
;; Bind a variable symbol to a value in subst, returning a new subst.
|
||||
(define
|
||||
dl-bind
|
||||
(fn (var-sym value subst) (assoc subst (symbol->string var-sym) value)))
|
||||
|
||||
(define
|
||||
dl-unify
|
||||
(fn
|
||||
(t1 t2 subst)
|
||||
(if
|
||||
(nil? subst)
|
||||
nil
|
||||
(let
|
||||
((u1 (dl-walk t1 subst)) (u2 (dl-walk t2 subst)))
|
||||
(cond
|
||||
((dl-var? u1)
|
||||
(cond
|
||||
((and (dl-var? u2) (= (symbol->string u1) (symbol->string u2)))
|
||||
subst)
|
||||
(else (dl-bind u1 u2 subst))))
|
||||
((dl-var? u2) (dl-bind u2 u1 subst))
|
||||
((and (list? u1) (list? u2))
|
||||
(if
|
||||
(= (len u1) (len u2))
|
||||
(dl-unify-list u1 u2 subst 0)
|
||||
nil))
|
||||
((and (number? u1) (number? u2)) (if (= u1 u2) subst nil))
|
||||
((and (string? u1) (string? u2)) (if (= u1 u2) subst nil))
|
||||
((and (symbol? u1) (symbol? u2))
|
||||
(if (= (symbol->string u1) (symbol->string u2)) subst nil))
|
||||
(else nil))))))
|
||||
|
||||
(define
|
||||
dl-unify-list
|
||||
(fn
|
||||
(a b subst i)
|
||||
(cond
|
||||
((nil? subst) nil)
|
||||
((>= i (len a)) subst)
|
||||
(else
|
||||
(dl-unify-list
|
||||
a
|
||||
b
|
||||
(dl-unify (nth a i) (nth b i) subst)
|
||||
(+ i 1))))))
|
||||
|
||||
;; Apply substitution: walk the term and recurse into lists.
|
||||
(define
|
||||
dl-apply-subst
|
||||
(fn
|
||||
(term subst)
|
||||
(let
|
||||
((w (dl-walk term subst)))
|
||||
(if (list? w) (map (fn (x) (dl-apply-subst x subst)) w) w))))
|
||||
|
||||
;; Ground? — true iff no free variables remain after walking.
|
||||
(define
|
||||
dl-ground?
|
||||
(fn
|
||||
(term subst)
|
||||
(let
|
||||
((w (dl-walk term subst)))
|
||||
(cond
|
||||
((dl-var? w) false)
|
||||
((list? w) (dl-ground-list? w subst 0))
|
||||
(else true)))))
|
||||
|
||||
(define
|
||||
dl-ground-list?
|
||||
(fn
|
||||
(xs subst i)
|
||||
(cond
|
||||
((>= i (len xs)) true)
|
||||
((not (dl-ground? (nth xs i) subst)) false)
|
||||
(else (dl-ground-list? xs subst (+ i 1))))))
|
||||
|
||||
;; Return the list of variable names appearing in a term (deduped, in
|
||||
;; left-to-right order). Useful for safety analysis later.
|
||||
(define
|
||||
dl-vars-of
|
||||
(fn (term) (let ((seen (list))) (do (dl-vars-of-aux term seen) seen))))
|
||||
|
||||
(define
|
||||
dl-vars-of-aux
|
||||
(fn
|
||||
(term acc)
|
||||
(cond
|
||||
((dl-var? term)
|
||||
(let
|
||||
((name (symbol->string term)))
|
||||
(when (not (dl-member? name acc)) (append! acc name))))
|
||||
((list? term) (dl-vars-of-list term acc 0))
|
||||
(else nil))))
|
||||
|
||||
(define
|
||||
dl-vars-of-list
|
||||
(fn
|
||||
(xs acc i)
|
||||
(when
|
||||
(< i (len xs))
|
||||
(do
|
||||
(dl-vars-of-aux (nth xs i) acc)
|
||||
(dl-vars-of-list xs acc (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-member?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (dl-member? x (rest xs))))))
|
||||
@@ -33,54 +33,3 @@ least: persistent (path-copying) envs, an inline scheduler that
|
||||
doesn't call/cc on the common path (msg-already-in-mailbox), and a
|
||||
linked-list mailbox. None of those are in scope for the Phase 3
|
||||
checkbox — captured here as the floor we're starting from.
|
||||
|
||||
## Phase 9 status (2026-05-14)
|
||||
|
||||
Specialized opcodes 9b–9f landed as **stub dispatchers** in
|
||||
`lib/erlang/vm/dispatcher.sx`: `OP_PATTERN_TUPLE/LIST/BINARY`,
|
||||
`OP_PERFORM/HANDLE`, `OP_RECEIVE_SCAN`, `OP_SPAWN/SEND`, and ten
|
||||
`OP_BIF_*` hot dispatch entries. Each opcode's handler is a thin
|
||||
wrapper over the existing `er-match-*` / `er-bif-*` / runtime impls,
|
||||
so **the perf numbers above are unchanged** — same per-hop cost, same
|
||||
scheduler. The stubs exist to nail down opcode IDs, operand contracts,
|
||||
and tests against `er-match!` parity *before* 9a (the OCaml
|
||||
opcode-extension mechanism in `hosts/ocaml/evaluator/`) lands.
|
||||
|
||||
When 9a integrates and the bytecode compiler can emit these opcodes
|
||||
at hot call sites, the real speedup story (~3000× ring throughput,
|
||||
~1000× spawn) starts. Until then this file documents the
|
||||
pre-integration ceiling. 72 vm-suite tests guard the stub correctness;
|
||||
full conformance is **709/709** with the stub infrastructure loaded.
|
||||
|
||||
## Phase 9g — post-integration bench (2026-05-15)
|
||||
|
||||
9a (vm-ext mechanism), 9h (`erlang_ext.ml` registering `erlang.OP_*`
|
||||
ids 222-239), and 9i (SX dispatcher consulting `extension-opcode-id`)
|
||||
are now integrated and built into `hosts/ocaml/_build/default/bin/sx_server.exe`.
|
||||
Re-ran the ring ladder on that binary:
|
||||
|
||||
| N (processes) | Hops | Wall-clock | Throughput |
|
||||
|---|---|---|---|
|
||||
| 10 | 10 | 938ms | 11 hops/s |
|
||||
| 100 | 100 | 2772ms | 36 hops/s |
|
||||
| 500 | 500 | 14190ms | 35 hops/s |
|
||||
| 1000 | 1000 | 31814ms | 31 hops/s |
|
||||
|
||||
**Numbers are unchanged from the pre-integration baseline** — and that
|
||||
is the expected, correct result. The opcode handlers (both the SX stub
|
||||
dispatcher and the OCaml `erlang_ext` module) wrap the existing
|
||||
`er-match-*` / `er-bif-*` / scheduler implementations 1-to-1, and the
|
||||
**bytecode compiler does not yet emit `erlang.OP_*` opcodes**, so every
|
||||
hop still goes through the general CEK path exactly as before. The
|
||||
unchanged numbers therefore double as a no-regression check: the full
|
||||
extension wiring (cherry-picked vm-ext A-E + force-link + erlang_ext +
|
||||
SX bridge) added zero per-hop cost. Conformance **715/715** on this
|
||||
binary.
|
||||
|
||||
The ~3000×/~1000× targets remain gated on a **future phase (Phase 10 —
|
||||
bytecode emission)**: teach `lib/compiler.sx` (or the Erlang
|
||||
transpiler) to emit `erlang.OP_PATTERN_TUPLE` etc. at hot call sites,
|
||||
then give `erlang_ext.ml` real register-machine handlers instead of the
|
||||
current honest not-wired raise. That is a substantial standalone phase,
|
||||
tracked in `plans/erlang-on-sx.md`. 9g's deliverable — *honest
|
||||
measurement + recorded numbers on the integrated binary* — is complete.
|
||||
|
||||
@@ -36,8 +36,6 @@ SUITES=(
|
||||
"bank|er-bank-test-pass|er-bank-test-count"
|
||||
"echo|er-echo-test-pass|er-echo-test-count"
|
||||
"fib|er-fib-test-pass|er-fib-test-count"
|
||||
"ffi|er-ffi-test-pass|er-ffi-test-count"
|
||||
"vm|er-vm-test-pass|er-vm-test-count"
|
||||
)
|
||||
|
||||
cat > "$TMPFILE" << 'EPOCHS'
|
||||
@@ -58,9 +56,6 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(load "lib/erlang/tests/programs/bank.sx")
|
||||
(load "lib/erlang/tests/programs/echo.sx")
|
||||
(load "lib/erlang/tests/programs/fib_server.sx")
|
||||
(load "lib/erlang/vm/dispatcher.sx")
|
||||
(load "lib/erlang/tests/ffi.sx")
|
||||
(load "lib/erlang/tests/vm.sx")
|
||||
(epoch 100)
|
||||
(eval "(list er-test-pass er-test-count)")
|
||||
(epoch 101)
|
||||
@@ -79,13 +74,9 @@ cat > "$TMPFILE" << 'EPOCHS'
|
||||
(eval "(list er-echo-test-pass er-echo-test-count)")
|
||||
(epoch 108)
|
||||
(eval "(list er-fib-test-pass er-fib-test-count)")
|
||||
(epoch 109)
|
||||
(eval "(list er-ffi-test-pass er-ffi-test-count)")
|
||||
(epoch 110)
|
||||
(eval "(list er-vm-test-pass er-vm-test-count)")
|
||||
EPOCHS
|
||||
|
||||
timeout 600 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
timeout 120 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
|
||||
# Parse "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
|
||||
parse_pair() {
|
||||
|
||||
@@ -853,112 +853,6 @@
|
||||
(define er-modules-get (fn () (nth er-modules 0)))
|
||||
(define er-modules-reset! (fn () (set-nth! er-modules 0 {})))
|
||||
|
||||
(define er-mk-module-slot
|
||||
(fn (mod-env old-env version)
|
||||
{:current mod-env :old old-env :version version :tag "module"}))
|
||||
|
||||
(define er-module-current-env (fn (slot) (get slot :current)))
|
||||
(define er-module-old-env (fn (slot) (get slot :old)))
|
||||
(define er-module-version (fn (slot) (get slot :version)))
|
||||
|
||||
;; ── FFI BIF registry (Phase 8) ───────────────────────────────────
|
||||
;; Global dict from "Module/Name/Arity" key to {:module :name :arity :fn :pure?}.
|
||||
;; Replaces the giant cond chain in transpile.sx#er-apply-remote-bif over time —
|
||||
;; Phase 8 BIFs (crypto / cid / file / httpc / sqlite) all register here.
|
||||
(define er-bif-registry (list {}))
|
||||
(define er-bif-registry-get (fn () (nth er-bif-registry 0)))
|
||||
(define er-bif-registry-reset! (fn () (set-nth! er-bif-registry 0 {})))
|
||||
|
||||
(define er-bif-key
|
||||
(fn (module name arity)
|
||||
(str module "/" name "/" arity)))
|
||||
|
||||
(define er-register-bif!
|
||||
(fn (module name arity sx-fn)
|
||||
(dict-set! (er-bif-registry-get) (er-bif-key module name arity)
|
||||
{:module module :name name :arity arity :fn sx-fn :pure? false})
|
||||
(er-mk-atom "ok")))
|
||||
|
||||
(define er-register-pure-bif!
|
||||
(fn (module name arity sx-fn)
|
||||
(dict-set! (er-bif-registry-get) (er-bif-key module name arity)
|
||||
{:module module :name name :arity arity :fn sx-fn :pure? true})
|
||||
(er-mk-atom "ok")))
|
||||
|
||||
(define er-lookup-bif
|
||||
(fn (module name arity)
|
||||
(let ((reg (er-bif-registry-get)) (k (er-bif-key module name arity)))
|
||||
(if (dict-has? reg k) (get reg k) nil))))
|
||||
|
||||
(define er-list-bifs
|
||||
(fn () (keys (er-bif-registry-get))))
|
||||
|
||||
;; ── term marshalling (Phase 8) ───────────────────────────────────
|
||||
;; Bridge Erlang term values (tagged dicts) and SX-native values for
|
||||
;; FFI BIFs to call out into platform primitives. Conversions:
|
||||
;;
|
||||
;; Erlang SX-native
|
||||
;; ───────────────────────── ────────────────
|
||||
;; atom {:tag "atom" :name S} ↔ symbol (make-symbol S)
|
||||
;; nil {:tag "nil"} ↔ '()
|
||||
;; cons {:tag "cons" :head :tail} → list of marshalled elements
|
||||
;; tuple {:tag "tuple" :elements} → list of marshalled elements
|
||||
;; binary {:tag "binary" :bytes} ↔ SX string
|
||||
;; integer / float / boolean ↔ passthrough
|
||||
;; SX string on the way back → binary
|
||||
;;
|
||||
;; Pids, refs, funs pass through unchanged — they have no SX-native
|
||||
;; equivalent and are opaque to FFI primitives.
|
||||
|
||||
(define er-cons-to-sx-list
|
||||
(fn (v)
|
||||
(cond
|
||||
(er-nil? v) (list)
|
||||
(er-cons? v)
|
||||
(let ((tail (er-cons-to-sx-list (get v :tail)))
|
||||
(head (er-to-sx (get v :head))))
|
||||
(let ((out (list head)))
|
||||
(for-each
|
||||
(fn (i) (append! out (nth tail i)))
|
||||
(range 0 (len tail)))
|
||||
out))
|
||||
:else (list v))))
|
||||
|
||||
(define er-to-sx
|
||||
(fn (v)
|
||||
(cond
|
||||
(er-atom? v) (make-symbol (get v :name))
|
||||
(er-nil? v) (list)
|
||||
(er-cons? v) (er-cons-to-sx-list v)
|
||||
(er-tuple? v)
|
||||
(let ((out (list)) (es (get v :elements)))
|
||||
(for-each
|
||||
(fn (i) (append! out (er-to-sx (nth es i))))
|
||||
(range 0 (len es)))
|
||||
out)
|
||||
(er-binary? v) (list->string (map integer->char (get v :bytes)))
|
||||
:else v)))
|
||||
|
||||
(define er-of-sx
|
||||
(fn (v)
|
||||
(let ((ty (type-of v)))
|
||||
(cond
|
||||
(= ty "symbol") (er-mk-atom (str v))
|
||||
(= ty "string") (er-mk-binary (map char->integer (string->list v)))
|
||||
(= ty "list")
|
||||
(let ((out (er-mk-nil)))
|
||||
(for-each
|
||||
(fn (i)
|
||||
(set! out
|
||||
(er-mk-cons (er-of-sx (nth v (- (- (len v) 1) i))) out)))
|
||||
(range 0 (len v)))
|
||||
out)
|
||||
(= ty "nil") (er-mk-nil)
|
||||
:else v))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; Load an Erlang module declaration. Source must start with
|
||||
;; `-module(Name).` and contain function definitions. Functions
|
||||
;; sharing a name (different arities) get their clauses concatenated
|
||||
@@ -1003,15 +897,7 @@
|
||||
((all-clauses (get by-name k)))
|
||||
(er-env-bind! mod-env k (er-mk-fun all-clauses mod-env))))
|
||||
(keys by-name))
|
||||
(let ((registry (er-modules-get)))
|
||||
(if (dict-has? registry mod-name)
|
||||
(let ((existing-slot (get registry mod-name)))
|
||||
(dict-set! registry mod-name
|
||||
(er-mk-module-slot mod-env
|
||||
(er-module-current-env existing-slot)
|
||||
(+ (er-module-version existing-slot) 1))))
|
||||
(dict-set! registry mod-name
|
||||
(er-mk-module-slot mod-env nil 1))))
|
||||
(dict-set! (er-modules-get) mod-name mod-env)
|
||||
(er-mk-atom mod-name)))))
|
||||
|
||||
(define
|
||||
@@ -1019,7 +905,7 @@
|
||||
(fn
|
||||
(mod name vs)
|
||||
(let
|
||||
((mod-env (er-module-current-env (get (er-modules-get) mod))))
|
||||
((mod-env (get (er-modules-get) mod)))
|
||||
(if
|
||||
(not (dict-has? mod-env name))
|
||||
(raise
|
||||
@@ -1303,266 +1189,16 @@
|
||||
:else (er-mk-atom "undefined")))
|
||||
:else (error "Erlang: ets:info: arity"))))
|
||||
|
||||
|
||||
|
||||
;; ── file module (Phase 8 FFI) ────────────────────────────────────
|
||||
;; Synchronous file IO. Filenames must be SX strings (or Erlang
|
||||
;; binaries/char-code lists coercible to strings via er-source-to-string).
|
||||
;; Returns `{ok, Binary}` / `ok` on success, `{error, Reason}` on failure
|
||||
;; where Reason is one of `enoent`, `eacces`, `enotdir`, `posix_error`.
|
||||
|
||||
(define er-classify-file-error
|
||||
(fn (msg)
|
||||
(let ((s (str msg)))
|
||||
(define
|
||||
er-apply-ets-bif
|
||||
(fn
|
||||
(name vs)
|
||||
(cond
|
||||
(string-contains? s "No such") (er-mk-atom "enoent")
|
||||
(string-contains? s "Permission denied") (er-mk-atom "eacces")
|
||||
(string-contains? s "Not a directory") (er-mk-atom "enotdir")
|
||||
(string-contains? s "Is a directory") (er-mk-atom "eisdir")
|
||||
:else (er-mk-atom "posix_error")))))
|
||||
|
||||
(define er-bif-file-read-file
|
||||
(fn (vs)
|
||||
(let ((path (er-source-to-string (nth vs 0))))
|
||||
(cond
|
||||
(= path nil)
|
||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
||||
:else
|
||||
(let ((res (list nil)) (err (list nil)))
|
||||
(guard (c (:else (set-nth! err 0 c)))
|
||||
(set-nth! res 0 (file-read path)))
|
||||
(cond
|
||||
(not (= (nth err 0) nil))
|
||||
(er-mk-tuple (list (er-mk-atom "error")
|
||||
(er-classify-file-error (nth err 0))))
|
||||
:else
|
||||
(er-mk-tuple (list (er-mk-atom "ok")
|
||||
(er-mk-binary (map char->integer (string->list (nth res 0))))))))))))
|
||||
|
||||
(define er-bif-file-write-file
|
||||
(fn (vs)
|
||||
(let ((path (er-source-to-string (nth vs 0)))
|
||||
(data (er-source-to-string (nth vs 1))))
|
||||
(cond
|
||||
(or (= path nil) (= data nil))
|
||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
||||
:else
|
||||
(let ((err (list nil)))
|
||||
(guard (c (:else (set-nth! err 0 c)))
|
||||
(file-write path data))
|
||||
(cond
|
||||
(not (= (nth err 0) nil))
|
||||
(er-mk-tuple (list (er-mk-atom "error")
|
||||
(er-classify-file-error (nth err 0))))
|
||||
:else (er-mk-atom "ok")))))))
|
||||
|
||||
(define er-bif-file-delete
|
||||
(fn (vs)
|
||||
(let ((path (er-source-to-string (nth vs 0))))
|
||||
(cond
|
||||
(= path nil)
|
||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
||||
:else
|
||||
(let ((err (list nil)))
|
||||
(guard (c (:else (set-nth! err 0 c)))
|
||||
(file-delete path))
|
||||
(cond
|
||||
(not (= (nth err 0) nil))
|
||||
(er-mk-tuple (list (er-mk-atom "error")
|
||||
(er-classify-file-error (nth err 0))))
|
||||
:else (er-mk-atom "ok")))))))
|
||||
|
||||
|
||||
;; ── crypto / cid / file:list_dir (Phase 8 FFI — host primitives) ──
|
||||
;; Wired against loops/fed-prims host primitives (see plans Blockers
|
||||
;; "RESOLVED 2026-05-18"). Term marshalling at the boundary:
|
||||
;; Erlang binary/string/charlist -> SX byte-string via er-source-to-string;
|
||||
;; results -> Erlang binary via er-mk-binary.
|
||||
|
||||
(define er-hexval
|
||||
(fn (c)
|
||||
(let ((v (char->integer c)))
|
||||
(cond
|
||||
(and (>= v 48) (<= v 57)) (- v 48) ;; 0-9
|
||||
(and (>= v 97) (<= v 102)) (+ 10 (- v 97)) ;; a-f
|
||||
(and (>= v 65) (<= v 70)) (+ 10 (- v 65)) ;; A-F
|
||||
:else 0))))
|
||||
|
||||
(define er-hex->bytes
|
||||
(fn (hex)
|
||||
(let ((cs (string->list hex)) (out (list)) (n (string-length hex)))
|
||||
(for-each
|
||||
(fn (i)
|
||||
(append! out
|
||||
(+ (* 16 (er-hexval (nth cs (* i 2))))
|
||||
(er-hexval (nth cs (+ (* i 2) 1))))))
|
||||
(range 0 (truncate (/ n 2))))
|
||||
out)))
|
||||
|
||||
;; crypto:hash(Type, Data) -> raw digest binary. Type is an Erlang
|
||||
;; atom (sha256 | sha512 | sha3_256). Bad type / non-binary -> badarg.
|
||||
(define er-bif-crypto-hash
|
||||
(fn (vs)
|
||||
(let ((ty (nth vs 0)) (data (er-source-to-string (nth vs 1))))
|
||||
(cond
|
||||
(or (not (er-atom? ty)) (= data nil))
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else
|
||||
(let ((name (get ty :name)))
|
||||
(let ((hex (cond
|
||||
(= name "sha256") (crypto-sha256 data)
|
||||
(= name "sha512") (crypto-sha512 data)
|
||||
(= name "sha3_256") (crypto-sha3-256 data)
|
||||
:else nil)))
|
||||
(cond
|
||||
(= hex nil) (raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else (er-mk-binary (er-hex->bytes hex)))))))))
|
||||
|
||||
;; cid:from_bytes(Bin) -> CIDv1 (raw codec 0x55, sha2-256 multihash)
|
||||
;; as an Erlang binary string.
|
||||
(define er-bif-cid-from-bytes
|
||||
(fn (vs)
|
||||
(let ((data (er-source-to-string (nth vs 0))))
|
||||
(cond
|
||||
(= data nil) (raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else
|
||||
(let ((digest (er-hex->bytes (crypto-sha256 data))))
|
||||
(let ((mh (list->string
|
||||
(map integer->char (append (list 18 32) digest)))))
|
||||
(er-mk-binary
|
||||
(map char->integer
|
||||
(string->list (cid-from-bytes 85 mh))))))))))
|
||||
|
||||
;; cid:to_string(Term) -> canonical CIDv1 (dag-cbor) of the term,
|
||||
;; as an Erlang binary string.
|
||||
(define er-bif-cid-to-string
|
||||
(fn (vs)
|
||||
;; Canonical CID of the term's stable string form. (cbor-encode
|
||||
;; rejects symbols, so er-to-sx of compound terms is unencodable;
|
||||
;; er-format-value yields a canonical SX string per term value.)
|
||||
(er-mk-binary
|
||||
(map char->integer
|
||||
(string->list (cid-from-sx (er-format-value (nth vs 0))))))))
|
||||
|
||||
;; file:list_dir(Path) -> {ok, [Binary]} | {error, Reason}
|
||||
(define er-bif-file-list-dir
|
||||
(fn (vs)
|
||||
(let ((path (er-source-to-string (nth vs 0))))
|
||||
(cond
|
||||
(= path nil)
|
||||
(er-mk-tuple (list (er-mk-atom "error") (er-mk-atom "badarg")))
|
||||
:else
|
||||
(let ((res (list nil)) (err (list nil)))
|
||||
(guard (c (:else (set-nth! err 0 c)))
|
||||
(set-nth! res 0 (file-list-dir path)))
|
||||
(cond
|
||||
(not (= (nth err 0) nil))
|
||||
(er-mk-tuple (list (er-mk-atom "error")
|
||||
(er-classify-file-error (nth err 0))))
|
||||
:else
|
||||
(er-mk-tuple (list (er-mk-atom "ok")
|
||||
(er-of-sx (nth res 0))))))))))
|
||||
|
||||
;; ── builtin BIF registrations (Phase 8 migration) ────────────────
|
||||
;; Populates `er-bif-registry` with every existing built-in BIF. Each
|
||||
;; entry is keyed by "Module/Name/Arity"; multi-arity BIFs register
|
||||
;; once per arity. Called eagerly at the end of runtime.sx so the
|
||||
;; registry is ready before any erlang-eval-ast call.
|
||||
(define er-register-builtin-bifs!
|
||||
(fn ()
|
||||
;; erlang module — type predicates (all pure)
|
||||
(er-register-pure-bif! "erlang" "is_integer" 1 er-bif-is-integer)
|
||||
(er-register-pure-bif! "erlang" "is_atom" 1 er-bif-is-atom)
|
||||
(er-register-pure-bif! "erlang" "is_list" 1 er-bif-is-list)
|
||||
(er-register-pure-bif! "erlang" "is_tuple" 1 er-bif-is-tuple)
|
||||
(er-register-pure-bif! "erlang" "is_number" 1 er-bif-is-number)
|
||||
(er-register-pure-bif! "erlang" "is_float" 1 er-bif-is-float)
|
||||
(er-register-pure-bif! "erlang" "is_boolean" 1 er-bif-is-boolean)
|
||||
(er-register-pure-bif! "erlang" "is_pid" 1 er-bif-is-pid)
|
||||
(er-register-pure-bif! "erlang" "is_reference" 1 er-bif-is-reference)
|
||||
(er-register-pure-bif! "erlang" "is_binary" 1 er-bif-is-binary)
|
||||
(er-register-pure-bif! "erlang" "is_function" 1 er-bif-is-function)
|
||||
(er-register-pure-bif! "erlang" "is_function" 2 er-bif-is-function)
|
||||
;; erlang module — pure data ops
|
||||
(er-register-pure-bif! "erlang" "length" 1 er-bif-length)
|
||||
(er-register-pure-bif! "erlang" "hd" 1 er-bif-hd)
|
||||
(er-register-pure-bif! "erlang" "tl" 1 er-bif-tl)
|
||||
(er-register-pure-bif! "erlang" "element" 2 er-bif-element)
|
||||
(er-register-pure-bif! "erlang" "tuple_size" 1 er-bif-tuple-size)
|
||||
(er-register-pure-bif! "erlang" "byte_size" 1 er-bif-byte-size)
|
||||
(er-register-pure-bif! "erlang" "atom_to_list" 1 er-bif-atom-to-list)
|
||||
(er-register-pure-bif! "erlang" "list_to_atom" 1 er-bif-list-to-atom)
|
||||
(er-register-pure-bif! "erlang" "abs" 1 er-bif-abs)
|
||||
(er-register-pure-bif! "erlang" "min" 2 er-bif-min)
|
||||
(er-register-pure-bif! "erlang" "max" 2 er-bif-max)
|
||||
(er-register-pure-bif! "erlang" "tuple_to_list" 1 er-bif-tuple-to-list)
|
||||
(er-register-pure-bif! "erlang" "list_to_tuple" 1 er-bif-list-to-tuple)
|
||||
(er-register-pure-bif! "erlang" "integer_to_list" 1 er-bif-integer-to-list)
|
||||
(er-register-pure-bif! "erlang" "list_to_integer" 1 er-bif-list-to-integer)
|
||||
;; erlang module — process / runtime (side-effecting)
|
||||
(er-register-bif! "erlang" "self" 0 er-bif-self)
|
||||
(er-register-bif! "erlang" "spawn" 1 er-bif-spawn)
|
||||
(er-register-bif! "erlang" "spawn" 3 er-bif-spawn)
|
||||
(er-register-bif! "erlang" "exit" 1 er-bif-exit)
|
||||
(er-register-bif! "erlang" "exit" 2 er-bif-exit)
|
||||
(er-register-bif! "erlang" "make_ref" 0 er-bif-make-ref)
|
||||
(er-register-bif! "erlang" "link" 1 er-bif-link)
|
||||
(er-register-bif! "erlang" "unlink" 1 er-bif-unlink)
|
||||
(er-register-bif! "erlang" "monitor" 2 er-bif-monitor)
|
||||
(er-register-bif! "erlang" "demonitor" 1 er-bif-demonitor)
|
||||
(er-register-bif! "erlang" "process_flag" 2 er-bif-process-flag)
|
||||
(er-register-bif! "erlang" "register" 2 er-bif-register)
|
||||
(er-register-bif! "erlang" "unregister" 1 er-bif-unregister)
|
||||
(er-register-bif! "erlang" "whereis" 1 er-bif-whereis)
|
||||
(er-register-bif! "erlang" "registered" 0 er-bif-registered)
|
||||
;; erlang module — exception raising (modelled as side-effecting)
|
||||
(er-register-bif! "erlang" "throw" 1
|
||||
(fn (vs) (raise (er-mk-throw-marker (er-bif-arg1 vs "throw")))))
|
||||
(er-register-bif! "erlang" "error" 1
|
||||
(fn (vs) (raise (er-mk-error-marker (er-bif-arg1 vs "error")))))
|
||||
;; lists module — all pure
|
||||
(er-register-pure-bif! "lists" "reverse" 1 er-bif-lists-reverse)
|
||||
(er-register-pure-bif! "lists" "map" 2 er-bif-lists-map)
|
||||
(er-register-pure-bif! "lists" "foldl" 3 er-bif-lists-foldl)
|
||||
(er-register-pure-bif! "lists" "seq" 2 er-bif-lists-seq)
|
||||
(er-register-pure-bif! "lists" "seq" 3 er-bif-lists-seq)
|
||||
(er-register-pure-bif! "lists" "sum" 1 er-bif-lists-sum)
|
||||
(er-register-pure-bif! "lists" "nth" 2 er-bif-lists-nth)
|
||||
(er-register-pure-bif! "lists" "last" 1 er-bif-lists-last)
|
||||
(er-register-pure-bif! "lists" "member" 2 er-bif-lists-member)
|
||||
(er-register-pure-bif! "lists" "append" 2 er-bif-lists-append)
|
||||
(er-register-pure-bif! "lists" "filter" 2 er-bif-lists-filter)
|
||||
(er-register-pure-bif! "lists" "any" 2 er-bif-lists-any)
|
||||
(er-register-pure-bif! "lists" "all" 2 er-bif-lists-all)
|
||||
(er-register-pure-bif! "lists" "duplicate" 2 er-bif-lists-duplicate)
|
||||
;; io module — side-effecting (writes to io buffer)
|
||||
(er-register-bif! "io" "format" 1 er-bif-io-format)
|
||||
(er-register-bif! "io" "format" 2 er-bif-io-format)
|
||||
;; ets module — side-effecting (mutates table state)
|
||||
(er-register-bif! "ets" "new" 2 er-bif-ets-new)
|
||||
(er-register-bif! "ets" "insert" 2 er-bif-ets-insert)
|
||||
(er-register-bif! "ets" "lookup" 2 er-bif-ets-lookup)
|
||||
(er-register-bif! "ets" "delete" 1 er-bif-ets-delete)
|
||||
(er-register-bif! "ets" "delete" 2 er-bif-ets-delete)
|
||||
(er-register-bif! "ets" "tab2list" 1 er-bif-ets-tab2list)
|
||||
(er-register-bif! "ets" "info" 2 er-bif-ets-info)
|
||||
;; code module — side-effecting (mutates module registry, kills procs)
|
||||
(er-register-bif! "code" "load_binary" 3 er-bif-code-load-binary)
|
||||
(er-register-bif! "code" "purge" 1 er-bif-code-purge)
|
||||
(er-register-bif! "code" "soft_purge" 1 er-bif-code-soft-purge)
|
||||
(er-register-bif! "code" "which" 1 er-bif-code-which)
|
||||
(er-register-bif! "code" "is_loaded" 1 er-bif-code-is-loaded)
|
||||
(er-register-bif! "code" "all_loaded" 0 er-bif-code-all-loaded)
|
||||
;; file module
|
||||
(er-register-bif! "file" "read_file" 1 er-bif-file-read-file)
|
||||
(er-register-bif! "file" "write_file" 2 er-bif-file-write-file)
|
||||
(er-register-bif! "file" "delete" 1 er-bif-file-delete)
|
||||
;; Phase 8 FFI — host-primitive BIFs (loops/fed-prims)
|
||||
(er-register-pure-bif! "crypto" "hash" 2 er-bif-crypto-hash)
|
||||
(er-register-pure-bif! "cid" "from_bytes" 1 er-bif-cid-from-bytes)
|
||||
(er-register-pure-bif! "cid" "to_string" 1 er-bif-cid-to-string)
|
||||
(er-register-bif! "file" "list_dir" 1 er-bif-file-list-dir)
|
||||
(er-mk-atom "ok")))
|
||||
|
||||
;; Register everything at load time.
|
||||
(er-register-builtin-bifs!)
|
||||
(= name "new") (er-bif-ets-new vs)
|
||||
(= name "insert") (er-bif-ets-insert vs)
|
||||
(= name "lookup") (er-bif-ets-lookup vs)
|
||||
(= name "delete") (er-bif-ets-delete vs)
|
||||
(= name "tab2list") (er-bif-ets-tab2list vs)
|
||||
(= name "info") (er-bif-ets-info vs)
|
||||
:else (error
|
||||
(str "Erlang: undefined 'ets:" name "/" (len vs) "'")))))
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user