Compare commits
5 Commits
2defa5e739
...
loops/tcl
| Author | SHA1 | Date | |
|---|---|---|---|
| 50b69bcbd0 | |||
| 14986d787d | |||
| 21028c4fb0 | |||
| 7415dd020e | |||
| 2fa0bb4df1 |
@@ -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;
|
||||
@@ -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
|
||||
|
||||
@@ -2899,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 *)
|
||||
|
||||
@@ -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 =
|
||||
@@ -715,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);
|
||||
@@ -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 =
|
||||
|
||||
@@ -528,6 +528,183 @@ let () =
|
||||
| [Rational (_, d)] -> Integer d
|
||||
| [Integer _] -> Integer 1
|
||||
| _ -> raise (Eval_error "denominator: expected rational or integer"));
|
||||
(* printf-spec: apply one Tcl/printf format spec to one arg.
|
||||
spec is like "%5.2f", "%-10s", "%x", "%c", "%d". Always starts with %
|
||||
and ends with the conversion char. Supports d i u x X o c s f e g.
|
||||
Coerces arg to the right type per conversion. *)
|
||||
register "printf-spec" (fun args ->
|
||||
let spec_str, arg = match args with
|
||||
| [String s; v] -> (s, v)
|
||||
| _ -> raise (Eval_error "printf-spec: (spec arg)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("printf-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let to_int v = match v with
|
||||
| Integer i -> i
|
||||
| Number f -> int_of_float f
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try int_of_string s
|
||||
with _ ->
|
||||
try int_of_float (float_of_string s)
|
||||
with _ -> 0)
|
||||
| Bool true -> 1 | Bool false -> 0
|
||||
| _ -> 0
|
||||
in
|
||||
let to_float v = match v with
|
||||
| Number f -> f
|
||||
| Integer i -> float_of_int i
|
||||
| String s ->
|
||||
let s = String.trim s in
|
||||
(try float_of_string s with _ -> 0.0)
|
||||
| _ -> 0.0
|
||||
in
|
||||
let to_string v = match v with
|
||||
| String s -> s
|
||||
| Integer i -> string_of_int i
|
||||
| Number f -> Sx_types.format_number f
|
||||
| Bool true -> "1" | Bool false -> "0"
|
||||
| Nil -> ""
|
||||
| _ -> Sx_types.inspect v
|
||||
in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%d" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'u' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%u" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'x' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%x" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'X' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%X" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'o' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%o" in
|
||||
String (Printf.sprintf fmt (to_int arg))
|
||||
| 'c' ->
|
||||
let n_val = to_int arg in
|
||||
let body = String.sub spec_str 0 (n - 1) in
|
||||
let fmt = Scanf.format_from_string (body ^ "s") "%s" in
|
||||
String (Printf.sprintf fmt (String.make 1 (Char.chr (n_val land 0xff))))
|
||||
| 's' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%s" in
|
||||
String (Printf.sprintf fmt (to_string arg))
|
||||
| 'f' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%f" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'e' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%e" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'E' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%E" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'g' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%g" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| 'G' ->
|
||||
let fmt = Scanf.format_from_string spec_str "%G" in
|
||||
String (Printf.sprintf fmt (to_float arg))
|
||||
| _ -> raise (Eval_error ("printf-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> raise (Eval_error ("printf-spec: invalid format " ^ spec_str)));
|
||||
|
||||
(* scan-spec: apply one Tcl/scanf format spec to a string.
|
||||
Returns (consumed-count . parsed-value), or nil on failure. *)
|
||||
register "scan-spec" (fun args ->
|
||||
let spec_str, str = match args with
|
||||
| [String s; String input] -> (s, input)
|
||||
| _ -> raise (Eval_error "scan-spec: (spec input)")
|
||||
in
|
||||
let n = String.length spec_str in
|
||||
if n < 2 || spec_str.[0] <> '%' then
|
||||
raise (Eval_error ("scan-spec: invalid spec " ^ spec_str));
|
||||
let type_char = spec_str.[n - 1] in
|
||||
let len = String.length str in
|
||||
(* skip leading whitespace for non-%c/%s conversions *)
|
||||
let i = ref 0 in
|
||||
if type_char <> 'c' then
|
||||
while !i < len && (str.[!i] = ' ' || str.[!i] = '\t' || str.[!i] = '\n') do incr i done;
|
||||
let start = !i in
|
||||
try
|
||||
match type_char with
|
||||
| 'd' | 'i' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done;
|
||||
if !j > start && (str.[start] >= '0' && str.[start] <= '9'
|
||||
|| (!j > start + 1 && (str.[start] = '-' || str.[start] = '+'))) then
|
||||
let n_val = int_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'x' | 'X' ->
|
||||
let j = ref !i in
|
||||
while !j < len &&
|
||||
((str.[!j] >= '0' && str.[!j] <= '9') ||
|
||||
(str.[!j] >= 'a' && str.[!j] <= 'f') ||
|
||||
(str.[!j] >= 'A' && str.[!j] <= 'F')) do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0x" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'o' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '7' do incr j done;
|
||||
if !j > start then
|
||||
let n_val = int_of_string ("0o" ^ String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer n_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'f' | 'e' | 'g' ->
|
||||
let j = ref !i in
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && ((str.[!j] >= '0' && str.[!j] <= '9') || str.[!j] = '.') do incr j done;
|
||||
if !j < len && (str.[!j] = 'e' || str.[!j] = 'E') then begin
|
||||
incr j;
|
||||
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
|
||||
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done
|
||||
end;
|
||||
if !j > start then
|
||||
let f_val = float_of_string (String.sub str start (!j - start)) in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Number f_val);
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 's' ->
|
||||
let j = ref !i in
|
||||
while !j < len && str.[!j] <> ' ' && str.[!j] <> '\t' && str.[!j] <> '\n' do incr j done;
|
||||
if !j > start then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (String (String.sub str start (!j - start)));
|
||||
Hashtbl.replace d "consumed" (Integer !j);
|
||||
Dict d
|
||||
else Nil
|
||||
| 'c' ->
|
||||
if !i < len then
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "value" (Integer (Char.code str.[!i]));
|
||||
Hashtbl.replace d "consumed" (Integer (!i + 1));
|
||||
Dict d
|
||||
else Nil
|
||||
| _ -> raise (Eval_error ("scan-spec: unsupported conversion " ^ String.make 1 type_char))
|
||||
with
|
||||
| Eval_error _ as e -> raise e
|
||||
| _ -> Nil);
|
||||
|
||||
register "parse-int" (fun args ->
|
||||
let parse_leading_int s =
|
||||
let len = String.length s in
|
||||
@@ -666,9 +843,7 @@ let () =
|
||||
register "list?" (fun args ->
|
||||
match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg"));
|
||||
register "dict?" (fun args ->
|
||||
match args with [Dict _] -> Bool true | [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
|
||||
register "adt?" (fun args ->
|
||||
match args with [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "adt?: 1 arg"));
|
||||
match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
|
||||
register "symbol?" (fun args ->
|
||||
match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
|
||||
register "keyword?" (fun args ->
|
||||
@@ -1281,11 +1456,6 @@ let () =
|
||||
match args with [String msg] -> raise (Eval_error msg)
|
||||
| [a] -> raise (Eval_error (to_string a))
|
||||
| _ -> raise (Eval_error "host-error: 1 arg"));
|
||||
register "host-warn" (fun args ->
|
||||
match args with
|
||||
| [String msg] -> prerr_endline msg; Nil
|
||||
| [a] -> prerr_endline (to_string a); Nil
|
||||
| _ -> raise (Eval_error "host-warn: 1 arg"));
|
||||
register "try-catch" (fun args ->
|
||||
match args with
|
||||
| [try_fn; catch_fn] ->
|
||||
@@ -1607,32 +1777,6 @@ let () =
|
||||
match args with [StringBuffer buf] -> Integer (Buffer.length buf)
|
||||
| _ -> raise (Eval_error "string-buffer-length: expected (buffer)"));
|
||||
|
||||
(* Short aliases — same StringBuffer value, terser names for hot paths.
|
||||
Append accepts any value: strings pass through, others get inspected/coerced. *)
|
||||
register "make-buffer" (fun _ -> StringBuffer (Buffer.create 64));
|
||||
register "buffer?" (fun args ->
|
||||
match args with [StringBuffer _] -> Bool true | [_] -> Bool false
|
||||
| _ -> raise (Eval_error "buffer?: expected 1 arg"));
|
||||
register "buffer-append!" (fun args ->
|
||||
match args with
|
||||
| [StringBuffer buf; String s] -> Buffer.add_string buf s; Nil
|
||||
| [StringBuffer buf; Integer n] -> Buffer.add_string buf (string_of_int n); Nil
|
||||
| [StringBuffer buf; Number n] -> Buffer.add_string buf (Sx_types.format_number n); Nil
|
||||
| [StringBuffer buf; Symbol s] -> Buffer.add_string buf s; Nil
|
||||
| [StringBuffer buf; Char n] ->
|
||||
Buffer.add_utf_8_uchar buf (Uchar.of_int n); Nil
|
||||
| [StringBuffer buf; Nil] -> Buffer.add_string buf ""; Nil
|
||||
| [StringBuffer buf; Bool true] -> Buffer.add_string buf "true"; Nil
|
||||
| [StringBuffer buf; Bool false] -> Buffer.add_string buf "false"; Nil
|
||||
| [StringBuffer buf; v] -> Buffer.add_string buf (inspect v); Nil
|
||||
| _ -> raise (Eval_error "buffer-append!: expected (buffer value)"));
|
||||
register "buffer->string" (fun args ->
|
||||
match args with [StringBuffer buf] -> String (Buffer.contents buf)
|
||||
| _ -> raise (Eval_error "buffer->string: expected (buffer)"));
|
||||
register "buffer-length" (fun args ->
|
||||
match args with [StringBuffer buf] -> Integer (Buffer.length buf)
|
||||
| _ -> raise (Eval_error "buffer-length: expected (buffer)"));
|
||||
|
||||
(* Capability-based sandboxing — gate IO operations *)
|
||||
let cap_stack : string list ref = ref [] in
|
||||
register "with-capabilities" (fun args ->
|
||||
@@ -3399,6 +3543,204 @@ let () =
|
||||
Nil
|
||||
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
|
||||
|
||||
(* === Exec === run an external process; capture stdout *)
|
||||
register "exec-process" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-process: (cmd-list)")
|
||||
in
|
||||
let argv = Array.of_list (List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items) in
|
||||
if Array.length argv = 0 then raise (Eval_error "exec: empty command");
|
||||
let (out_r, out_w) = Unix.pipe () in
|
||||
let (err_r, err_w) = Unix.pipe () in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv Unix.stdin out_w err_w
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
Unix.close out_r; Unix.close out_w;
|
||||
Unix.close err_r; Unix.close err_w;
|
||||
raise (Eval_error ("exec: " ^ Unix.error_message e))
|
||||
in
|
||||
Unix.close out_w;
|
||||
Unix.close err_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let n = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if n = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 n
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all out_r buf;
|
||||
read_all err_r errbuf;
|
||||
Unix.close out_r;
|
||||
Unix.close err_r;
|
||||
let (_, status) = Unix.waitpid [] pid in
|
||||
let exit_code = match status with
|
||||
| Unix.WEXITED n -> n
|
||||
| Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 1
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if exit_code <> 0 then
|
||||
raise (Eval_error ("exec: child exited " ^ string_of_int exit_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* exec-pipeline: takes a list of words like Tcl `exec` would receive.
|
||||
Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
|
||||
`2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
|
||||
stage; raises Eval_error if the last stage exits non-zero. *)
|
||||
register "exec-pipeline" (fun args ->
|
||||
let items = match args with
|
||||
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||
| _ -> raise (Eval_error "exec-pipeline: (word-list)")
|
||||
in
|
||||
let words = List.map (function
|
||||
| String s -> s
|
||||
| v -> Sx_types.inspect v
|
||||
) items in
|
||||
if words = [] then raise (Eval_error "exec: empty command");
|
||||
let split_stages ws =
|
||||
let rec loop acc cur = function
|
||||
| [] -> List.rev (List.rev cur :: acc)
|
||||
| "|" :: rest -> loop (List.rev cur :: acc) [] rest
|
||||
| w :: rest -> loop acc (w :: cur) rest
|
||||
in
|
||||
loop [] [] ws
|
||||
in
|
||||
let extract_redirs ws =
|
||||
let in_path = ref None in
|
||||
let out_path = ref None in
|
||||
let out_append = ref false in
|
||||
let err_path = ref None in
|
||||
let merge_err = ref false in
|
||||
let cleaned = ref [] in
|
||||
let rec loop = function
|
||||
| [] -> ()
|
||||
| "<" :: p :: rest -> in_path := Some p; loop rest
|
||||
| ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
|
||||
| ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
|
||||
| "2>@1" :: rest -> merge_err := true; loop rest
|
||||
| "2>" :: p :: rest -> err_path := Some p; loop rest
|
||||
| w :: rest -> cleaned := w :: !cleaned; loop rest
|
||||
in
|
||||
loop ws;
|
||||
(List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
|
||||
in
|
||||
let stages = List.map extract_redirs (split_stages words) in
|
||||
if stages = [] then raise (Eval_error "exec: no stages");
|
||||
let n = List.length stages in
|
||||
let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
|
||||
let (final_r, final_w) = Unix.pipe () in
|
||||
let (errstash_r, errstash_w) = Unix.pipe () in
|
||||
let pids = ref [] in
|
||||
let close_safe fd = try Unix.close fd with _ -> () in
|
||||
let open_in_redir = function
|
||||
| None -> Unix.stdin
|
||||
| Some path ->
|
||||
(try Unix.openfile path [Unix.O_RDONLY] 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
|
||||
in
|
||||
let open_out_redir path append =
|
||||
let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
|
||||
try Unix.openfile path flags 0o644
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
let stages_arr = Array.of_list stages in
|
||||
(try
|
||||
Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
|
||||
if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
|
||||
let argv = Array.of_list cleaned in
|
||||
let stdin_fd =
|
||||
if i = 0 then open_in_redir ip
|
||||
else fst pipes.(i - 1)
|
||||
in
|
||||
let stdout_fd =
|
||||
if i = n - 1 then
|
||||
(match op with
|
||||
| None -> final_w
|
||||
| Some path -> open_out_redir path app)
|
||||
else snd pipes.(i)
|
||||
in
|
||||
let stderr_fd =
|
||||
if merge then stdout_fd
|
||||
else (match ep with
|
||||
| None -> if i = n - 1 then errstash_w else Unix.stderr
|
||||
| Some path -> open_out_redir path false)
|
||||
in
|
||||
let pid =
|
||||
try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
|
||||
in
|
||||
pids := pid :: !pids;
|
||||
if i > 0 then close_safe (fst pipes.(i - 1));
|
||||
if i < n - 1 then close_safe (snd pipes.(i));
|
||||
if i = 0 && ip <> None then close_safe stdin_fd;
|
||||
if i = n - 1 && op <> None then close_safe stdout_fd;
|
||||
if not merge && ep <> None then close_safe stderr_fd
|
||||
) stages_arr
|
||||
with e ->
|
||||
close_safe final_r; close_safe final_w;
|
||||
close_safe errstash_r; close_safe errstash_w;
|
||||
Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
|
||||
raise e);
|
||||
close_safe final_w;
|
||||
close_safe errstash_w;
|
||||
let buf = Buffer.create 256 in
|
||||
let errbuf = Buffer.create 64 in
|
||||
let chunk = Bytes.create 4096 in
|
||||
let read_all fd target =
|
||||
try
|
||||
let stop = ref false in
|
||||
while not !stop do
|
||||
let r = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||
if r = 0 then stop := true
|
||||
else Buffer.add_subbytes target chunk 0 r
|
||||
done
|
||||
with _ -> ()
|
||||
in
|
||||
read_all final_r buf;
|
||||
read_all errstash_r errbuf;
|
||||
close_safe final_r;
|
||||
close_safe errstash_r;
|
||||
let exit_codes = List.rev_map (fun pid ->
|
||||
let (_, st) = Unix.waitpid [] pid in
|
||||
match st with
|
||||
| Unix.WEXITED c -> c
|
||||
| _ -> 1
|
||||
) !pids in
|
||||
let final_code = match List.rev exit_codes with
|
||||
| [] -> 0
|
||||
| last :: _ -> last
|
||||
in
|
||||
let s = Buffer.contents buf in
|
||||
let trimmed =
|
||||
if String.length s > 0 && s.[String.length s - 1] = '\n'
|
||||
then String.sub s 0 (String.length s - 1) else s
|
||||
in
|
||||
if final_code <> 0 then
|
||||
raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
|
||||
^ (if Buffer.length errbuf > 0
|
||||
then ": " ^ Buffer.contents errbuf
|
||||
else "")))
|
||||
else String trimmed);
|
||||
|
||||
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
||||
let resolve_inet_addr host =
|
||||
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
||||
|
||||
@@ -614,7 +614,7 @@ and cek_step_loop state =
|
||||
|
||||
(* cek-run *)
|
||||
and cek_run state =
|
||||
(let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (match !_cek_io_suspend_hook with Some hook -> hook final | None -> (raise (Eval_error (value_to_str (String "IO suspension in non-IO context"))))) else (cek_value (final))))
|
||||
(let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) else (cek_value (final))))
|
||||
|
||||
(* cek-resume *)
|
||||
and cek_resume suspended_state result' =
|
||||
@@ -759,78 +759,7 @@ and match_pattern pattern value env =
|
||||
|
||||
(* step-sf-match *)
|
||||
and step_sf_match args env kont =
|
||||
(let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let () = ignore (match_check_exhaustiveness val' clauses env) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))))
|
||||
|
||||
(* match-check-exhaustiveness — Step 8 hand-patched into sx_ref.ml *)
|
||||
and match_check_exhaustiveness val' clauses env =
|
||||
let is_else_pat p =
|
||||
match p with
|
||||
| Symbol "_" | Symbol "else" -> true
|
||||
| Keyword "else" -> true
|
||||
| _ -> false
|
||||
in
|
||||
let clause_is_else c =
|
||||
match c with
|
||||
| List (p :: _) -> is_else_pat p
|
||||
| _ -> false
|
||||
in
|
||||
let clause_ctor_name c =
|
||||
match c with
|
||||
| List (List (Symbol n :: _) :: _) -> Some n
|
||||
| _ -> None
|
||||
in
|
||||
let type_name_opt = match val' with
|
||||
| AdtValue a -> Some a.av_type
|
||||
| Dict d ->
|
||||
(match Hashtbl.find_opt d "_adt" with
|
||||
| Some (Bool true) ->
|
||||
(match Hashtbl.find_opt d "_type" with
|
||||
| Some (String s) -> Some s
|
||||
| _ -> None)
|
||||
| _ -> None)
|
||||
| _ -> None
|
||||
in
|
||||
match type_name_opt with
|
||||
| None -> Nil
|
||||
| Some type_name ->
|
||||
if not (sx_truthy (env_has env (String "*adt-registry*"))) then Nil
|
||||
else
|
||||
let registry = env_get env (String "*adt-registry*") in
|
||||
let registered = match registry with
|
||||
| Dict r ->
|
||||
(match Hashtbl.find_opt r type_name with
|
||||
| Some (List ctors) -> Some ctors
|
||||
| _ -> None)
|
||||
| _ -> None in
|
||||
(match registered with
|
||||
| None -> Nil
|
||||
| Some ctor_vals ->
|
||||
let clauses_list = match clauses with List xs -> xs | _ -> [] in
|
||||
if List.exists clause_is_else clauses_list then Nil
|
||||
else
|
||||
let clause_ctors = List.filter_map clause_ctor_name clauses_list in
|
||||
let registered_names = List.filter_map (function
|
||||
| String s -> Some s | _ -> None) ctor_vals in
|
||||
let missing = List.filter (fun c -> not (List.mem c clause_ctors)) registered_names in
|
||||
if missing = [] then Nil
|
||||
else begin
|
||||
if not (sx_truthy (env_has env (String "*adt-warned*"))) then
|
||||
ignore (env_bind env (String "*adt-warned*") (Dict (Hashtbl.create 4)));
|
||||
let warned = env_get env (String "*adt-warned*") in
|
||||
let key = type_name ^ "|" ^ String.concat "," missing in
|
||||
let already = match warned with
|
||||
| Dict w -> (match Hashtbl.find_opt w key with Some (Bool true) -> true | _ -> false)
|
||||
| _ -> false in
|
||||
if already then Nil
|
||||
else begin
|
||||
(match warned with
|
||||
| Dict w -> Hashtbl.replace w key (Bool true)
|
||||
| _ -> ());
|
||||
let msg = "[sx] match: non-exhaustive — " ^ type_name ^ ": missing " ^ String.concat ", " missing in
|
||||
ignore (host_warn (String msg));
|
||||
Nil
|
||||
end
|
||||
end)
|
||||
(let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont)))))
|
||||
|
||||
(* step-sf-handler-bind *)
|
||||
and step_sf_handler_bind args env kont =
|
||||
@@ -1052,14 +981,7 @@ let cek_run_iterative state =
|
||||
s := cek_step !s
|
||||
done;
|
||||
(match cek_suspended_p !s with
|
||||
| Bool true ->
|
||||
(* Propagate suspension via the OCaml-side hook so it converts to
|
||||
VmSuspended and flows to the outer driver (value_to_js / resume
|
||||
callback). Without the hook (pure CEK harness), keep the legacy
|
||||
error so test runners surface the misuse. *)
|
||||
(match !_cek_io_suspend_hook with
|
||||
| Some hook -> hook !s
|
||||
| None -> raise (Eval_error "IO suspension in non-IO context"))
|
||||
| Bool true -> raise (Eval_error "IO suspension in non-IO context")
|
||||
| _ -> cek_value !s)
|
||||
with Eval_error msg ->
|
||||
_last_error_kont_ref := cek_kont !s;
|
||||
@@ -1132,7 +1054,8 @@ let sf_define_type args env_val =
|
||||
(match pargs with
|
||||
| [v] ->
|
||||
(match v with
|
||||
| AdtValue a -> Bool (a.av_type = type_name)
|
||||
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
|
||||
(match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false))
|
||||
| _ -> Bool false)
|
||||
| _ -> Bool false)));
|
||||
List.iter (fun spec ->
|
||||
@@ -1146,18 +1069,21 @@ let sf_define_type args env_val =
|
||||
if List.length ctor_args <> arity then
|
||||
raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d"
|
||||
cn arity (List.length ctor_args)))
|
||||
else
|
||||
AdtValue {
|
||||
av_type = type_name;
|
||||
av_ctor = cn;
|
||||
av_fields = Array.of_list ctor_args;
|
||||
}));
|
||||
else begin
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "_adt" (Bool true);
|
||||
Hashtbl.replace d "_type" (String type_name);
|
||||
Hashtbl.replace d "_ctor" (String cn);
|
||||
Hashtbl.replace d "_fields" (List ctor_args);
|
||||
Dict d
|
||||
end));
|
||||
env_bind_v (cn ^ "?")
|
||||
(NativeFn (cn ^ "?", fun pargs ->
|
||||
(match pargs with
|
||||
| [v] ->
|
||||
(match v with
|
||||
| AdtValue a -> Bool (a.av_ctor = cn)
|
||||
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
|
||||
(match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false))
|
||||
| _ -> Bool false)
|
||||
| _ -> Bool false)));
|
||||
List.iteri (fun idx fname ->
|
||||
@@ -1166,10 +1092,13 @@ let sf_define_type args env_val =
|
||||
(match pargs with
|
||||
| [v] ->
|
||||
(match v with
|
||||
| AdtValue a ->
|
||||
if idx < Array.length a.av_fields then a.av_fields.(idx)
|
||||
else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
|
||||
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
|
||||
| Dict d ->
|
||||
(match Hashtbl.find_opt d "_fields" with
|
||||
| Some (List fs) ->
|
||||
if idx < List.length fs then List.nth fs idx
|
||||
else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
|
||||
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
|
||||
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict")))
|
||||
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg")))))
|
||||
) field_names
|
||||
| _ -> ())
|
||||
|
||||
@@ -6,72 +6,11 @@
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** Fast path equality — same as Sx_primitives.safe_eq for the common cases
|
||||
that show up in hot dispatch (string vs string, etc). Falls through to
|
||||
the registered "=" primitive for complex cases. *)
|
||||
let rec _fast_eq a b =
|
||||
if a == b then true
|
||||
else match a, b with
|
||||
| String x, String y -> x = y
|
||||
| Integer x, Integer y -> x = y
|
||||
| Number x, Number y -> x = y
|
||||
| Integer x, Number y -> float_of_int x = y
|
||||
| Number x, Integer y -> x = float_of_int y
|
||||
| Bool x, Bool y -> x = y
|
||||
| Nil, Nil -> true
|
||||
| Symbol x, Symbol y -> x = y
|
||||
| Keyword x, Keyword y -> x = y
|
||||
| List la, List lb ->
|
||||
(try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false)
|
||||
| _ -> false
|
||||
|
||||
(** Call a registered primitive by name.
|
||||
Fast path for hot dispatch primitives ([=], [<], [>], [<=], [>=], [empty?],
|
||||
[first], [rest], [len]) skips the Hashtbl lookup entirely — these are
|
||||
called millions of times in the CEK [step_continue]/[step_eval] dispatch. *)
|
||||
(** Call a registered primitive by name. *)
|
||||
let prim_call name args =
|
||||
(* Hot path: most-frequently-called primitives by step_continue dispatch *)
|
||||
match name, args with
|
||||
| "=", [a; b] -> Bool (_fast_eq a b)
|
||||
| "empty?", [List []] -> Bool true
|
||||
| "empty?", [List _] -> Bool false
|
||||
| "empty?", [ListRef { contents = [] }] -> Bool true
|
||||
| "empty?", [ListRef _] -> Bool false
|
||||
| "empty?", [Nil] -> Bool true
|
||||
| "first", [List (x :: _)] -> x
|
||||
| "first", [List []] -> Nil
|
||||
| "first", [ListRef { contents = (x :: _) }] -> x
|
||||
| "first", [ListRef _] -> Nil
|
||||
| "first", [Nil] -> Nil
|
||||
| "rest", [List (_ :: xs)] -> List xs
|
||||
| "rest", [List []] -> List []
|
||||
| "rest", [ListRef { contents = (_ :: xs) }] -> List xs
|
||||
| "rest", [ListRef _] -> List []
|
||||
| "rest", [Nil] -> List []
|
||||
| "len", [List l] -> Integer (List.length l)
|
||||
| "len", [ListRef r] -> Integer (List.length !r)
|
||||
| "len", [String s] -> Integer (String.length s)
|
||||
| "len", [Nil] -> Integer 0
|
||||
| "<", [Integer x; Integer y] -> Bool (x < y)
|
||||
| "<", [Number x; Number y] -> Bool (x < y)
|
||||
| "<", [Integer x; Number y] -> Bool (float_of_int x < y)
|
||||
| "<", [Number x; Integer y] -> Bool (x < float_of_int y)
|
||||
| ">", [Integer x; Integer y] -> Bool (x > y)
|
||||
| ">", [Number x; Number y] -> Bool (x > y)
|
||||
| ">", [Integer x; Number y] -> Bool (float_of_int x > y)
|
||||
| ">", [Number x; Integer y] -> Bool (x > float_of_int y)
|
||||
| "<=", [Integer x; Integer y] -> Bool (x <= y)
|
||||
| "<=", [Number x; Number y] -> Bool (x <= y)
|
||||
| "<=", [Integer x; Number y] -> Bool (float_of_int x <= y)
|
||||
| "<=", [Number x; Integer y] -> Bool (x <= float_of_int y)
|
||||
| ">=", [Integer x; Integer y] -> Bool (x >= y)
|
||||
| ">=", [Number x; Number y] -> Bool (x >= y)
|
||||
| ">=", [Integer x; Number y] -> Bool (float_of_int x >= y)
|
||||
| ">=", [Number x; Integer y] -> Bool (x >= float_of_int y)
|
||||
| _ ->
|
||||
match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f args
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f args
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
|
||||
(** Convert any SX value to an OCaml string (internal). *)
|
||||
let value_to_str = function
|
||||
@@ -270,13 +209,6 @@ let get_val container key =
|
||||
| _ -> Nil)
|
||||
| Dict d, String k -> dict_get d k
|
||||
| Dict d, Keyword k -> dict_get d k
|
||||
| AdtValue a, String k | AdtValue a, Keyword k ->
|
||||
(match k with
|
||||
| "_adt" -> Bool true
|
||||
| "_type" -> String a.av_type
|
||||
| "_ctor" -> String a.av_ctor
|
||||
| "_fields" -> List (Array.to_list a.av_fields)
|
||||
| _ -> Nil)
|
||||
| (List l | ListRef { contents = l }), Number n ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| (List l | ListRef { contents = l }), Integer n ->
|
||||
@@ -472,10 +404,6 @@ let callcc_continuation_winders_len v = match v with
|
||||
let host_error msg =
|
||||
raise (Eval_error (value_to_str msg))
|
||||
|
||||
let host_warn msg =
|
||||
prerr_endline (value_to_str msg);
|
||||
Nil
|
||||
|
||||
let dynamic_wind_call before body after _env =
|
||||
ignore (sx_call before []);
|
||||
let result = sx_call body [] in
|
||||
|
||||
@@ -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 =
|
||||
@@ -530,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
|
||||
@@ -817,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 "\\\""
|
||||
@@ -834,129 +822,66 @@ let rec inspect_into buf = function
|
||||
| '\r' -> Buffer.add_string buf "\\r"
|
||||
| '\t' -> Buffer.add_string buf "\\t"
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.add_char buf '"'
|
||||
| Symbol s -> Buffer.add_string buf s
|
||||
| Keyword k -> Buffer.add_char buf ':'; Buffer.add_string buf k
|
||||
Buffer.add_char buf '"';
|
||||
Buffer.contents buf
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
Buffer.add_char buf '(';
|
||||
(match items with
|
||||
| [] -> ()
|
||||
| x :: rest ->
|
||||
inspect_into buf x;
|
||||
List.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) rest);
|
||||
Buffer.add_char buf ')'
|
||||
"(" ^ String.concat " " (List.map inspect items) ^ ")"
|
||||
| Dict d ->
|
||||
Buffer.add_char buf '{';
|
||||
let first = ref true in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if !first then first := false else Buffer.add_char buf ' ';
|
||||
Buffer.add_char buf ':'; Buffer.add_string buf k;
|
||||
Buffer.add_char buf ' '; inspect_into buf v) d;
|
||||
Buffer.add_char buf '}'
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| Lambda l ->
|
||||
let tag = match l.l_name with Some n -> n | None -> "lambda" in
|
||||
Buffer.add_char buf '<'; Buffer.add_string buf tag;
|
||||
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " l.l_params);
|
||||
Buffer.add_string buf ")>"
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
|
||||
| Component c ->
|
||||
Buffer.add_string buf "<Component ~"; Buffer.add_string buf c.c_name;
|
||||
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " c.c_params);
|
||||
Buffer.add_string buf ")>"
|
||||
Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
|
||||
| Island i ->
|
||||
Buffer.add_string buf "<Island ~"; Buffer.add_string buf i.i_name;
|
||||
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " i.i_params);
|
||||
Buffer.add_string buf ")>"
|
||||
Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
|
||||
| Macro m ->
|
||||
let tag = match m.m_name with Some n -> n | None -> "macro" in
|
||||
Buffer.add_char buf '<'; Buffer.add_string buf tag;
|
||||
Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " m.m_params);
|
||||
Buffer.add_string buf ")>"
|
||||
| Thunk _ -> Buffer.add_string buf "<thunk>"
|
||||
| Continuation (_, _) -> Buffer.add_string buf "<continuation>"
|
||||
| CallccContinuation (_, _) -> Buffer.add_string buf "<callcc-continuation>"
|
||||
| NativeFn (name, _) ->
|
||||
Buffer.add_string buf "<native:"; Buffer.add_string buf name; Buffer.add_char buf '>'
|
||||
| Signal _ -> Buffer.add_string buf "<signal>"
|
||||
| RawHTML s ->
|
||||
Buffer.add_string buf "\"<raw-html:";
|
||||
Buffer.add_string buf (string_of_int (String.length s));
|
||||
Buffer.add_string buf ">\""
|
||||
| Spread _ -> Buffer.add_string buf "<spread>"
|
||||
| SxExpr s ->
|
||||
Buffer.add_string buf "\"<sx-expr:";
|
||||
Buffer.add_string buf (string_of_int (String.length s));
|
||||
Buffer.add_string buf ">\""
|
||||
| Env _ -> Buffer.add_string buf "<env>"
|
||||
| CekState _ -> Buffer.add_string buf "<cek-state>"
|
||||
| CekFrame f ->
|
||||
Buffer.add_string buf "<frame:"; Buffer.add_string buf f.cf_type; Buffer.add_char buf '>'
|
||||
| VmClosure cl ->
|
||||
Buffer.add_string buf "<vm:";
|
||||
Buffer.add_string buf (match cl.vm_name with Some n -> n | None -> "anon");
|
||||
Buffer.add_char buf '>'
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
|
||||
| Thunk _ -> "<thunk>"
|
||||
| Continuation (_, _) -> "<continuation>"
|
||||
| CallccContinuation (_, _) -> "<callcc-continuation>"
|
||||
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
|
||||
| Signal _ -> "<signal>"
|
||||
| RawHTML s -> Printf.sprintf "\"<raw-html:%d>\"" (String.length s)
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "\"<sx-expr:%d>\"" (String.length s)
|
||||
| Env _ -> "<env>"
|
||||
| CekState _ -> "<cek-state>"
|
||||
| CekFrame f -> Printf.sprintf "<frame:%s>" f.cf_type
|
||||
| VmClosure cl -> Printf.sprintf "<vm:%s>" (match cl.vm_name with Some n -> n | None -> "anon")
|
||||
| Record r ->
|
||||
Buffer.add_string buf "<record:"; Buffer.add_string buf r.r_type.rt_name;
|
||||
Array.iteri (fun i v ->
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf r.r_type.rt_fields.(i);
|
||||
Buffer.add_char buf '=';
|
||||
inspect_into buf v) r.r_fields;
|
||||
Buffer.add_char buf '>'
|
||||
| Parameter p ->
|
||||
Buffer.add_string buf "<parameter:"; Buffer.add_string buf p.pm_uid; Buffer.add_char buf '>'
|
||||
let fields = Array.to_list (Array.mapi (fun i v ->
|
||||
Printf.sprintf "%s=%s" r.r_type.rt_fields.(i) (inspect v)
|
||||
) r.r_fields) in
|
||||
Printf.sprintf "<record:%s %s>" r.r_type.rt_name (String.concat " " fields)
|
||||
| Parameter p -> Printf.sprintf "<parameter:%s>" p.pm_uid
|
||||
| Vector arr ->
|
||||
Buffer.add_string buf "#(";
|
||||
Array.iteri (fun i v ->
|
||||
if i > 0 then Buffer.add_char buf ' ';
|
||||
inspect_into buf v) arr;
|
||||
Buffer.add_char buf ')'
|
||||
| VmFrame f ->
|
||||
Buffer.add_string buf (Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base)
|
||||
| VmMachine m ->
|
||||
Buffer.add_string buf (Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames))
|
||||
| StringBuffer b ->
|
||||
Buffer.add_string buf (Printf.sprintf "<string-buffer:%d>" (Buffer.length b))
|
||||
| HashTable ht ->
|
||||
Buffer.add_string buf (Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht))
|
||||
let elts = Array.to_list (Array.map inspect arr) in
|
||||
Printf.sprintf "#(%s)" (String.concat " " elts)
|
||||
| VmFrame f -> Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base
|
||||
| VmMachine m -> Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames)
|
||||
| StringBuffer buf -> Printf.sprintf "<string-buffer:%d>" (Buffer.length buf)
|
||||
| HashTable ht -> Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht)
|
||||
| Char n ->
|
||||
Buffer.add_string buf "#\\";
|
||||
(match n with
|
||||
| 32 -> Buffer.add_string buf "space"
|
||||
| 10 -> Buffer.add_string buf "newline"
|
||||
| 9 -> Buffer.add_string buf "tab"
|
||||
| 13 -> Buffer.add_string buf "return"
|
||||
| 0 -> Buffer.add_string buf "nul"
|
||||
| 27 -> Buffer.add_string buf "escape"
|
||||
| 127 -> Buffer.add_string buf "delete"
|
||||
| 8 -> Buffer.add_string buf "backspace"
|
||||
| _ -> Buffer.add_utf_8_uchar buf (Uchar.of_int n))
|
||||
| Eof -> Buffer.add_string buf "#!eof"
|
||||
let name = match n with
|
||||
| 32 -> "space" | 10 -> "newline" | 9 -> "tab"
|
||||
| 13 -> "return" | 0 -> "nul" | 27 -> "escape"
|
||||
| 127 -> "delete" | 8 -> "backspace"
|
||||
| _ -> let buf = Buffer.create 1 in
|
||||
Buffer.add_utf_8_uchar buf (Uchar.of_int n);
|
||||
Buffer.contents buf
|
||||
in "#\\" ^ name
|
||||
| Eof -> "#!eof"
|
||||
| Port { sp_kind = PortInput (_, pos); sp_closed } ->
|
||||
Buffer.add_string buf (Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else ""))
|
||||
| Port { sp_kind = PortOutput b; sp_closed } ->
|
||||
Buffer.add_string buf (Printf.sprintf "<output-port:len=%d%s>" (Buffer.length b) (if sp_closed then ":closed" else ""))
|
||||
| Rational (n, d) ->
|
||||
Buffer.add_string buf (string_of_int n); Buffer.add_char buf '/';
|
||||
Buffer.add_string buf (string_of_int d)
|
||||
| SxSet ht ->
|
||||
Buffer.add_string buf (Printf.sprintf "<set:%d>" (Hashtbl.length ht))
|
||||
| SxRegexp (src, flags, _) ->
|
||||
Buffer.add_string buf "#/"; Buffer.add_string buf src;
|
||||
Buffer.add_char buf '/'; Buffer.add_string buf flags
|
||||
| SxBytevector b ->
|
||||
Buffer.add_string buf "#u8(";
|
||||
let n = Bytes.length b in
|
||||
for i = 0 to n - 1 do
|
||||
if i > 0 then Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf (string_of_int (Char.code (Bytes.get b i)))
|
||||
done;
|
||||
Buffer.add_char buf ')'
|
||||
| AdtValue a ->
|
||||
Buffer.add_char buf '('; Buffer.add_string buf a.av_ctor;
|
||||
Array.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) a.av_fields;
|
||||
Buffer.add_char buf ')'
|
||||
|
||||
let inspect v =
|
||||
let buf = Buffer.create 64 in
|
||||
inspect_into buf v;
|
||||
Buffer.contents buf
|
||||
Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else "")
|
||||
| Port { sp_kind = PortOutput buf; sp_closed } ->
|
||||
Printf.sprintf "<output-port:len=%d%s>" (Buffer.length buf) (if sp_closed then ":closed" else "")
|
||||
| Rational (n, d) -> Printf.sprintf "%d/%d" n d
|
||||
| SxSet ht -> Printf.sprintf "<set:%d>" (Hashtbl.length ht)
|
||||
| SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags
|
||||
| SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i)))))
|
||||
|
||||
@@ -327,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
|
||||
|
||||
@@ -642,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 _ ->
|
||||
@@ -744,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)))
|
||||
@@ -917,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;
|
||||
@@ -1309,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
|
||||
@@ -1432,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
|
||||
|
||||
@@ -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,576 +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-parse-op-glyph?
|
||||
(fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
|
||||
|
||||
; ============================================================
|
||||
; Token accessors
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
apl-parse-fn-glyph?
|
||||
(fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs)))
|
||||
|
||||
(define tok-type (fn (tok) (get tok :type)))
|
||||
|
||||
(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)))))
|
||||
|
||||
; ============================================================
|
||||
; Collect trailing operators starting at index i
|
||||
; Returns {:ops (op ...) :end new-i}
|
||||
; ============================================================
|
||||
|
||||
(define
|
||||
is-fn-tok?
|
||||
(fn
|
||||
(tok)
|
||||
(or
|
||||
(and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok)))
|
||||
(and
|
||||
(= (tok-type tok) :name)
|
||||
(some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)))))
|
||||
|
||||
(define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list))))
|
||||
|
||||
; ============================================================
|
||||
; Build a derived-fn node by chaining operators left-to-right
|
||||
; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
|
||||
; ============================================================
|
||||
|
||||
(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})))))
|
||||
|
||||
; ============================================================
|
||||
; Find matching close bracket/paren/brace
|
||||
; Returns the index of the matching close token
|
||||
; ============================================================
|
||||
|
||||
(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)))
|
||||
|
||||
; ============================================================
|
||||
; 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
|
||||
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 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
|
||||
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)
|
||||
(if
|
||||
(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})))))
|
||||
(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
|
||||
((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 "⍵"))
|
||||
(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)
|
||||
(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)))
|
||||
|
||||
; 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
|
||||
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)))))
|
||||
|
||||
|
||||
; ============================================================
|
||||
; Split token list on statement separators (diamond / newline)
|
||||
; Only splits at depth 0 (ignores separators inside { } or ( ) )
|
||||
; ============================================================
|
||||
|
||||
(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)))
|
||||
|
||||
; ============================================================
|
||||
; Parse a dfn body (tokens between { and })
|
||||
; Handles guard expressions: cond : expr
|
||||
; ============================================================
|
||||
|
||||
(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)))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(define
|
||||
find-top-level-colon
|
||||
(fn (tokens i) (find-top-level-colon-loop tokens i 0)))
|
||||
|
||||
; ============================================================
|
||||
; Parse a single statement (assignment or expression)
|
||||
; ============================================================
|
||||
|
||||
(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)))))))
|
||||
|
||||
; ============================================================
|
||||
; Parse an expression from a flat token list
|
||||
; ============================================================
|
||||
|
||||
(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))))
|
||||
|
||||
; ============================================================
|
||||
; Main entry point
|
||||
; parse-apl: string → AST
|
||||
; ============================================================
|
||||
|
||||
(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)))
|
||||
(if
|
||||
(= (len stmt-groups) 0)
|
||||
nil
|
||||
(if
|
||||
(= (len stmt-groups) 1)
|
||||
(parse-stmt (first stmt-groups))
|
||||
(cons :program (map parse-stmt stmt-groups))))))))
|
||||
|
||||
(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
|
||||
((idx-expr (parse-apl-expr inner-tokens)))
|
||||
(let
|
||||
((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
|
||||
(maybe-bracket indexed tokens next-after)))))
|
||||
(list val-node after))))
|
||||
1536
lib/apl/runtime.sx
1536
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,37 +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")
|
||||
(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,180 +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))
|
||||
@@ -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 = … : boolean — count is exactly 3 or exactly 4
|
||||
⍝ 1 ⍵ ∨.∧ … : "alive next" iff (count=3) or (alive AND count=4)
|
||||
⍝ ⊃ … : disclose 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,168 +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 {:type type :value value})))
|
||||
|
||||
(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! "")))
|
||||
(tok-push! :num (- 0 (parse-int digits 0))))
|
||||
(scan!)))
|
||||
((apl-digit? ch)
|
||||
(begin
|
||||
(let ((digits (read-digits! "")))
|
||||
(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? "⎕") (consume! "⎕") (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,460 +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 "⎕FMT") apl-quad-fmt)
|
||||
(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)
|
||||
(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 :vec)
|
||||
(let
|
||||
((items (rest node)))
|
||||
(let
|
||||
((vals (map (fn (n) (apl-eval-ast n env)) items)))
|
||||
(make-array
|
||||
(list (len vals))
|
||||
(map (fn (v) (first (get v :ravel))) vals)))))
|
||||
((= tag :name)
|
||||
(let
|
||||
((nm (nth node 1)))
|
||||
(cond
|
||||
((= nm "⍺") (get env "alpha"))
|
||||
((= nm "⍵") (get env "omega"))
|
||||
((= 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))
|
||||
((apl-resolve-monadic fn-node env) (apl-eval-ast arg env)))))
|
||||
((= 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))
|
||||
((apl-resolve-dyadic fn-node env)
|
||||
(apl-eval-ast lhs env)
|
||||
(apl-eval-ast rhs env)))))
|
||||
((= tag :program) (apl-eval-stmts (rest node) env))
|
||||
((= tag :dfn) node)
|
||||
(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")))))
|
||||
(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 :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)))))
|
||||
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
||||
|
||||
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
|
||||
@@ -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 |
|
||||
|-------|------|------|--------|
|
||||
|
||||
@@ -1008,27 +1008,11 @@
|
||||
(let
|
||||
((name (symbol-name head))
|
||||
(argc (len args))
|
||||
(specialized-op (cond
|
||||
(and (= argc 2) (= name "+")) 160
|
||||
(and (= argc 2) (= name "-")) 161
|
||||
(and (= argc 2) (= name "*")) 162
|
||||
(and (= argc 2) (= name "/")) 163
|
||||
(and (= argc 2) (= name "=")) 164
|
||||
(and (= argc 2) (= name "<")) 165
|
||||
(and (= argc 2) (= name ">")) 166
|
||||
(and (= argc 2) (= name "cons")) 172
|
||||
(and (= argc 1) (= name "not")) 167
|
||||
(and (= argc 1) (= name "len")) 168
|
||||
(and (= argc 1) (= name "first")) 169
|
||||
(and (= argc 1) (= name "rest")) 170
|
||||
:else nil)))
|
||||
(name-idx (pool-add (get em "pool") name)))
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
(if specialized-op
|
||||
(emit-op em specialized-op)
|
||||
(let ((name-idx (pool-add (get em "pool") name)))
|
||||
(emit-op em 52)
|
||||
(emit-u16 em name-idx)
|
||||
(emit-byte em argc))))
|
||||
(emit-op em 52)
|
||||
(emit-u16 em name-idx)
|
||||
(emit-byte em argc))
|
||||
(do
|
||||
(compile-expr em head scope false)
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
|
||||
@@ -1,16 +1,16 @@
|
||||
{
|
||||
"language": "erlang",
|
||||
"total_pass": 0,
|
||||
"total": 0,
|
||||
"total_pass": 530,
|
||||
"total": 530,
|
||||
"suites": [
|
||||
{"name":"tokenize","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"parse","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"eval","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"runtime","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"ring","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"ping-pong","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"bank","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"echo","pass":0,"total":0,"status":"ok"},
|
||||
{"name":"fib","pass":0,"total":0,"status":"ok"}
|
||||
{"name":"tokenize","pass":62,"total":62,"status":"ok"},
|
||||
{"name":"parse","pass":52,"total":52,"status":"ok"},
|
||||
{"name":"eval","pass":346,"total":346,"status":"ok"},
|
||||
{"name":"runtime","pass":39,"total":39,"status":"ok"},
|
||||
{"name":"ring","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"ping-pong","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"bank","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"echo","pass":7,"total":7,"status":"ok"},
|
||||
{"name":"fib","pass":8,"total":8,"status":"ok"}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -1,18 +1,18 @@
|
||||
# Erlang-on-SX Scoreboard
|
||||
|
||||
**Total: 0 / 0 tests passing**
|
||||
**Total: 530 / 530 tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
| ✅ | tokenize | 0 | 0 |
|
||||
| ✅ | parse | 0 | 0 |
|
||||
| ✅ | eval | 0 | 0 |
|
||||
| ✅ | runtime | 0 | 0 |
|
||||
| ✅ | ring | 0 | 0 |
|
||||
| ✅ | ping-pong | 0 | 0 |
|
||||
| ✅ | bank | 0 | 0 |
|
||||
| ✅ | echo | 0 | 0 |
|
||||
| ✅ | fib | 0 | 0 |
|
||||
| ✅ | tokenize | 62 | 62 |
|
||||
| ✅ | parse | 52 | 52 |
|
||||
| ✅ | eval | 346 | 346 |
|
||||
| ✅ | runtime | 39 | 39 |
|
||||
| ✅ | ring | 4 | 4 |
|
||||
| ✅ | ping-pong | 4 | 4 |
|
||||
| ✅ | bank | 8 | 8 |
|
||||
| ✅ | echo | 7 | 7 |
|
||||
| ✅ | fib | 8 | 8 |
|
||||
|
||||
|
||||
Generated by `lib/erlang/conformance.sh`.
|
||||
|
||||
@@ -1,92 +0,0 @@
|
||||
;; lib/guest/ast.sx — canonical AST node shapes.
|
||||
;;
|
||||
;; A guest's parser may emit its own AST in whatever shape is convenient
|
||||
;; for that language's evaluator/transpiler. This file gives a SHARED
|
||||
;; canonical shape that cross-language tools (formatters, highlighters,
|
||||
;; debuggers) can target without per-language adapters.
|
||||
;;
|
||||
;; Each canonical node is a tagged list: (KIND ...payload).
|
||||
;;
|
||||
;; Constructors (return a canonical node):
|
||||
;;
|
||||
;; (ast-literal VALUE) — number / string / bool / nil
|
||||
;; (ast-var NAME) — identifier reference
|
||||
;; (ast-app FN ARGS) — function application
|
||||
;; (ast-lambda PARAMS BODY) — anonymous function
|
||||
;; (ast-let BINDINGS BODY) — local bindings
|
||||
;; (ast-letrec BINDINGS BODY) — recursive local bindings
|
||||
;; (ast-if TEST THEN ELSE) — conditional
|
||||
;; (ast-match-clause PATTERN BODY) — one match arm
|
||||
;; (ast-module NAME BODY) — module declaration
|
||||
;; (ast-import NAME) — import directive
|
||||
;;
|
||||
;; Predicates: (ast-literal? X), (ast-var? X), …
|
||||
;; Generic: (ast? X) — any canonical node
|
||||
;; (ast-kind X) — :literal / :var / :app / …
|
||||
;;
|
||||
;; Accessors (one per payload field):
|
||||
;; (ast-literal-value N)
|
||||
;; (ast-var-name N)
|
||||
;; (ast-app-fn N) (ast-app-args N)
|
||||
;; (ast-lambda-params N) (ast-lambda-body N)
|
||||
;; (ast-let-bindings N) (ast-let-body N)
|
||||
;; (ast-letrec-bindings N) (ast-letrec-body N)
|
||||
;; (ast-if-test N) (ast-if-then N) (ast-if-else N)
|
||||
;; (ast-match-clause-pattern N)
|
||||
;; (ast-match-clause-body N)
|
||||
;; (ast-module-name N) (ast-module-body N)
|
||||
;; (ast-import-name N)
|
||||
|
||||
(define ast-literal (fn (v) (list :literal v)))
|
||||
(define ast-var (fn (n) (list :var n)))
|
||||
(define ast-app (fn (f args) (list :app f args)))
|
||||
(define ast-lambda (fn (ps body) (list :lambda ps body)))
|
||||
(define ast-let (fn (bs body) (list :let bs body)))
|
||||
(define ast-letrec (fn (bs body) (list :letrec bs body)))
|
||||
(define ast-if (fn (t th el) (list :if t th el)))
|
||||
(define ast-match-clause (fn (p body) (list :match-clause p body)))
|
||||
(define ast-module (fn (n body) (list :module n body)))
|
||||
(define ast-import (fn (n) (list :import n)))
|
||||
|
||||
(define ast-kind (fn (x) (if (and (list? x) (not (empty? x))) (first x) nil)))
|
||||
|
||||
(define
|
||||
ast?
|
||||
(fn (x)
|
||||
(and (list? x)
|
||||
(not (empty? x))
|
||||
(let ((k (first x)))
|
||||
(or (= k :literal) (= k :var) (= k :app)
|
||||
(= k :lambda) (= k :let) (= k :letrec)
|
||||
(= k :if) (= k :match-clause)
|
||||
(= k :module) (= k :import))))))
|
||||
|
||||
(define ast-literal? (fn (x) (and (ast? x) (= (first x) :literal))))
|
||||
(define ast-var? (fn (x) (and (ast? x) (= (first x) :var))))
|
||||
(define ast-app? (fn (x) (and (ast? x) (= (first x) :app))))
|
||||
(define ast-lambda? (fn (x) (and (ast? x) (= (first x) :lambda))))
|
||||
(define ast-let? (fn (x) (and (ast? x) (= (first x) :let))))
|
||||
(define ast-letrec? (fn (x) (and (ast? x) (= (first x) :letrec))))
|
||||
(define ast-if? (fn (x) (and (ast? x) (= (first x) :if))))
|
||||
(define ast-match-clause? (fn (x) (and (ast? x) (= (first x) :match-clause))))
|
||||
(define ast-module? (fn (x) (and (ast? x) (= (first x) :module))))
|
||||
(define ast-import? (fn (x) (and (ast? x) (= (first x) :import))))
|
||||
|
||||
(define ast-literal-value (fn (n) (nth n 1)))
|
||||
(define ast-var-name (fn (n) (nth n 1)))
|
||||
(define ast-app-fn (fn (n) (nth n 1)))
|
||||
(define ast-app-args (fn (n) (nth n 2)))
|
||||
(define ast-lambda-params (fn (n) (nth n 1)))
|
||||
(define ast-lambda-body (fn (n) (nth n 2)))
|
||||
(define ast-let-bindings (fn (n) (nth n 1)))
|
||||
(define ast-let-body (fn (n) (nth n 2)))
|
||||
(define ast-letrec-bindings (fn (n) (nth n 1)))
|
||||
(define ast-letrec-body (fn (n) (nth n 2)))
|
||||
(define ast-if-test (fn (n) (nth n 1)))
|
||||
(define ast-if-then (fn (n) (nth n 2)))
|
||||
(define ast-if-else (fn (n) (nth n 3)))
|
||||
(define ast-match-clause-pattern (fn (n) (nth n 1)))
|
||||
(define ast-match-clause-body (fn (n) (nth n 2)))
|
||||
(define ast-module-name (fn (n) (nth n 1)))
|
||||
(define ast-module-body (fn (n) (nth n 2)))
|
||||
(define ast-import-name (fn (n) (nth n 1)))
|
||||
@@ -1,18 +0,0 @@
|
||||
{
|
||||
"lang": "apl",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/apl/test.sh",
|
||||
"totals": {
|
||||
"pass": 73,
|
||||
"fail": 0,
|
||||
"total": 73
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "all",
|
||||
"pass": 73,
|
||||
"fail": 0,
|
||||
"total": 73
|
||||
}
|
||||
]
|
||||
}
|
||||
@@ -1,86 +0,0 @@
|
||||
{
|
||||
"lang": "common-lisp",
|
||||
"captured": "2026-05-06T22:59:46Z",
|
||||
"suite_command": "bash lib/common-lisp/conformance.sh",
|
||||
"totals": {
|
||||
"pass": 518,
|
||||
"fail": 0,
|
||||
"total": 518
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "Phase 1: tokenizer/reader",
|
||||
"pass": 79,
|
||||
"fail": 0,
|
||||
"total": 79
|
||||
},
|
||||
{
|
||||
"name": "Phase 1: parser/lambda-lists",
|
||||
"pass": 31,
|
||||
"fail": 0,
|
||||
"total": 31
|
||||
},
|
||||
{
|
||||
"name": "Phase 2: evaluator",
|
||||
"pass": 182,
|
||||
"fail": 0,
|
||||
"total": 182
|
||||
},
|
||||
{
|
||||
"name": "Phase 3: condition system",
|
||||
"pass": 59,
|
||||
"fail": 0,
|
||||
"total": 59
|
||||
},
|
||||
{
|
||||
"name": "Phase 3: restart-demo",
|
||||
"pass": 7,
|
||||
"fail": 0,
|
||||
"total": 7
|
||||
},
|
||||
{
|
||||
"name": "Phase 3: parse-recover",
|
||||
"pass": 6,
|
||||
"fail": 0,
|
||||
"total": 6
|
||||
},
|
||||
{
|
||||
"name": "Phase 3: interactive-debugger",
|
||||
"pass": 7,
|
||||
"fail": 0,
|
||||
"total": 7
|
||||
},
|
||||
{
|
||||
"name": "Phase 4: CLOS",
|
||||
"pass": 41,
|
||||
"fail": 0,
|
||||
"total": 41
|
||||
},
|
||||
{
|
||||
"name": "Phase 4: geometry",
|
||||
"pass": 12,
|
||||
"fail": 0,
|
||||
"total": 12
|
||||
},
|
||||
{
|
||||
"name": "Phase 4: mop-trace",
|
||||
"pass": 13,
|
||||
"fail": 0,
|
||||
"total": 13
|
||||
},
|
||||
{
|
||||
"name": "Phase 5: macros+LOOP",
|
||||
"pass": 27,
|
||||
"fail": 0,
|
||||
"total": 27
|
||||
},
|
||||
{
|
||||
"name": "Phase 6: stdlib",
|
||||
"pass": 54,
|
||||
"fail": 0,
|
||||
"total": 54
|
||||
}
|
||||
],
|
||||
"source_scoreboard": "lib/common-lisp/scoreboard.json",
|
||||
"note": "Step 2: previous baseline (309) was lower because Phase 2 (evaluator, +182 tests) and Phase 6 (stdlib, +27 tests) results were under-counted by the original conformance.sh's parser. Re-running with prefix.sx loaded reveals true counts. No tests regressed."
|
||||
}
|
||||
@@ -1,67 +0,0 @@
|
||||
{
|
||||
"lang": "erlang",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/erlang/conformance.sh",
|
||||
"totals": {
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "tokenize",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "parse",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "eval",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "runtime",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "ring",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "ping-pong",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "bank",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "echo",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
},
|
||||
{
|
||||
"name": "fib",
|
||||
"pass": 0,
|
||||
"fail": 0,
|
||||
"total": 0
|
||||
}
|
||||
],
|
||||
"source_scoreboard": "lib/erlang/scoreboard.json"
|
||||
}
|
||||
@@ -1,18 +0,0 @@
|
||||
{
|
||||
"lang": "forth",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/forth/test.sh",
|
||||
"totals": {
|
||||
"pass": 64,
|
||||
"fail": 0,
|
||||
"total": 64
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "all",
|
||||
"pass": 64,
|
||||
"fail": 0,
|
||||
"total": 64
|
||||
}
|
||||
]
|
||||
}
|
||||
@@ -1,122 +0,0 @@
|
||||
{
|
||||
"lang": "haskell",
|
||||
"captured": "2026-05-06T22:46:16Z",
|
||||
"suite_command": "bash lib/haskell/conformance.sh",
|
||||
"totals": {
|
||||
"pass": 156,
|
||||
"fail": 0,
|
||||
"total": 156
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "fib",
|
||||
"pass": 2,
|
||||
"fail": 0,
|
||||
"total": 2
|
||||
},
|
||||
{
|
||||
"name": "sieve",
|
||||
"pass": 2,
|
||||
"fail": 0,
|
||||
"total": 2
|
||||
},
|
||||
{
|
||||
"name": "quicksort",
|
||||
"pass": 5,
|
||||
"fail": 0,
|
||||
"total": 5
|
||||
},
|
||||
{
|
||||
"name": "nqueens",
|
||||
"pass": 2,
|
||||
"fail": 0,
|
||||
"total": 2
|
||||
},
|
||||
{
|
||||
"name": "calculator",
|
||||
"pass": 5,
|
||||
"fail": 0,
|
||||
"total": 5
|
||||
},
|
||||
{
|
||||
"name": "collatz",
|
||||
"pass": 11,
|
||||
"fail": 0,
|
||||
"total": 11
|
||||
},
|
||||
{
|
||||
"name": "palindrome",
|
||||
"pass": 8,
|
||||
"fail": 0,
|
||||
"total": 8
|
||||
},
|
||||
{
|
||||
"name": "maybe",
|
||||
"pass": 12,
|
||||
"fail": 0,
|
||||
"total": 12
|
||||
},
|
||||
{
|
||||
"name": "fizzbuzz",
|
||||
"pass": 12,
|
||||
"fail": 0,
|
||||
"total": 12
|
||||
},
|
||||
{
|
||||
"name": "anagram",
|
||||
"pass": 9,
|
||||
"fail": 0,
|
||||
"total": 9
|
||||
},
|
||||
{
|
||||
"name": "roman",
|
||||
"pass": 14,
|
||||
"fail": 0,
|
||||
"total": 14
|
||||
},
|
||||
{
|
||||
"name": "binary",
|
||||
"pass": 12,
|
||||
"fail": 0,
|
||||
"total": 12
|
||||
},
|
||||
{
|
||||
"name": "either",
|
||||
"pass": 12,
|
||||
"fail": 0,
|
||||
"total": 12
|
||||
},
|
||||
{
|
||||
"name": "primes",
|
||||
"pass": 12,
|
||||
"fail": 0,
|
||||
"total": 12
|
||||
},
|
||||
{
|
||||
"name": "zipwith",
|
||||
"pass": 9,
|
||||
"fail": 0,
|
||||
"total": 9
|
||||
},
|
||||
{
|
||||
"name": "matrix",
|
||||
"pass": 8,
|
||||
"fail": 0,
|
||||
"total": 8
|
||||
},
|
||||
{
|
||||
"name": "wordcount",
|
||||
"pass": 7,
|
||||
"fail": 0,
|
||||
"total": 7
|
||||
},
|
||||
{
|
||||
"name": "powers",
|
||||
"pass": 14,
|
||||
"fail": 0,
|
||||
"total": 14
|
||||
}
|
||||
],
|
||||
"source_scoreboard": "lib/haskell/scoreboard.json",
|
||||
"note": "Step 1: previous baseline (0/18) was an artefact of the old conformance.sh bug \u2014 its (ok-len 3 ...) grep never matched, defaulting every program to 0 pass / 1 fail. Shared driver in Step 1 reads counters correctly."
|
||||
}
|
||||
@@ -1,75 +0,0 @@
|
||||
{
|
||||
"lang": "js",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/js/conformance.sh",
|
||||
"totals": {
|
||||
"pass": 94,
|
||||
"fail": 54,
|
||||
"total": 148
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "test262-slice",
|
||||
"pass": 94,
|
||||
"fail": 54,
|
||||
"total": 148,
|
||||
"failing_tests": [
|
||||
"arithmetic/bitnot",
|
||||
"arithmetic/mixed_concat",
|
||||
"async/await_promise_all",
|
||||
"closures/sum_sq",
|
||||
"coercion/implicit_str_add",
|
||||
"collections/array_index",
|
||||
"collections/array_nested",
|
||||
"collections/string_index",
|
||||
"functions/rest_param",
|
||||
"loops/for_break",
|
||||
"loops/for_continue",
|
||||
"loops/nested_for",
|
||||
"loops/while_basic",
|
||||
"loops/while_break_infinite",
|
||||
"objects/array_filter_reduce",
|
||||
"objects/array_map",
|
||||
"objects/array_method_chain",
|
||||
"objects/array_mutate",
|
||||
"objects/array_push_length",
|
||||
"objects/arrow_lexical_this",
|
||||
"objects/class_basic",
|
||||
"objects/class_extend_chain",
|
||||
"objects/class_inherit",
|
||||
"objects/counter_closure",
|
||||
"objects/in_operator",
|
||||
"objects/instanceof",
|
||||
"objects/method_this",
|
||||
"objects/new_constructor",
|
||||
"objects/object_mutate",
|
||||
"objects/prototype_chain",
|
||||
"objects/string_method",
|
||||
"objects/string_slice",
|
||||
"promises/executor_throws",
|
||||
"promises/finally_passthrough",
|
||||
"promises/microtask_ordering",
|
||||
"promises/new_promise_reject",
|
||||
"promises/new_promise_resolve",
|
||||
"promises/promise_all",
|
||||
"promises/promise_all_empty",
|
||||
"promises/promise_all_nonpromise",
|
||||
"promises/promise_all_reject",
|
||||
"promises/promise_race",
|
||||
"promises/promise_resolve_already_promise",
|
||||
"promises/reject_catch",
|
||||
"promises/resolve_adopts",
|
||||
"promises/resolve_then",
|
||||
"promises/then_chain",
|
||||
"promises/then_throw_catch",
|
||||
"statements/block_scope",
|
||||
"statements/const_multi",
|
||||
"statements/if_else_false",
|
||||
"statements/if_else_true",
|
||||
"statements/let_init",
|
||||
"statements/var_decl"
|
||||
]
|
||||
}
|
||||
],
|
||||
"source_scoreboard": "lib/js/conformance.sh-output"
|
||||
}
|
||||
@@ -1,18 +0,0 @@
|
||||
{
|
||||
"lang": "lua",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/lua/test.sh",
|
||||
"totals": {
|
||||
"pass": 185,
|
||||
"fail": 0,
|
||||
"total": 185
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "all",
|
||||
"pass": 185,
|
||||
"fail": 0,
|
||||
"total": 185
|
||||
}
|
||||
]
|
||||
}
|
||||
@@ -1,187 +0,0 @@
|
||||
{
|
||||
"lang": "prolog",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/prolog/conformance.sh",
|
||||
"totals": {
|
||||
"pass": 590,
|
||||
"fail": 0,
|
||||
"total": 590
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "parse",
|
||||
"pass": 25,
|
||||
"fail": 0,
|
||||
"total": 25
|
||||
},
|
||||
{
|
||||
"name": "unify",
|
||||
"pass": 47,
|
||||
"fail": 0,
|
||||
"total": 47
|
||||
},
|
||||
{
|
||||
"name": "clausedb",
|
||||
"pass": 14,
|
||||
"fail": 0,
|
||||
"total": 14
|
||||
},
|
||||
{
|
||||
"name": "solve",
|
||||
"pass": 62,
|
||||
"fail": 0,
|
||||
"total": 62
|
||||
},
|
||||
{
|
||||
"name": "operators",
|
||||
"pass": 19,
|
||||
"fail": 0,
|
||||
"total": 19
|
||||
},
|
||||
{
|
||||
"name": "dynamic",
|
||||
"pass": 11,
|
||||
"fail": 0,
|
||||
"total": 11
|
||||
},
|
||||
{
|
||||
"name": "findall",
|
||||
"pass": 11,
|
||||
"fail": 0,
|
||||
"total": 11
|
||||
},
|
||||
{
|
||||
"name": "term_inspect",
|
||||
"pass": 14,
|
||||
"fail": 0,
|
||||
"total": 14
|
||||
},
|
||||
{
|
||||
"name": "append",
|
||||
"pass": 6,
|
||||
"fail": 0,
|
||||
"total": 6
|
||||
},
|
||||
{
|
||||
"name": "reverse",
|
||||
"pass": 6,
|
||||
"fail": 0,
|
||||
"total": 6
|
||||
},
|
||||
{
|
||||
"name": "member",
|
||||
"pass": 7,
|
||||
"fail": 0,
|
||||
"total": 7
|
||||
},
|
||||
{
|
||||
"name": "nqueens",
|
||||
"pass": 6,
|
||||
"fail": 0,
|
||||
"total": 6
|
||||
},
|
||||
{
|
||||
"name": "family",
|
||||
"pass": 10,
|
||||
"fail": 0,
|
||||
"total": 10
|
||||
},
|
||||
{
|
||||
"name": "atoms",
|
||||
"pass": 34,
|
||||
"fail": 0,
|
||||
"total": 34
|
||||
},
|
||||
{
|
||||
"name": "query_api",
|
||||
"pass": 16,
|
||||
"fail": 0,
|
||||
"total": 16
|
||||
},
|
||||
{
|
||||
"name": "iso_predicates",
|
||||
"pass": 29,
|
||||
"fail": 0,
|
||||
"total": 29
|
||||
},
|
||||
{
|
||||
"name": "meta_predicates",
|
||||
"pass": 25,
|
||||
"fail": 0,
|
||||
"total": 25
|
||||
},
|
||||
{
|
||||
"name": "list_predicates",
|
||||
"pass": 33,
|
||||
"fail": 0,
|
||||
"total": 33
|
||||
},
|
||||
{
|
||||
"name": "meta_call",
|
||||
"pass": 15,
|
||||
"fail": 0,
|
||||
"total": 15
|
||||
},
|
||||
{
|
||||
"name": "set_predicates",
|
||||
"pass": 15,
|
||||
"fail": 0,
|
||||
"total": 15
|
||||
},
|
||||
{
|
||||
"name": "char_predicates",
|
||||
"pass": 27,
|
||||
"fail": 0,
|
||||
"total": 27
|
||||
},
|
||||
{
|
||||
"name": "io_predicates",
|
||||
"pass": 24,
|
||||
"fail": 0,
|
||||
"total": 24
|
||||
},
|
||||
{
|
||||
"name": "assert_rules",
|
||||
"pass": 15,
|
||||
"fail": 0,
|
||||
"total": 15
|
||||
},
|
||||
{
|
||||
"name": "string_agg",
|
||||
"pass": 25,
|
||||
"fail": 0,
|
||||
"total": 25
|
||||
},
|
||||
{
|
||||
"name": "advanced",
|
||||
"pass": 21,
|
||||
"fail": 0,
|
||||
"total": 21
|
||||
},
|
||||
{
|
||||
"name": "compiler",
|
||||
"pass": 17,
|
||||
"fail": 0,
|
||||
"total": 17
|
||||
},
|
||||
{
|
||||
"name": "cross_validate",
|
||||
"pass": 17,
|
||||
"fail": 0,
|
||||
"total": 17
|
||||
},
|
||||
{
|
||||
"name": "integration",
|
||||
"pass": 20,
|
||||
"fail": 0,
|
||||
"total": 20
|
||||
},
|
||||
{
|
||||
"name": "hs_bridge",
|
||||
"pass": 19,
|
||||
"fail": 0,
|
||||
"total": 19
|
||||
}
|
||||
],
|
||||
"source_scoreboard": "lib/prolog/scoreboard.json"
|
||||
}
|
||||
@@ -1,18 +0,0 @@
|
||||
{
|
||||
"lang": "ruby",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/ruby/test.sh",
|
||||
"totals": {
|
||||
"pass": 76,
|
||||
"fail": 0,
|
||||
"total": 76
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "all",
|
||||
"pass": 76,
|
||||
"fail": 0,
|
||||
"total": 76
|
||||
}
|
||||
]
|
||||
}
|
||||
@@ -1,25 +0,0 @@
|
||||
{
|
||||
"lang": "smalltalk",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/smalltalk/conformance.sh",
|
||||
"totals": {
|
||||
"pass": 625,
|
||||
"fail": 4,
|
||||
"total": 629
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "all",
|
||||
"pass": 625,
|
||||
"fail": 4,
|
||||
"total": 629
|
||||
},
|
||||
{
|
||||
"name": "classic-corpus",
|
||||
"pass": 4,
|
||||
"fail": 1,
|
||||
"total": 5
|
||||
}
|
||||
],
|
||||
"source_scoreboard": "lib/smalltalk/scoreboard.json"
|
||||
}
|
||||
@@ -1,37 +0,0 @@
|
||||
{
|
||||
"lang": "tcl",
|
||||
"captured": "2026-05-06T22:01:00Z",
|
||||
"suite_command": "bash lib/tcl/conformance.sh",
|
||||
"totals": {
|
||||
"pass": 3,
|
||||
"fail": 1,
|
||||
"total": 4
|
||||
},
|
||||
"suites": [
|
||||
{
|
||||
"name": "assert",
|
||||
"pass": 1,
|
||||
"fail": 0,
|
||||
"total": 1
|
||||
},
|
||||
{
|
||||
"name": "event-loop",
|
||||
"pass": 0,
|
||||
"fail": 1,
|
||||
"total": 1
|
||||
},
|
||||
{
|
||||
"name": "for-each-line",
|
||||
"pass": 1,
|
||||
"fail": 0,
|
||||
"total": 1
|
||||
},
|
||||
{
|
||||
"name": "with-temp-var",
|
||||
"pass": 1,
|
||||
"fail": 0,
|
||||
"total": 1
|
||||
}
|
||||
],
|
||||
"source_scoreboard": "lib/tcl/scoreboard.json"
|
||||
}
|
||||
@@ -1,221 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# lib/guest/conformance.sh — shared, config-driven conformance driver.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/guest/conformance.sh <conf-file>
|
||||
#
|
||||
# The conf file is a bash file that sets:
|
||||
# LANG_NAME e.g. prolog
|
||||
# PRELOADS=( ... ) .sx files to load before any suite (path from repo root)
|
||||
# SUITES=( ... ) colon-separated entries; format depends on MODE
|
||||
# MODE "dict" or "counters"
|
||||
# COUNTERS_PASS (counters mode) global symbol for the pass counter
|
||||
# COUNTERS_FAIL (counters mode) global symbol for the fail counter
|
||||
# TIMEOUT_PER_SUITE (optional, counters mode) seconds per suite, default 120
|
||||
# SCOREBOARD_DIR (optional) defaults to lib/$LANG_NAME
|
||||
#
|
||||
# It may override the bash functions emit_scoreboard_json / emit_scoreboard_md
|
||||
# to produce the per-language scoreboard schema. Defaults are provided.
|
||||
#
|
||||
# Suite formats:
|
||||
# MODE=dict — "name:test-file:(runner-fn)"
|
||||
# The runner expression is evaluated and is expected to
|
||||
# return a dict with :passed/:failed/:total.
|
||||
# MODE=counters — "name:test-file"
|
||||
# Each suite is run in a fresh sx_server session: preloads
|
||||
# are loaded, then the test file, then counters are read.
|
||||
# The suite is treated as starting from counters (0, 0).
|
||||
#
|
||||
# Output:
|
||||
# Writes $SCOREBOARD_DIR/scoreboard.json and $SCOREBOARD_DIR/scoreboard.md.
|
||||
# Exits 0 if every suite is green, 1 otherwise.
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
if [ "$#" -lt 1 ]; then
|
||||
echo "usage: $0 <conf-file>" >&2
|
||||
exit 2
|
||||
fi
|
||||
|
||||
CONF="$1"
|
||||
if [ ! -f "$CONF" ]; then
|
||||
echo "config not found: $CONF" >&2
|
||||
exit 2
|
||||
fi
|
||||
|
||||
# Defaults — the conf file may override these.
|
||||
LANG_NAME=
|
||||
PRELOADS=()
|
||||
SUITES=()
|
||||
MODE=dict
|
||||
COUNTERS_PASS=
|
||||
COUNTERS_FAIL=
|
||||
TIMEOUT_PER_SUITE=120
|
||||
SCOREBOARD_DIR=
|
||||
|
||||
emit_scoreboard_json() {
|
||||
# Generic schema. Per-lang configs override this for byte-equality with
|
||||
# historical scoreboards.
|
||||
local n=${#GC_NAMES[@]} i sep
|
||||
printf '{\n'
|
||||
printf ' "lang": "%s",\n' "$LANG_NAME"
|
||||
printf ' "total_passed": %d,\n' "$GC_TOTAL_PASS"
|
||||
printf ' "total_failed": %d,\n' "$GC_TOTAL_FAIL"
|
||||
printf ' "total": %d,\n' "$GC_TOTAL"
|
||||
printf ' "suites": ['
|
||||
for ((i=0; i<n; i++)); do
|
||||
sep=","; [ $i -eq $((n-1)) ] && sep=""
|
||||
printf '\n {"name":"%s","passed":%d,"failed":%d,"total":%d}%s' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "${GC_TOTAL_S[$i]}" "$sep"
|
||||
done
|
||||
printf '\n ],\n'
|
||||
printf ' "generated": "%s"\n' "$(date -Iseconds 2>/dev/null || date)"
|
||||
printf '}\n'
|
||||
}
|
||||
|
||||
emit_scoreboard_md() {
|
||||
local n=${#GC_NAMES[@]} i status
|
||||
printf '# %s scoreboard\n\n' "$LANG_NAME"
|
||||
printf '**%d / %d passing** (%d failure(s)).\n\n' "$GC_TOTAL_PASS" "$GC_TOTAL" "$GC_TOTAL_FAIL"
|
||||
printf '| Suite | Passed | Total | Status |\n'
|
||||
printf '|-------|--------|-------|--------|\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
status="ok"; [ "${GC_FAIL[$i]}" -gt 0 ] && status="FAIL"
|
||||
printf '| %s | %d | %d | %s |\n' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_TOTAL_S[$i]}" "$status"
|
||||
done
|
||||
}
|
||||
|
||||
# shellcheck disable=SC1090
|
||||
source "$CONF"
|
||||
|
||||
if [ -z "$LANG_NAME" ]; then
|
||||
echo "LANG_NAME not set in $CONF" >&2
|
||||
exit 2
|
||||
fi
|
||||
SCOREBOARD_DIR="${SCOREBOARD_DIR:-lib/$LANG_NAME}"
|
||||
|
||||
SX="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX" ]; then
|
||||
MAIN_ROOT=$(git worktree list 2>/dev/null | head -1 | awk '{print $1}')
|
||||
if [ -n "${MAIN_ROOT:-}" ] && [ -x "$MAIN_ROOT/$SX" ]; then
|
||||
SX="$MAIN_ROOT/$SX"
|
||||
else
|
||||
echo "ERROR: sx_server.exe not found (set SX_SERVER to override)." >&2
|
||||
exit 2
|
||||
fi
|
||||
fi
|
||||
|
||||
GC_NAMES=()
|
||||
GC_PASS=()
|
||||
GC_FAIL=()
|
||||
GC_TOTAL_S=()
|
||||
|
||||
parse_result_line() {
|
||||
# Match a (gc-result "name" P F T) line.
|
||||
local line="$1"
|
||||
if [[ "$line" =~ ^\(gc-result\ \"([^\"]+)\"\ ([0-9]+)\ ([0-9]+)\ ([0-9]+)\)$ ]]; then
|
||||
GC_NAMES+=("${BASH_REMATCH[1]}")
|
||||
GC_PASS+=("${BASH_REMATCH[2]}")
|
||||
GC_FAIL+=("${BASH_REMATCH[3]}")
|
||||
GC_TOTAL_S+=("${BASH_REMATCH[4]}")
|
||||
return 0
|
||||
fi
|
||||
return 1
|
||||
}
|
||||
|
||||
case "$MODE" in
|
||||
dict)
|
||||
SCRIPT='(epoch 1)
|
||||
'
|
||||
for f in "${PRELOADS[@]}"; do
|
||||
SCRIPT+='(load "'"$f"'")
|
||||
'
|
||||
done
|
||||
SCRIPT+='(load "lib/guest/conformance.sx")
|
||||
'
|
||||
for entry in "${SUITES[@]}"; do
|
||||
IFS=: read -r _ file _ <<< "$entry"
|
||||
SCRIPT+='(load "'"$file"'")
|
||||
'
|
||||
done
|
||||
SCRIPT+='(epoch 2)
|
||||
'
|
||||
for entry in "${SUITES[@]}"; do
|
||||
IFS=: read -r name _ runner <<< "$entry"
|
||||
SCRIPT+='(eval "(gc-dict-result \"'"$name"'\" '"$runner"')")
|
||||
'
|
||||
done
|
||||
OUTPUT=$(printf '%s' "$SCRIPT" | "$SX" 2>&1)
|
||||
expected=${#SUITES[@]}
|
||||
matched=0
|
||||
while IFS= read -r line; do
|
||||
if parse_result_line "$line"; then
|
||||
matched=$((matched + 1))
|
||||
fi
|
||||
done <<< "$OUTPUT"
|
||||
if [ "$matched" -ne "$expected" ]; then
|
||||
echo "Expected $expected suite results, got $matched" >&2
|
||||
echo "---- raw output ----" >&2
|
||||
printf '%s\n' "$OUTPUT" >&2
|
||||
exit 3
|
||||
fi
|
||||
;;
|
||||
counters)
|
||||
if [ -z "$COUNTERS_PASS" ] || [ -z "$COUNTERS_FAIL" ]; then
|
||||
echo "MODE=counters requires COUNTERS_PASS and COUNTERS_FAIL in $CONF" >&2
|
||||
exit 2
|
||||
fi
|
||||
for entry in "${SUITES[@]}"; do
|
||||
IFS=: read -r name file <<< "$entry"
|
||||
TMPFILE=$(mktemp)
|
||||
{
|
||||
printf '(epoch 1)\n'
|
||||
for f in "${PRELOADS[@]}"; do printf '(load "%s")\n' "$f"; done
|
||||
printf '(load "lib/guest/conformance.sx")\n'
|
||||
printf '(epoch 2)\n'
|
||||
printf '(load "%s")\n' "$file"
|
||||
printf '(epoch 3)\n'
|
||||
printf '(eval "(gc-counters-result \\"%s\\" 0 0 %s %s)")\n' \
|
||||
"$name" "$COUNTERS_PASS" "$COUNTERS_FAIL"
|
||||
} > "$TMPFILE"
|
||||
OUTPUT=$(timeout "$TIMEOUT_PER_SUITE" "$SX" < "$TMPFILE" 2>&1 || true)
|
||||
rm -f "$TMPFILE"
|
||||
result=$(printf '%s\n' "$OUTPUT" | grep -E '^\(gc-result ' | tail -1 || true)
|
||||
if [ -n "$result" ] && parse_result_line "$result"; then
|
||||
:
|
||||
else
|
||||
# Suite hung or crashed before emitting a result. Record 0/1 so it
|
||||
# shows up as a failure rather than vanishing.
|
||||
GC_NAMES+=("$name")
|
||||
GC_PASS+=(0)
|
||||
GC_FAIL+=(1)
|
||||
GC_TOTAL_S+=(1)
|
||||
fi
|
||||
done
|
||||
;;
|
||||
*)
|
||||
echo "Unknown MODE=$MODE in $CONF (expected dict|counters)" >&2
|
||||
exit 2
|
||||
;;
|
||||
esac
|
||||
|
||||
GC_TOTAL_PASS=0
|
||||
GC_TOTAL_FAIL=0
|
||||
GC_TOTAL=0
|
||||
for ((i=0; i<${#GC_NAMES[@]}; i++)); do
|
||||
GC_TOTAL_PASS=$((GC_TOTAL_PASS + GC_PASS[i]))
|
||||
GC_TOTAL_FAIL=$((GC_TOTAL_FAIL + GC_FAIL[i]))
|
||||
GC_TOTAL=$((GC_TOTAL + GC_TOTAL_S[i]))
|
||||
done
|
||||
|
||||
mkdir -p "$SCOREBOARD_DIR"
|
||||
emit_scoreboard_json > "$SCOREBOARD_DIR/scoreboard.json"
|
||||
emit_scoreboard_md > "$SCOREBOARD_DIR/scoreboard.md"
|
||||
|
||||
if [ "$GC_TOTAL_FAIL" -gt 0 ]; then
|
||||
echo "$GC_TOTAL_FAIL failure(s) across $GC_TOTAL tests" >&2
|
||||
exit 1
|
||||
fi
|
||||
echo "All $GC_TOTAL tests pass."
|
||||
@@ -1,40 +0,0 @@
|
||||
;; lib/guest/conformance.sx — shared helpers for the guest conformance driver.
|
||||
;;
|
||||
;; The bash driver lib/guest/conformance.sh loads this file and then for each
|
||||
;; suite emits an (eval "...") form whose result is a tagged list:
|
||||
;;
|
||||
;; (gc-result NAME PASSED FAILED TOTAL)
|
||||
;;
|
||||
;; The driver greps these from sx_server's output and aggregates them.
|
||||
;;
|
||||
;; Two suite shapes are supported:
|
||||
;;
|
||||
;; :dict — runner expression returns a dict with :passed/:failed/:total.
|
||||
;; (gc-dict-result "parse" (pl-parse-tests-run!))
|
||||
;;
|
||||
;; :counters — runner has no return value, mutates pass/fail global counters.
|
||||
;; (gc-counters-result NAME P0 F0 PASS FAIL)
|
||||
;; where P0/F0 are the counters captured BEFORE the suite ran
|
||||
;; and PASS/FAIL are the counters AFTER.
|
||||
|
||||
(define
|
||||
gc-dict-result
|
||||
(fn
|
||||
(name r)
|
||||
(list
|
||||
(quote gc-result)
|
||||
name
|
||||
(get r :passed)
|
||||
(get r :failed)
|
||||
(get r :total))))
|
||||
|
||||
(define
|
||||
gc-counters-result
|
||||
(fn
|
||||
(name p0 f0 p1 f1)
|
||||
(list
|
||||
(quote gc-result)
|
||||
name
|
||||
(- p1 p0)
|
||||
(- f1 f0)
|
||||
(- (+ p1 f1) (+ p0 f0)))))
|
||||
@@ -1,67 +0,0 @@
|
||||
;; lib/guest/lex.sx — character-class predicates and token primitives shared
|
||||
;; across guest tokenisers.
|
||||
;;
|
||||
;; All predicates are nil-safe — they accept nil (end-of-input) and return
|
||||
;; false. This matches the convention used by the existing per-language
|
||||
;; tokenisers (cur returns nil at EOF).
|
||||
;;
|
||||
;; Char classes
|
||||
;; ------------
|
||||
;; lex-digit? — 0-9
|
||||
;; lex-hex-digit? — 0-9, a-f, A-F
|
||||
;; lex-alpha? — a-z, A-Z (alias: lex-letter?)
|
||||
;; lex-alnum? — alpha or digit
|
||||
;; lex-ident-start? — alpha or underscore
|
||||
;; lex-ident-char? — ident-start or digit
|
||||
;; lex-space? — " ", "\t", "\r" (no newline)
|
||||
;; lex-whitespace? — " ", "\t", "\r", "\n" (includes newline)
|
||||
;;
|
||||
;; Token record
|
||||
;; ------------
|
||||
;; (lex-make-token TYPE VALUE POS) — {:type :value :pos}
|
||||
;; (lex-make-token-spanning TYPE VALUE POS END)
|
||||
;; — {:type :value :pos :end}
|
||||
;; (lex-token-type TOK)
|
||||
;; (lex-token-value TOK)
|
||||
;; (lex-token-pos TOK)
|
||||
|
||||
(define lex-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
|
||||
|
||||
(define
|
||||
lex-hex-digit?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or
|
||||
(lex-digit? c)
|
||||
(and (>= c "a") (<= c "f"))
|
||||
(and (>= c "A") (<= c "F"))))))
|
||||
|
||||
(define
|
||||
lex-alpha?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define lex-letter? lex-alpha?)
|
||||
|
||||
(define lex-alnum? (fn (c) (or (lex-alpha? c) (lex-digit? c))))
|
||||
|
||||
(define lex-ident-start? (fn (c) (or (lex-alpha? c) (= c "_"))))
|
||||
|
||||
(define lex-ident-char? (fn (c) (or (lex-ident-start? c) (lex-digit? c))))
|
||||
|
||||
(define lex-space? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
|
||||
|
||||
(define lex-whitespace? (fn (c) (or (lex-space? c) (= c "\n"))))
|
||||
|
||||
(define lex-make-token (fn (type value pos) {:pos pos :value value :type type}))
|
||||
|
||||
(define lex-make-token-spanning (fn (type value pos end) {:pos pos :end end :value value :type type}))
|
||||
|
||||
(define lex-token-type (fn (tok) (get tok :type)))
|
||||
(define lex-token-value (fn (tok) (get tok :value)))
|
||||
(define lex-token-pos (fn (tok) (get tok :pos)))
|
||||
@@ -1,28 +0,0 @@
|
||||
;; lib/guest/pratt.sx — operator-table format + lookup for Pratt-style
|
||||
;; precedence climbing.
|
||||
;;
|
||||
;; The climbing loop stays per-language because the two canaries use
|
||||
;; opposite conventions (Lua: higher prec = tighter; Prolog: lower prec =
|
||||
;; tighter, with xfx/xfy/yfx assoc tags). Forcing a single loop adds
|
||||
;; callback indirection that obscures more than it shares.
|
||||
;;
|
||||
;; What IS shared and gets extracted: the operator-table format and lookup.
|
||||
;; "Grammar is a dict, not hardcoded cond."
|
||||
;;
|
||||
;; Entry shape: (NAME PREC ASSOC).
|
||||
;; NAME — string, the operator's source token.
|
||||
;; PREC — integer, in the host's own convention.
|
||||
;; ASSOC — :left | :right | :none for languages with traditional
|
||||
;; associativity, or "xfx" / "xfy" / "yfx" for Prolog-style.
|
||||
|
||||
(define
|
||||
pratt-op-lookup
|
||||
(fn (table name)
|
||||
(cond
|
||||
((empty? table) nil)
|
||||
((= (first (first table)) name) (first table))
|
||||
(:else (pratt-op-lookup (rest table) name)))))
|
||||
|
||||
(define pratt-op-name (fn (entry) (first entry)))
|
||||
(define pratt-op-prec (fn (entry) (nth entry 1)))
|
||||
(define pratt-op-assoc (fn (entry) (nth entry 2)))
|
||||
@@ -1,46 +0,0 @@
|
||||
;; lib/guest/prefix.sx — prefix-rename macro.
|
||||
;;
|
||||
;; A guest runtime often re-exports a stretch of host primitives under a
|
||||
;; language-specific prefix. The prefix-rename macro replaces the repeated
|
||||
;; (define lang-foo foo) boilerplate with a single declarative call.
|
||||
;;
|
||||
;; Two entry shapes are supported:
|
||||
;;
|
||||
;; (prefix-rename "cl-" '(gcd lcm expt floor truncate))
|
||||
;; ;; expands to (begin (define cl-gcd gcd)
|
||||
;; ;; (define cl-lcm lcm) ...)
|
||||
;;
|
||||
;; (prefix-rename "cl-"
|
||||
;; '((mod modulo)
|
||||
;; (arrayp? vector?)
|
||||
;; (ceiling ceil)))
|
||||
;; ;; expands to (begin (define cl-mod modulo)
|
||||
;; ;; (define cl-arrayp? vector?)
|
||||
;; ;; (define cl-ceiling ceil))
|
||||
;;
|
||||
;; Mixed lists are supported — bare symbols are same-name aliases, two-element
|
||||
;; lists are (alias target) pairs.
|
||||
|
||||
(defmacro
|
||||
prefix-rename
|
||||
(prefix entries-q)
|
||||
(let
|
||||
((entries (nth entries-q 1)))
|
||||
(cons
|
||||
(quote begin)
|
||||
(map
|
||||
(fn
|
||||
(entry)
|
||||
(cond
|
||||
((= (type-of entry) "symbol")
|
||||
(list
|
||||
(quote define)
|
||||
(make-symbol (str prefix (symbol-name entry)))
|
||||
entry))
|
||||
((and (list? entry) (= (len entry) 2))
|
||||
(list
|
||||
(quote define)
|
||||
(make-symbol (str prefix (symbol-name (first entry))))
|
||||
(nth entry 1)))
|
||||
(:else (error (str "prefix-rename: invalid entry " entry)))))
|
||||
entries))))
|
||||
@@ -1,63 +0,0 @@
|
||||
;; lib/guest/tests/ast.sx — exercises every constructor / predicate /
|
||||
;; accessor in lib/guest/ast.sx so future ports have a stable contract
|
||||
;; to point at.
|
||||
|
||||
(define gast-test-pass 0)
|
||||
(define gast-test-fail 0)
|
||||
(define gast-test-fails (list))
|
||||
|
||||
(define
|
||||
gast-test
|
||||
(fn (name actual expected)
|
||||
(if (= actual expected)
|
||||
(set! gast-test-pass (+ gast-test-pass 1))
|
||||
(begin
|
||||
(set! gast-test-fail (+ gast-test-fail 1))
|
||||
(append! gast-test-fails {:name name :expected expected :actual actual})))))
|
||||
|
||||
;; Constructors round-trip.
|
||||
(gast-test "literal-int" (ast-literal-value (ast-literal 42)) 42)
|
||||
(gast-test "literal-str" (ast-literal-value (ast-literal "hi")) "hi")
|
||||
(gast-test "literal-bool" (ast-literal-value (ast-literal true)) true)
|
||||
(gast-test "var-name" (ast-var-name (ast-var "x")) "x")
|
||||
(gast-test "app-fn" (ast-app-fn (ast-app (ast-var "f") (list (ast-literal 1)))) (ast-var "f"))
|
||||
(gast-test "app-args-len" (len (ast-app-args (ast-app (ast-var "f") (list (ast-literal 1))))) 1)
|
||||
(gast-test "lambda-params" (ast-lambda-params (ast-lambda (list "x" "y") (ast-var "x"))) (list "x" "y"))
|
||||
(gast-test "lambda-body" (ast-lambda-body (ast-lambda (list "x") (ast-var "x"))) (ast-var "x"))
|
||||
(gast-test "let-bindings" (len (ast-let-bindings (ast-let (list {:name "x" :value (ast-literal 1)}) (ast-var "x")))) 1)
|
||||
(gast-test "letrec-body" (ast-letrec-body (ast-letrec (list) (ast-literal 0))) (ast-literal 0))
|
||||
(gast-test "if-test" (ast-if-test (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal true))
|
||||
(gast-test "if-then" (ast-if-then (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 1))
|
||||
(gast-test "if-else" (ast-if-else (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 0))
|
||||
(gast-test "match-pattern" (ast-match-clause-pattern (ast-match-clause "P" (ast-literal 1))) "P")
|
||||
(gast-test "match-body" (ast-match-clause-body (ast-match-clause "P" (ast-literal 1))) (ast-literal 1))
|
||||
(gast-test "module-name" (ast-module-name (ast-module "m" (list))) "m")
|
||||
(gast-test "import-name" (ast-import-name (ast-import "lib/foo")) "lib/foo")
|
||||
|
||||
;; Predicates fire only on matching kinds.
|
||||
(gast-test "is-literal" (ast-literal? (ast-literal 1)) true)
|
||||
(gast-test "not-literal" (ast-literal? (ast-var "x")) false)
|
||||
(gast-test "is-var" (ast-var? (ast-var "x")) true)
|
||||
(gast-test "is-app" (ast-app? (ast-app (ast-var "f") (list))) true)
|
||||
(gast-test "is-lambda" (ast-lambda? (ast-lambda (list) (ast-literal 0))) true)
|
||||
(gast-test "is-let" (ast-let? (ast-let (list) (ast-literal 0))) true)
|
||||
(gast-test "is-letrec" (ast-letrec? (ast-letrec (list) (ast-literal 0))) true)
|
||||
(gast-test "is-if" (ast-if? (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) true)
|
||||
(gast-test "is-match" (ast-match-clause? (ast-match-clause "P" (ast-literal 1))) true)
|
||||
(gast-test "is-module" (ast-module? (ast-module "m" (list))) true)
|
||||
(gast-test "is-import" (ast-import? (ast-import "x")) true)
|
||||
|
||||
;; ast? recognises any canonical node.
|
||||
(gast-test "ast?-literal" (ast? (ast-literal 0)) true)
|
||||
(gast-test "ast?-foreign" (ast? (list "lua-num" 0)) false)
|
||||
(gast-test "ast?-non-list" (ast? 42) false)
|
||||
|
||||
;; ast-kind dispatch.
|
||||
(gast-test "kind-literal" (ast-kind (ast-literal 0)) :literal)
|
||||
(gast-test "kind-import" (ast-kind (ast-import "x")) :import)
|
||||
|
||||
(define gast-tests-run!
|
||||
(fn ()
|
||||
{:passed gast-test-pass
|
||||
:failed gast-test-fail
|
||||
:total (+ gast-test-pass gast-test-fail)}))
|
||||
@@ -1,76 +0,0 @@
|
||||
# Haskell-on-SX conformance config — sourced by lib/guest/conformance.sh.
|
||||
|
||||
LANG_NAME=haskell
|
||||
MODE=counters
|
||||
COUNTERS_PASS=hk-test-pass
|
||||
COUNTERS_FAIL=hk-test-fail
|
||||
TIMEOUT_PER_SUITE=120
|
||||
|
||||
PRELOADS=(
|
||||
lib/haskell/tokenizer.sx
|
||||
lib/haskell/layout.sx
|
||||
lib/haskell/parser.sx
|
||||
lib/haskell/desugar.sx
|
||||
lib/haskell/runtime.sx
|
||||
lib/haskell/match.sx
|
||||
lib/haskell/eval.sx
|
||||
lib/haskell/testlib.sx
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"fib:lib/haskell/tests/program-fib.sx"
|
||||
"sieve:lib/haskell/tests/program-sieve.sx"
|
||||
"quicksort:lib/haskell/tests/program-quicksort.sx"
|
||||
"nqueens:lib/haskell/tests/program-nqueens.sx"
|
||||
"calculator:lib/haskell/tests/program-calculator.sx"
|
||||
"collatz:lib/haskell/tests/program-collatz.sx"
|
||||
"palindrome:lib/haskell/tests/program-palindrome.sx"
|
||||
"maybe:lib/haskell/tests/program-maybe.sx"
|
||||
"fizzbuzz:lib/haskell/tests/program-fizzbuzz.sx"
|
||||
"anagram:lib/haskell/tests/program-anagram.sx"
|
||||
"roman:lib/haskell/tests/program-roman.sx"
|
||||
"binary:lib/haskell/tests/program-binary.sx"
|
||||
"either:lib/haskell/tests/program-either.sx"
|
||||
"primes:lib/haskell/tests/program-primes.sx"
|
||||
"zipwith:lib/haskell/tests/program-zipwith.sx"
|
||||
"matrix:lib/haskell/tests/program-matrix.sx"
|
||||
"wordcount:lib/haskell/tests/program-wordcount.sx"
|
||||
"powers:lib/haskell/tests/program-powers.sx"
|
||||
)
|
||||
|
||||
emit_scoreboard_json() {
|
||||
local n=${#GC_NAMES[@]} i sep date_only
|
||||
date_only=$(date '+%Y-%m-%d')
|
||||
printf '{\n'
|
||||
printf ' "date": "%s",\n' "$date_only"
|
||||
printf ' "total_pass": %d,\n' "$GC_TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$GC_TOTAL_FAIL"
|
||||
printf ' "programs": {\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
sep=","; [ $i -eq $((n-1)) ] && sep=""
|
||||
printf ' "%s": {"pass": %d, "fail": %d}%s\n' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "$sep"
|
||||
done
|
||||
printf ' }\n'
|
||||
printf '}\n'
|
||||
}
|
||||
|
||||
emit_scoreboard_md() {
|
||||
local n=${#GC_NAMES[@]}
|
||||
local i status p f t prog_pass=0 prog_total=$n date_only
|
||||
date_only=$(date '+%Y-%m-%d')
|
||||
for ((i=0; i<n; i++)); do
|
||||
[ "${GC_FAIL[$i]}" -eq 0 ] && prog_pass=$((prog_pass + 1))
|
||||
done
|
||||
printf '# Haskell-on-SX Scoreboard\n\n'
|
||||
printf 'Updated %s · Phase 6 (prelude extras + 18 programs)\n\n' "$date_only"
|
||||
printf '| Program | Tests | Status |\n'
|
||||
printf '|---------|-------|--------|\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
p=${GC_PASS[$i]}; f=${GC_FAIL[$i]}; t=${GC_TOTAL_S[$i]}
|
||||
[ "$f" -eq 0 ] && status="✓" || status="✗"
|
||||
printf '| %s.hs | %d/%d | %s |\n' "${GC_NAMES[$i]}" "$p" "$t" "$status"
|
||||
done
|
||||
printf '| **Total** | **%d/%d** | **%d/%d programs** |\n' \
|
||||
"$GC_TOTAL_PASS" "$GC_TOTAL" "$prog_pass" "$prog_total"
|
||||
}
|
||||
@@ -1,3 +1,140 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/haskell/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
# lib/haskell/conformance.sh — run the classic-program test suites.
|
||||
# Writes lib/haskell/scoreboard.json and lib/haskell/scoreboard.md.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/haskell/conformance.sh # run + write scoreboards
|
||||
# bash lib/haskell/conformance.sh --check # run only, exit 1 on failure
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
|
||||
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
|
||||
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
|
||||
else
|
||||
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
|
||||
exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
PROGRAMS=(fib sieve quicksort nqueens calculator collatz palindrome maybe fizzbuzz anagram roman binary either primes zipwith matrix wordcount powers)
|
||||
PASS_COUNTS=()
|
||||
FAIL_COUNTS=()
|
||||
|
||||
run_suite() {
|
||||
local prog="$1"
|
||||
local FILE="lib/haskell/tests/program-${prog}.sx"
|
||||
local TMPFILE
|
||||
TMPFILE=$(mktemp)
|
||||
cat > "$TMPFILE" <<EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/haskell/tokenizer.sx")
|
||||
(load "lib/haskell/layout.sx")
|
||||
(load "lib/haskell/parser.sx")
|
||||
(load "lib/haskell/desugar.sx")
|
||||
(load "lib/haskell/runtime.sx")
|
||||
(load "lib/haskell/match.sx")
|
||||
(load "lib/haskell/eval.sx")
|
||||
(load "lib/haskell/testlib.sx")
|
||||
(epoch 2)
|
||||
(load "$FILE")
|
||||
(epoch 3)
|
||||
(eval "(list hk-test-pass hk-test-fail)")
|
||||
EPOCHS
|
||||
local OUTPUT
|
||||
OUTPUT=$(timeout 120 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||
rm -f "$TMPFILE"
|
||||
|
||||
local LINE
|
||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
|
||||
if [ -z "$LINE" ]; then
|
||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||
| sed -E 's/^\(ok 3 //; s/\)$//' || true)
|
||||
fi
|
||||
if [ -z "$LINE" ]; then
|
||||
echo "0 1"
|
||||
else
|
||||
local P F
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/' || echo "0")
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/' || echo "1")
|
||||
echo "$P $F"
|
||||
fi
|
||||
}
|
||||
|
||||
for prog in "${PROGRAMS[@]}"; do
|
||||
RESULT=$(run_suite "$prog")
|
||||
P=$(echo "$RESULT" | cut -d' ' -f1)
|
||||
F=$(echo "$RESULT" | cut -d' ' -f2)
|
||||
PASS_COUNTS+=("$P")
|
||||
FAIL_COUNTS+=("$F")
|
||||
T=$((P + F))
|
||||
if [ "$F" -eq 0 ]; then
|
||||
printf '✓ %-14s %d/%d\n' "${prog}.hs" "$P" "$T"
|
||||
else
|
||||
printf '✗ %-14s %d/%d\n' "${prog}.hs" "$P" "$T"
|
||||
fi
|
||||
done
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
PROG_PASS=0
|
||||
for i in "${!PROGRAMS[@]}"; do
|
||||
TOTAL_PASS=$((TOTAL_PASS + PASS_COUNTS[i]))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + FAIL_COUNTS[i]))
|
||||
[ "${FAIL_COUNTS[$i]}" -eq 0 ] && PROG_PASS=$((PROG_PASS + 1))
|
||||
done
|
||||
PROG_TOTAL=${#PROGRAMS[@]}
|
||||
|
||||
echo ""
|
||||
echo "Classic programs: ${TOTAL_PASS}/$((TOTAL_PASS + TOTAL_FAIL)) tests | ${PROG_PASS}/${PROG_TOTAL} programs passing"
|
||||
|
||||
if [[ "${1:-}" == "--check" ]]; then
|
||||
[ $TOTAL_FAIL -eq 0 ]
|
||||
exit $?
|
||||
fi
|
||||
|
||||
DATE=$(date '+%Y-%m-%d')
|
||||
|
||||
# scoreboard.json
|
||||
{
|
||||
printf '{\n'
|
||||
printf ' "date": "%s",\n' "$DATE"
|
||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||
printf ' "programs": {\n'
|
||||
last=$((${#PROGRAMS[@]} - 1))
|
||||
for i in "${!PROGRAMS[@]}"; do
|
||||
prog="${PROGRAMS[$i]}"
|
||||
if [ $i -lt $last ]; then
|
||||
printf ' "%s": {"pass": %d, "fail": %d},\n' "$prog" "${PASS_COUNTS[$i]}" "${FAIL_COUNTS[$i]}"
|
||||
else
|
||||
printf ' "%s": {"pass": %d, "fail": %d}\n' "$prog" "${PASS_COUNTS[$i]}" "${FAIL_COUNTS[$i]}"
|
||||
fi
|
||||
done
|
||||
printf ' }\n'
|
||||
printf '}\n'
|
||||
} > lib/haskell/scoreboard.json
|
||||
|
||||
# scoreboard.md
|
||||
{
|
||||
printf '# Haskell-on-SX Scoreboard\n\n'
|
||||
printf 'Updated %s · Phase 6 (prelude extras + 18 programs)\n\n' "$DATE"
|
||||
printf '| Program | Tests | Status |\n'
|
||||
printf '|---------|-------|--------|\n'
|
||||
for i in "${!PROGRAMS[@]}"; do
|
||||
prog="${PROGRAMS[$i]}"
|
||||
P=${PASS_COUNTS[$i]}
|
||||
F=${FAIL_COUNTS[$i]}
|
||||
T=$((P + F))
|
||||
[ "$F" -eq 0 ] && STATUS="✓" || STATUS="✗"
|
||||
printf '| %s | %d/%d | %s |\n' "${prog}.hs" "$P" "$T" "$STATUS"
|
||||
done
|
||||
printf '| **Total** | **%d/%d** | **%d/%d programs** |\n' \
|
||||
"$TOTAL_PASS" "$((TOTAL_PASS + TOTAL_FAIL))" "$PROG_PASS" "$PROG_TOTAL"
|
||||
} > lib/haskell/scoreboard.md
|
||||
|
||||
echo "Wrote lib/haskell/scoreboard.json and lib/haskell/scoreboard.md"
|
||||
[ $TOTAL_FAIL -eq 0 ]
|
||||
|
||||
@@ -7,22 +7,6 @@
|
||||
;; (hs-to-sx (hs-compile "on click add .active to me"))
|
||||
;; → (hs-on me "click" (fn (event) (dom-add-class me "active")))
|
||||
|
||||
;; ── Compiler plugin registries ────────────────────────────────────
|
||||
;; Plugins call (hs-register-command! "head" compile-fn) and
|
||||
;; (hs-register-converter! "TypeName" convert-fn) at load time. Both
|
||||
;; compile-fn and convert-fn receive a ctx dict (built per call inside
|
||||
;; hs-to-sx) exposing :hs-to-sx for recursion plus the AST node fields
|
||||
;; the dispatch needs. Compile-fn returns an SX expression.
|
||||
(begin
|
||||
(define _hs-command-registry {})
|
||||
(define _hs-converter-registry {})
|
||||
(define
|
||||
hs-register-command!
|
||||
(fn (name compile-fn) (dict-set! _hs-command-registry name compile-fn)))
|
||||
(define
|
||||
hs-register-converter!
|
||||
(fn (name convert-fn) (dict-set! _hs-converter-registry name convert-fn))))
|
||||
|
||||
(define
|
||||
hs-to-sx
|
||||
(let
|
||||
@@ -968,22 +952,6 @@
|
||||
(true
|
||||
(let
|
||||
((head (first ast)))
|
||||
(let
|
||||
((reg-cmd-fn (dict-get _hs-command-registry (str head)))
|
||||
(reg-conv-fn
|
||||
(and
|
||||
(= head (quote as))
|
||||
(dict-get _hs-converter-registry (nth ast 2)))))
|
||||
(cond
|
||||
(reg-conv-fn
|
||||
(reg-conv-fn
|
||||
{:hs-to-sx hs-to-sx
|
||||
:ast ast
|
||||
:value-ast (nth ast 1)
|
||||
:type-name (nth ast 2)}))
|
||||
(reg-cmd-fn
|
||||
(reg-cmd-fn {:hs-to-sx hs-to-sx :ast ast :head head}))
|
||||
(true
|
||||
(cond
|
||||
((= head (quote __bind-from-detail__))
|
||||
(let
|
||||
@@ -2699,7 +2667,7 @@
|
||||
(quote begin)
|
||||
(list (quote set!) (quote it) (quote __hs-js))
|
||||
(quote __hs-js))))))
|
||||
(true ast))))))))))))
|
||||
(true ast)))))))))
|
||||
|
||||
;; ── Convenience: source → SX ─────────────────────────────────
|
||||
(define
|
||||
|
||||
@@ -3,17 +3,6 @@
|
||||
;; Input: list of {:type T :value V :pos P} tokens from hs-tokenize
|
||||
;; Output: SX AST forms that map to runtime primitives
|
||||
|
||||
;; ── Feature plugin registry ───────────────────────────────────────
|
||||
;; Plugins call (hs-register-feature! "name" parse-fn) at load time.
|
||||
;; parse-fn is (fn (ctx) ...) where ctx is a dict exposing parser
|
||||
;; helpers (:adv! :tp-val :tp-type :parse-cmd-list ...) and the
|
||||
;; built-in parse-X-feat dispatch fns.
|
||||
(begin
|
||||
(define _hs-feature-registry {})
|
||||
(define
|
||||
hs-register-feature!
|
||||
(fn (name parse-fn) (dict-set! _hs-feature-registry name parse-fn))))
|
||||
|
||||
;; ── Parser entry point ────────────────────────────────────────────
|
||||
(define
|
||||
hs-parse
|
||||
@@ -3242,24 +3231,6 @@
|
||||
(do
|
||||
(match-kw "end")
|
||||
(list (quote socket) name-path url timeout on-message))))))))))
|
||||
(define
|
||||
parse-feat-ctx
|
||||
(fn
|
||||
()
|
||||
{:adv! adv!
|
||||
:tp-val tp-val
|
||||
:tp-type tp-type
|
||||
:at-end? at-end?
|
||||
:parse-cmd-list parse-cmd-list
|
||||
:parse-expr parse-expr
|
||||
:parse-on-feat parse-on-feat
|
||||
:parse-init-feat parse-init-feat
|
||||
:parse-def-feat parse-def-feat
|
||||
:parse-behavior-feat parse-behavior-feat
|
||||
:parse-live-feat parse-live-feat
|
||||
:parse-when-feat parse-when-feat
|
||||
:parse-bind-feat parse-bind-feat
|
||||
:parse-socket-feat parse-socket-feat}))
|
||||
(define
|
||||
parse-feat
|
||||
(fn
|
||||
@@ -3290,23 +3261,29 @@
|
||||
((unit (tp-val)))
|
||||
(do (adv!) (list (quote string-postfix) inner unit)))
|
||||
inner))))
|
||||
((= val "on") (do (adv!) (parse-on-feat)))
|
||||
((= val "init") (do (adv!) (parse-init-feat)))
|
||||
((= val "def") (do (adv!) (parse-def-feat)))
|
||||
((= val "behavior") (do (adv!) (parse-behavior-feat)))
|
||||
((= val "live") (do (adv!) (parse-live-feat)))
|
||||
((= val "when") (do (adv!) (parse-when-feat)))
|
||||
((= val "worker")
|
||||
(error
|
||||
"worker plugin is not installed — see https://hyperscript.org/features/worker"))
|
||||
((= val "bind") (do (adv!) (parse-bind-feat)))
|
||||
((= val "socket") (do (adv!) (parse-socket-feat)))
|
||||
(true
|
||||
(let
|
||||
((reg-fn (dict-get _hs-feature-registry val)))
|
||||
(if
|
||||
reg-fn
|
||||
(reg-fn (parse-feat-ctx))
|
||||
(if
|
||||
(= (tp-type) "keyword")
|
||||
(parse-cmd-list)
|
||||
(let
|
||||
((saved-p p))
|
||||
(let
|
||||
((expr (guard (_e (true nil)) (parse-expr))))
|
||||
(if
|
||||
(and expr (at-end?))
|
||||
expr
|
||||
(do (set! p saved-p) (parse-cmd-list)))))))))))))
|
||||
(if
|
||||
(= (tp-type) "keyword")
|
||||
(parse-cmd-list)
|
||||
(let
|
||||
((saved-p p))
|
||||
(let
|
||||
((expr (guard (_e (true nil)) (parse-expr))))
|
||||
(if
|
||||
(and expr (at-end?))
|
||||
expr
|
||||
(do (set! p saved-p) (parse-cmd-list)))))))))))
|
||||
(define
|
||||
coll-feats
|
||||
(fn
|
||||
@@ -3349,33 +3326,3 @@
|
||||
(let
|
||||
((result (hs-parse (hs-tokenize src) src)))
|
||||
(do (set! hs-span-mode false) result)))))
|
||||
|
||||
;; ── Built-in feature registrations ────────────────────────────────
|
||||
;; These mirror the original parse-feat cond branches. Registering at
|
||||
;; load time means plugins can override or extend; ctx exposes the
|
||||
;; parser internals each fn needs.
|
||||
(begin
|
||||
(hs-register-feature!
|
||||
"on"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-on-feat)))))
|
||||
(hs-register-feature!
|
||||
"init"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-init-feat)))))
|
||||
(hs-register-feature!
|
||||
"def"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-def-feat)))))
|
||||
(hs-register-feature!
|
||||
"behavior"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-behavior-feat)))))
|
||||
(hs-register-feature!
|
||||
"live"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-live-feat)))))
|
||||
(hs-register-feature!
|
||||
"when"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-when-feat)))))
|
||||
(hs-register-feature!
|
||||
"bind"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-bind-feat)))))
|
||||
(hs-register-feature!
|
||||
"socket"
|
||||
(fn (ctx) (begin ((dict-get ctx :adv!)) ((dict-get ctx :parse-socket-feat))))))
|
||||
|
||||
@@ -1,24 +0,0 @@
|
||||
;; lib/hyperscript/plugins/prolog.sx — Prolog plugin
|
||||
;;
|
||||
;; Provides the `prolog` HS-level function. Replaces the ad-hoc
|
||||
;; hs-prolog-hook / hs-set-prolog-hook! slots that previously lived in
|
||||
;; lib/hyperscript/runtime.sx (nodes 140–142 of the plugin design doc).
|
||||
;;
|
||||
;; Two-step wiring preserves the original API:
|
||||
;; 1. lib/prolog/runtime.sx loaded → defines pl-query-one
|
||||
;; 2. lib/prolog/hs-bridge.sx (or this file's auto-wire) calls
|
||||
;; (hs-set-prolog-hook! (fn (db goal) (not (= nil (pl-query-one db goal)))))
|
||||
;; If neither is loaded, calling (prolog db goal) raises a clear error.
|
||||
|
||||
(define hs-prolog-hook nil)
|
||||
|
||||
(define hs-set-prolog-hook! (fn (f) (set! hs-prolog-hook f)))
|
||||
|
||||
(define
|
||||
prolog
|
||||
(fn
|
||||
(db goal)
|
||||
(if
|
||||
(nil? hs-prolog-hook)
|
||||
(raise "prolog hook not installed")
|
||||
(hs-prolog-hook db goal))))
|
||||
@@ -1,19 +0,0 @@
|
||||
;; lib/hyperscript/plugins/worker.sx — Worker plugin (stub)
|
||||
;;
|
||||
;; Phase 1 of the worker plugin: the registration formerly inlined in
|
||||
;; lib/hyperscript/parser.sx (E39 stub) moves here. Behaviour is
|
||||
;; identical — `worker MyWorker ...` raises a helpful error directing
|
||||
;; users to the full plugin (not yet implemented).
|
||||
;;
|
||||
;; Phase 2 (future) replaces this stub with parse-worker-feat, a
|
||||
;; compiler entry, hs-worker-define!, and the postMessage-based
|
||||
;; method dispatch documented in plans/designs/hs-plugin-system.md §4a.
|
||||
|
||||
(define hs-worker-loaded? true)
|
||||
|
||||
(hs-register-feature!
|
||||
"worker"
|
||||
(fn
|
||||
(ctx)
|
||||
(error
|
||||
"worker plugin is not installed — see https://hyperscript.org/features/worker")))
|
||||
@@ -2911,6 +2911,19 @@
|
||||
((nth entry 2) val)))
|
||||
_hs-dom-watchers)))
|
||||
|
||||
(define hs-prolog-hook nil)
|
||||
|
||||
(define hs-set-prolog-hook! (fn (f) (set! hs-prolog-hook f)))
|
||||
|
||||
(define
|
||||
prolog
|
||||
(fn
|
||||
(db goal)
|
||||
(if
|
||||
(nil? hs-prolog-hook)
|
||||
(raise "prolog hook not installed")
|
||||
(hs-prolog-hook db goal))))
|
||||
|
||||
(define
|
||||
hs-null-error!
|
||||
(fn (selector) (raise (str "'" selector "' is null"))))
|
||||
|
||||
@@ -8,17 +8,7 @@
|
||||
|
||||
;; ── Token constructor ─────────────────────────────────────────────
|
||||
|
||||
(define hs-make-token
|
||||
(fn (type value pos &rest extras)
|
||||
(let
|
||||
((end-arg (if (>= (len extras) 1) (nth extras 0) nil))
|
||||
(line-arg (if (>= (len extras) 2) (nth extras 1) nil)))
|
||||
(let
|
||||
((end (if (nil? end-arg)
|
||||
(+ pos (if (nil? value) 0 (len (str value))))
|
||||
end-arg))
|
||||
(line (if (nil? line-arg) 1 line-arg)))
|
||||
{:pos pos :end end :line line :value value :type type}))))
|
||||
(define hs-make-token (fn (type value pos) {:pos pos :value value :type type}))
|
||||
|
||||
;; ── Character predicates ──────────────────────────────────────────
|
||||
|
||||
@@ -231,26 +221,14 @@
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)) (current-line 1))
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define
|
||||
hs-peek
|
||||
(fn
|
||||
(offset)
|
||||
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||
(define hs-cur (fn () (hs-peek 0)))
|
||||
(define
|
||||
hs-advance!
|
||||
(fn (n)
|
||||
(let ((new-pos (+ pos n)))
|
||||
(define
|
||||
count-nl!
|
||||
(fn (i)
|
||||
(when (< i new-pos)
|
||||
(when (= (nth src i) "\n")
|
||||
(set! current-line (+ current-line 1)))
|
||||
(count-nl! (+ i 1)))))
|
||||
(count-nl! pos)
|
||||
(set! pos new-pos))))
|
||||
(define hs-advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define
|
||||
skip-ws!
|
||||
(fn
|
||||
@@ -524,14 +502,13 @@
|
||||
(fn
|
||||
(type value start)
|
||||
(let
|
||||
((end-pos
|
||||
(max pos (+ start (if (nil? value) 0 (len (str value))))))
|
||||
(newlines-after-start
|
||||
(- (len (split (slice src start (max start pos)) "\n")) 1))
|
||||
(start-line (- current-line newlines-after-start)))
|
||||
(append!
|
||||
tokens
|
||||
(hs-make-token type value start end-pos start-line)))))
|
||||
((tok (hs-make-token type value start))
|
||||
(end-pos
|
||||
(max pos (+ start (if (nil? value) 0 (len (str value)))))))
|
||||
(do
|
||||
(dict-set! tok "end" end-pos)
|
||||
(dict-set! tok "line" (len (split (slice src 0 start) "\n")))
|
||||
(append! tokens tok)))))
|
||||
(define
|
||||
scan!
|
||||
(fn
|
||||
@@ -781,30 +758,11 @@
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)) (current-line 1))
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define t-cur (fn () (if (< pos src-len) (nth src pos) nil)))
|
||||
(define t-peek (fn (n) (if (< (+ pos n) src-len) (nth src (+ pos n)) nil)))
|
||||
(define
|
||||
t-advance!
|
||||
(fn (n)
|
||||
(let ((new-pos (+ pos n)))
|
||||
(define
|
||||
t-count-nl!
|
||||
(fn (i)
|
||||
(when (< i new-pos)
|
||||
(when (= (nth src i) "\n")
|
||||
(set! current-line (+ current-line 1)))
|
||||
(t-count-nl! (+ i 1)))))
|
||||
(t-count-nl! pos)
|
||||
(set! pos new-pos))))
|
||||
(define
|
||||
t-emit!
|
||||
(fn (type value)
|
||||
(let
|
||||
((end-pos (+ pos (if (nil? value) 0 (len (str value))))))
|
||||
(append!
|
||||
tokens
|
||||
(hs-make-token type value pos end-pos current-line)))))
|
||||
(define t-advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define t-emit! (fn (type value) (append! tokens (hs-make-token type value pos))))
|
||||
(define
|
||||
scan-to-close!
|
||||
(fn
|
||||
|
||||
@@ -3,33 +3,28 @@
|
||||
(define lua-tok-value (fn (t) (if (= t nil) nil (get t :value))))
|
||||
|
||||
(define
|
||||
lua-op-table
|
||||
(list
|
||||
(list "or" 1 :left)
|
||||
(list "and" 2 :left)
|
||||
(list "<" 3 :left)
|
||||
(list ">" 3 :left)
|
||||
(list "<=" 3 :left)
|
||||
(list ">=" 3 :left)
|
||||
(list "==" 3 :left)
|
||||
(list "~=" 3 :left)
|
||||
(list ".." 5 :right)
|
||||
(list "+" 6 :left)
|
||||
(list "-" 6 :left)
|
||||
(list "*" 7 :left)
|
||||
(list "/" 7 :left)
|
||||
(list "%" 7 :left)
|
||||
(list "^" 10 :right)))
|
||||
lua-binop-prec
|
||||
(fn
|
||||
(op)
|
||||
(cond
|
||||
((= op "or") 1)
|
||||
((= op "and") 2)
|
||||
((= op "<") 3)
|
||||
((= op ">") 3)
|
||||
((= op "<=") 3)
|
||||
((= op ">=") 3)
|
||||
((= op "==") 3)
|
||||
((= op "~=") 3)
|
||||
((= op "..") 5)
|
||||
((= op "+") 6)
|
||||
((= op "-") 6)
|
||||
((= op "*") 7)
|
||||
((= op "/") 7)
|
||||
((= op "%") 7)
|
||||
((= op "^") 10)
|
||||
(else 0))))
|
||||
|
||||
(define lua-binop-prec
|
||||
(fn (op)
|
||||
(let ((entry (pratt-op-lookup lua-op-table op)))
|
||||
(if (= entry nil) 0 (pratt-op-prec entry)))))
|
||||
|
||||
(define lua-binop-right?
|
||||
(fn (op)
|
||||
(let ((entry (pratt-op-lookup lua-op-table op)))
|
||||
(and (not (= entry nil)) (= (pratt-op-assoc entry) :right)))))
|
||||
(define lua-binop-right? (fn (op) (or (= op "..") (= op "^"))))
|
||||
|
||||
(define
|
||||
lua-parse
|
||||
|
||||
@@ -28,9 +28,6 @@ trap "rm -f $TMPFILE" EXIT
|
||||
|
||||
cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 1)
|
||||
(load "lib/guest/lex.sx")
|
||||
(load "lib/guest/prefix.sx")
|
||||
(load "lib/guest/pratt.sx")
|
||||
(load "lib/lua/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/lua/parser.sx")
|
||||
|
||||
@@ -1,12 +1,31 @@
|
||||
(prefix-rename "lua-"
|
||||
'((make-token lex-make-token)
|
||||
(digit? lex-digit?)
|
||||
(hex-digit? lex-hex-digit?)
|
||||
(letter? lex-alpha?)
|
||||
(ident-start? lex-ident-start?)
|
||||
(ident-char? lex-ident-char?)
|
||||
(ws? lex-whitespace?)))
|
||||
(define lua-make-token (fn (type value pos) {:pos pos :value value :type type}))
|
||||
|
||||
(define lua-digit? (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
|
||||
|
||||
(define
|
||||
lua-hex-digit?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or
|
||||
(lua-digit? c)
|
||||
(and (>= c "a") (<= c "f"))
|
||||
(and (>= c "A") (<= c "F"))))))
|
||||
|
||||
(define
|
||||
lua-letter?
|
||||
(fn
|
||||
(c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define lua-ident-start? (fn (c) (or (lua-letter? c) (= c "_"))))
|
||||
|
||||
(define lua-ident-char? (fn (c) (or (lua-ident-start? c) (lua-digit? c))))
|
||||
|
||||
(define lua-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
lua-keywords
|
||||
|
||||
@@ -1,81 +0,0 @@
|
||||
# Prolog conformance config — sourced by lib/guest/conformance.sh.
|
||||
|
||||
LANG_NAME=prolog
|
||||
MODE=dict
|
||||
|
||||
PRELOADS=(
|
||||
lib/guest/pratt.sx
|
||||
lib/prolog/tokenizer.sx
|
||||
lib/prolog/parser.sx
|
||||
lib/prolog/runtime.sx
|
||||
lib/prolog/query.sx
|
||||
lib/prolog/compiler.sx
|
||||
lib/prolog/hs-bridge.sx
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"parse:lib/prolog/tests/parse.sx:(pl-parse-tests-run!)"
|
||||
"unify:lib/prolog/tests/unify.sx:(pl-unify-tests-run!)"
|
||||
"clausedb:lib/prolog/tests/clausedb.sx:(pl-clausedb-tests-run!)"
|
||||
"solve:lib/prolog/tests/solve.sx:(pl-solve-tests-run!)"
|
||||
"operators:lib/prolog/tests/operators.sx:(pl-operators-tests-run!)"
|
||||
"dynamic:lib/prolog/tests/dynamic.sx:(pl-dynamic-tests-run!)"
|
||||
"findall:lib/prolog/tests/findall.sx:(pl-findall-tests-run!)"
|
||||
"term_inspect:lib/prolog/tests/term_inspect.sx:(pl-term-inspect-tests-run!)"
|
||||
"append:lib/prolog/tests/programs/append.sx:(pl-append-tests-run!)"
|
||||
"reverse:lib/prolog/tests/programs/reverse.sx:(pl-reverse-tests-run!)"
|
||||
"member:lib/prolog/tests/programs/member.sx:(pl-member-tests-run!)"
|
||||
"nqueens:lib/prolog/tests/programs/nqueens.sx:(pl-nqueens-tests-run!)"
|
||||
"family:lib/prolog/tests/programs/family.sx:(pl-family-tests-run!)"
|
||||
"atoms:lib/prolog/tests/atoms.sx:(pl-atom-tests-run!)"
|
||||
"query_api:lib/prolog/tests/query_api.sx:(pl-query-api-tests-run!)"
|
||||
"iso_predicates:lib/prolog/tests/iso_predicates.sx:(pl-iso-predicates-tests-run!)"
|
||||
"meta_predicates:lib/prolog/tests/meta_predicates.sx:(pl-meta-predicates-tests-run!)"
|
||||
"list_predicates:lib/prolog/tests/list_predicates.sx:(pl-list-predicates-tests-run!)"
|
||||
"meta_call:lib/prolog/tests/meta_call.sx:(pl-meta-call-tests-run!)"
|
||||
"set_predicates:lib/prolog/tests/set_predicates.sx:(pl-set-predicates-tests-run!)"
|
||||
"char_predicates:lib/prolog/tests/char_predicates.sx:(pl-char-predicates-tests-run!)"
|
||||
"io_predicates:lib/prolog/tests/io_predicates.sx:(pl-io-predicates-tests-run!)"
|
||||
"assert_rules:lib/prolog/tests/assert_rules.sx:(pl-assert-rules-tests-run!)"
|
||||
"string_agg:lib/prolog/tests/string_agg.sx:(pl-string-agg-tests-run!)"
|
||||
"advanced:lib/prolog/tests/advanced.sx:(pl-advanced-tests-run!)"
|
||||
"compiler:lib/prolog/tests/compiler.sx:(pl-compiler-tests-run!)"
|
||||
"cross_validate:lib/prolog/tests/cross_validate.sx:(pl-cross-validate-tests-run!)"
|
||||
"integration:lib/prolog/tests/integration.sx:(pl-integration-tests-run!)"
|
||||
"hs_bridge:lib/prolog/tests/hs_bridge.sx:(pl-hs-bridge-tests-run!)"
|
||||
)
|
||||
|
||||
emit_scoreboard_json() {
|
||||
local n=${#GC_NAMES[@]} i sep
|
||||
printf '{\n'
|
||||
printf ' "total_passed": %d,\n' "$GC_TOTAL_PASS"
|
||||
printf ' "total_failed": %d,\n' "$GC_TOTAL_FAIL"
|
||||
printf ' "total": %d,\n' "$GC_TOTAL"
|
||||
printf ' "suites": {'
|
||||
for ((i=0; i<n; i++)); do
|
||||
sep=","; [ $i -eq $((n-1)) ] && sep=""
|
||||
printf '"%s":{"passed":%d,"total":%d,"failed":%d}%s' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_TOTAL_S[$i]}" "${GC_FAIL[$i]}" "$sep"
|
||||
done
|
||||
printf '},\n'
|
||||
printf ' "generated": "%s"\n' "$(date -Iseconds 2>/dev/null || date)"
|
||||
printf '}\n'
|
||||
}
|
||||
|
||||
emit_scoreboard_md() {
|
||||
local n=${#GC_NAMES[@]} i status when
|
||||
when="$(date -Iseconds 2>/dev/null || date)"
|
||||
printf '# Prolog scoreboard\n\n'
|
||||
printf '**%d / %d passing** (%d failure(s)).\n' \
|
||||
"$GC_TOTAL_PASS" "$GC_TOTAL" "$GC_TOTAL_FAIL"
|
||||
printf 'Generated %s.\n\n' "$when"
|
||||
printf '| Suite | Passed | Total | Status |\n'
|
||||
printf '|-------|--------|-------|--------|\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
status="ok"; [ "${GC_FAIL[$i]}" -gt 0 ] && status="FAIL"
|
||||
printf '| %s | %d | %d | %s |\n' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_TOTAL_S[$i]}" "$status"
|
||||
done
|
||||
printf '\nRun `bash lib/prolog/conformance.sh` to refresh. Override the binary\n'
|
||||
printf 'with `SX_SERVER=path/to/sx_server.exe bash …`.\n'
|
||||
}
|
||||
@@ -1,3 +1,129 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/prolog/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
# Run every Prolog test suite via sx_server and refresh scoreboard.{json,md}.
|
||||
# Exit 0 if all green, 1 if any failures.
|
||||
set -euo pipefail
|
||||
|
||||
HERE="$(cd "$(dirname "$0")" && pwd)"
|
||||
ROOT="$(cd "$HERE/../.." && pwd)"
|
||||
SX="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
|
||||
if [[ ! -x "$SX" ]]; then
|
||||
echo "sx_server not found at $SX (set SX_SERVER env to override)" >&2
|
||||
exit 2
|
||||
fi
|
||||
|
||||
cd "$ROOT"
|
||||
|
||||
# name : test-file : runner-fn
|
||||
SUITES=(
|
||||
"parse:lib/prolog/tests/parse.sx:pl-parse-tests-run!"
|
||||
"unify:lib/prolog/tests/unify.sx:pl-unify-tests-run!"
|
||||
"clausedb:lib/prolog/tests/clausedb.sx:pl-clausedb-tests-run!"
|
||||
"solve:lib/prolog/tests/solve.sx:pl-solve-tests-run!"
|
||||
"operators:lib/prolog/tests/operators.sx:pl-operators-tests-run!"
|
||||
"dynamic:lib/prolog/tests/dynamic.sx:pl-dynamic-tests-run!"
|
||||
"findall:lib/prolog/tests/findall.sx:pl-findall-tests-run!"
|
||||
"term_inspect:lib/prolog/tests/term_inspect.sx:pl-term-inspect-tests-run!"
|
||||
"append:lib/prolog/tests/programs/append.sx:pl-append-tests-run!"
|
||||
"reverse:lib/prolog/tests/programs/reverse.sx:pl-reverse-tests-run!"
|
||||
"member:lib/prolog/tests/programs/member.sx:pl-member-tests-run!"
|
||||
"nqueens:lib/prolog/tests/programs/nqueens.sx:pl-nqueens-tests-run!"
|
||||
"family:lib/prolog/tests/programs/family.sx:pl-family-tests-run!"
|
||||
"atoms:lib/prolog/tests/atoms.sx:pl-atom-tests-run!"
|
||||
"query_api:lib/prolog/tests/query_api.sx:pl-query-api-tests-run!"
|
||||
"iso_predicates:lib/prolog/tests/iso_predicates.sx:pl-iso-predicates-tests-run!"
|
||||
"meta_predicates:lib/prolog/tests/meta_predicates.sx:pl-meta-predicates-tests-run!"
|
||||
"list_predicates:lib/prolog/tests/list_predicates.sx:pl-list-predicates-tests-run!"
|
||||
"meta_call:lib/prolog/tests/meta_call.sx:pl-meta-call-tests-run!"
|
||||
"set_predicates:lib/prolog/tests/set_predicates.sx:pl-set-predicates-tests-run!"
|
||||
"char_predicates:lib/prolog/tests/char_predicates.sx:pl-char-predicates-tests-run!"
|
||||
"io_predicates:lib/prolog/tests/io_predicates.sx:pl-io-predicates-tests-run!"
|
||||
"assert_rules:lib/prolog/tests/assert_rules.sx:pl-assert-rules-tests-run!"
|
||||
"string_agg:lib/prolog/tests/string_agg.sx:pl-string-agg-tests-run!"
|
||||
"advanced:lib/prolog/tests/advanced.sx:pl-advanced-tests-run!"
|
||||
"compiler:lib/prolog/tests/compiler.sx:pl-compiler-tests-run!"
|
||||
"cross_validate:lib/prolog/tests/cross_validate.sx:pl-cross-validate-tests-run!"
|
||||
"integration:lib/prolog/tests/integration.sx:pl-integration-tests-run!"
|
||||
"hs_bridge:lib/prolog/tests/hs_bridge.sx:pl-hs-bridge-tests-run!"
|
||||
)
|
||||
|
||||
SCRIPT='(epoch 1)
|
||||
(load "lib/prolog/tokenizer.sx")
|
||||
(load "lib/prolog/parser.sx")
|
||||
(load "lib/prolog/runtime.sx")
|
||||
(load "lib/prolog/query.sx")
|
||||
(load "lib/prolog/compiler.sx")
|
||||
(load "lib/prolog/hs-bridge.sx")'
|
||||
for entry in "${SUITES[@]}"; do
|
||||
IFS=: read -r _ file _ <<< "$entry"
|
||||
SCRIPT+=$'\n(load "'"$file"$'")'
|
||||
done
|
||||
for entry in "${SUITES[@]}"; do
|
||||
IFS=: read -r _ _ fn <<< "$entry"
|
||||
SCRIPT+=$'\n(eval "('"$fn"$')")'
|
||||
done
|
||||
|
||||
OUTPUT="$(printf '%s\n' "$SCRIPT" | "$SX" 2>&1)"
|
||||
|
||||
mapfile -t LINES < <(printf '%s\n' "$OUTPUT" | grep -E '^\{:failed')
|
||||
|
||||
if [[ ${#LINES[@]} -ne ${#SUITES[@]} ]]; then
|
||||
echo "Expected ${#SUITES[@]} suite results, got ${#LINES[@]}" >&2
|
||||
echo "---- raw output ----" >&2
|
||||
printf '%s\n' "$OUTPUT" >&2
|
||||
exit 3
|
||||
fi
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
TOTAL=0
|
||||
JSON_SUITES=""
|
||||
MD_ROWS=""
|
||||
|
||||
for i in "${!SUITES[@]}"; do
|
||||
IFS=: read -r name _ _ <<< "${SUITES[$i]}"
|
||||
line="${LINES[$i]}"
|
||||
passed=$(grep -oE ':passed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
|
||||
total=$(grep -oE ':total [0-9]+' <<< "$line" | grep -oE '[0-9]+')
|
||||
failed=$(grep -oE ':failed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
|
||||
TOTAL_PASS=$((TOTAL_PASS + passed))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + failed))
|
||||
TOTAL=$((TOTAL + total))
|
||||
status="ok"
|
||||
[[ "$failed" -gt 0 ]] && status="FAIL"
|
||||
[[ -n "$JSON_SUITES" ]] && JSON_SUITES+=","
|
||||
JSON_SUITES+="\"$name\":{\"passed\":$passed,\"total\":$total,\"failed\":$failed}"
|
||||
MD_ROWS+="| $name | $passed | $total | $status |"$'\n'
|
||||
done
|
||||
|
||||
WHEN="$(date -Iseconds 2>/dev/null || date)"
|
||||
|
||||
cat > "$HERE/scoreboard.json" <<JSON
|
||||
{
|
||||
"total_passed": $TOTAL_PASS,
|
||||
"total_failed": $TOTAL_FAIL,
|
||||
"total": $TOTAL,
|
||||
"suites": {$JSON_SUITES},
|
||||
"generated": "$WHEN"
|
||||
}
|
||||
JSON
|
||||
|
||||
cat > "$HERE/scoreboard.md" <<MD
|
||||
# Prolog scoreboard
|
||||
|
||||
**$TOTAL_PASS / $TOTAL passing** ($TOTAL_FAIL failure(s)).
|
||||
Generated $WHEN.
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
$MD_ROWS
|
||||
Run \`bash lib/prolog/conformance.sh\` to refresh. Override the binary
|
||||
with \`SX_SERVER=path/to/sx_server.exe bash …\`.
|
||||
MD
|
||||
|
||||
if [[ "$TOTAL_FAIL" -gt 0 ]]; then
|
||||
echo "$TOTAL_FAIL failure(s) across $TOTAL tests" >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
echo "All $TOTAL tests pass."
|
||||
|
||||
@@ -4,7 +4,7 @@
|
||||
;;
|
||||
;; 1. Hook style — for `prolog(db, "goal(args)")` call syntax in Hyperscript:
|
||||
;; (pl-install-hs-hook!) ;; call once at startup
|
||||
;; Requires lib/hyperscript/plugins/prolog.sx (provides hs-set-prolog-hook!)
|
||||
;; Requires lib/hyperscript/runtime.sx (provides hs-set-prolog-hook!)
|
||||
;;
|
||||
;; 2. Factory style — for named conditions like `when allowed(user, action)`:
|
||||
;; (define allowed (pl-hs-predicate/2 pl-db "allowed"))
|
||||
|
||||
@@ -104,9 +104,18 @@
|
||||
(list ":-" 1200 "xfx")
|
||||
(list "mod" 400 "yfx")))
|
||||
|
||||
(define pl-op-lookup (fn (name) (pratt-op-lookup pl-op-table name)))
|
||||
(define
|
||||
pl-op-find
|
||||
(fn
|
||||
(name table)
|
||||
(cond
|
||||
((empty? table) nil)
|
||||
((= (first (first table)) name) (rest (first table)))
|
||||
(true (pl-op-find name (rest table))))))
|
||||
|
||||
;; Token → entry (name prec type) for known infix ops, else nil.
|
||||
(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table)))
|
||||
|
||||
;; Token → (name prec type) for known infix ops, else nil.
|
||||
(define
|
||||
pl-token-op
|
||||
(fn
|
||||
@@ -114,8 +123,14 @@
|
||||
(let
|
||||
((ty (get t :type)) (vv (get t :value)))
|
||||
(cond
|
||||
((and (= ty "punct") (= vv ",")) (pl-op-lookup ","))
|
||||
((or (= ty "atom") (= ty "op")) (pl-op-lookup vv))
|
||||
((and (= ty "punct") (= vv ","))
|
||||
(let
|
||||
((info (pl-op-lookup ",")))
|
||||
(if (nil? info) nil (cons "," info))))
|
||||
((or (= ty "atom") (= ty "op"))
|
||||
(let
|
||||
((info (pl-op-lookup vv)))
|
||||
(if (nil? info) nil (cons vv info))))
|
||||
(true nil)))))
|
||||
|
||||
;; ── Term parser ─────────────────────────────────────────────────────
|
||||
|
||||
@@ -3,5 +3,5 @@
|
||||
"total_failed": 0,
|
||||
"total": 590,
|
||||
"suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"term_inspect":{"passed":14,"total":14,"failed":0},"append":{"passed":6,"total":6,"failed":0},"reverse":{"passed":6,"total":6,"failed":0},"member":{"passed":7,"total":7,"failed":0},"nqueens":{"passed":6,"total":6,"failed":0},"family":{"passed":10,"total":10,"failed":0},"atoms":{"passed":34,"total":34,"failed":0},"query_api":{"passed":16,"total":16,"failed":0},"iso_predicates":{"passed":29,"total":29,"failed":0},"meta_predicates":{"passed":25,"total":25,"failed":0},"list_predicates":{"passed":33,"total":33,"failed":0},"meta_call":{"passed":15,"total":15,"failed":0},"set_predicates":{"passed":15,"total":15,"failed":0},"char_predicates":{"passed":27,"total":27,"failed":0},"io_predicates":{"passed":24,"total":24,"failed":0},"assert_rules":{"passed":15,"total":15,"failed":0},"string_agg":{"passed":25,"total":25,"failed":0},"advanced":{"passed":21,"total":21,"failed":0},"compiler":{"passed":17,"total":17,"failed":0},"cross_validate":{"passed":17,"total":17,"failed":0},"integration":{"passed":20,"total":20,"failed":0},"hs_bridge":{"passed":19,"total":19,"failed":0}},
|
||||
"generated": "2026-05-07T17:35:23+00:00"
|
||||
"generated": "2026-05-06T12:17:46+00:00"
|
||||
}
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
# Prolog scoreboard
|
||||
|
||||
**590 / 590 passing** (0 failure(s)).
|
||||
Generated 2026-05-07T17:35:23+00:00.
|
||||
Generated 2026-05-06T12:17:46+00:00.
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
{
|
||||
"date": "2026-05-06T21:06:00Z",
|
||||
"date": "2026-04-25T16:05:32Z",
|
||||
"programs": [
|
||||
"eight-queens.st",
|
||||
"fibonacci.st",
|
||||
@@ -8,8 +8,8 @@
|
||||
"quicksort.st"
|
||||
],
|
||||
"program_count": 5,
|
||||
"program_tests_passed": 4,
|
||||
"all_tests_passed": 625,
|
||||
"all_tests_total": 629,
|
||||
"exit_code": 1
|
||||
"program_tests_passed": 39,
|
||||
"all_tests_passed": 847,
|
||||
"all_tests_total": 847,
|
||||
"exit_code": 0
|
||||
}
|
||||
|
||||
@@ -1,13 +1,13 @@
|
||||
# Smalltalk-on-SX Scoreboard
|
||||
|
||||
_Last run: 2026-05-06T21:06:00Z_
|
||||
_Last run: 2026-04-25T16:05:32Z_
|
||||
|
||||
## Totals
|
||||
|
||||
| Suite | Passing |
|
||||
|-------|---------|
|
||||
| All Smalltalk-on-SX tests | **625 / 629** |
|
||||
| Classic-corpus tests (`tests/programs.sx`) | **4** |
|
||||
| All Smalltalk-on-SX tests | **847 / 847** |
|
||||
| Classic-corpus tests (`tests/programs.sx`) | **39** |
|
||||
|
||||
## Classic-corpus programs (`lib/smalltalk/tests/programs/`)
|
||||
|
||||
@@ -22,6 +22,7 @@ _Last run: 2026-05-06T21:06:00Z_
|
||||
## Per-file test counts
|
||||
|
||||
```
|
||||
OK lib/smalltalk/tests/ansi.sx 62 passed
|
||||
OK lib/smalltalk/tests/blocks.sx 19 passed
|
||||
OK lib/smalltalk/tests/cannot_return.sx 5 passed
|
||||
OK lib/smalltalk/tests/collections.sx 29 passed
|
||||
@@ -29,13 +30,16 @@ OK lib/smalltalk/tests/conditional.sx 25 passed
|
||||
OK lib/smalltalk/tests/dnu.sx 15 passed
|
||||
OK lib/smalltalk/tests/eval.sx 68 passed
|
||||
OK lib/smalltalk/tests/exceptions.sx 15 passed
|
||||
OK lib/smalltalk/tests/hashed.sx 30 passed
|
||||
OK lib/smalltalk/tests/inline_cache.sx 10 passed
|
||||
OK lib/smalltalk/tests/intrinsics.sx 24 passed
|
||||
OK lib/smalltalk/tests/nlr.sx 14 passed
|
||||
OK lib/smalltalk/tests/numbers.sx 47 passed
|
||||
OK lib/smalltalk/tests/parse_chunks.sx 21 passed
|
||||
OK lib/smalltalk/tests/parse.sx 47 passed
|
||||
OK lib/smalltalk/tests/pharo.sx 91 passed
|
||||
OK lib/smalltalk/tests/printing.sx 19 passed
|
||||
OK lib/smalltalk/tests/programs.sx 39 passed
|
||||
OK lib/smalltalk/tests/reflection.sx 77 passed
|
||||
OK lib/smalltalk/tests/runtime.sx 64 passed
|
||||
OK lib/smalltalk/tests/streams.sx 21 passed
|
||||
@@ -43,10 +47,6 @@ OK lib/smalltalk/tests/sunit.sx 19 passed
|
||||
OK lib/smalltalk/tests/super.sx 9 passed
|
||||
OK lib/smalltalk/tests/tokenize.sx 63 passed
|
||||
OK lib/smalltalk/tests/while.sx 14 passed
|
||||
X lib/smalltalk/tests/ansi.sx: could not extract summary
|
||||
X lib/smalltalk/tests/hashed.sx: could not extract summary
|
||||
X lib/smalltalk/tests/pharo.sx: could not extract summary
|
||||
X lib/smalltalk/tests/programs.sx: could not extract summary
|
||||
```
|
||||
|
||||
## Notes
|
||||
|
||||
@@ -63,8 +63,6 @@ for tcl_file in "${TCL_FILES[@]}"; do
|
||||
# Build epoch input using quoted heredoc for static parts; helper path via variable
|
||||
cat > "$tmpfile" << EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/guest/lex.sx")
|
||||
(load "lib/guest/prefix.sx")
|
||||
(load "lib/tcl/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/tcl/parser.sx")
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,10 +1,9 @@
|
||||
{
|
||||
"total": 4,
|
||||
"total": 3,
|
||||
"passed": 3,
|
||||
"failed": 1,
|
||||
"failed": 0,
|
||||
"programs": {
|
||||
"assert": {"status": "PASS", "expected": "10", "got": "10"},
|
||||
"event-loop": {"status": "FAIL", "expected": "done", "got": ""},
|
||||
"for-each-line": {"status": "PASS", "expected": "13", "got": "13"},
|
||||
"with-temp-var": {"status": "PASS", "expected": "100 999", "got": "100 999"}
|
||||
}
|
||||
|
||||
@@ -3,8 +3,7 @@
|
||||
| Program | Status | Expected | Got |
|
||||
|---|---|---|---|
|
||||
| assert | ✓ PASS | 10 | 10 |
|
||||
| event-loop | ✗ FAIL | done | |
|
||||
| for-each-line | ✓ PASS | 13 | 13 |
|
||||
| with-temp-var | ✓ PASS | 100 999 | 100 999 |
|
||||
|
||||
**3/4 passing**
|
||||
**3/3 passing**
|
||||
|
||||
@@ -33,8 +33,6 @@ HELPER_EOF
|
||||
|
||||
cat > "$TMPFILE" << EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/guest/lex.sx")
|
||||
(load "lib/guest/prefix.sx")
|
||||
(load "lib/tcl/tokenizer.sx")
|
||||
(epoch 2)
|
||||
(load "lib/tcl/parser.sx")
|
||||
@@ -59,7 +57,7 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(eval "tcl-test-summary")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 2400 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
OUTPUT=$(timeout 7200 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||
|
||||
# Extract summary line from epoch 11 output
|
||||
|
||||
@@ -415,6 +415,268 @@
|
||||
:result)
|
||||
"")
|
||||
|
||||
; 60-63. Phase 6a namespace :: prefix
|
||||
(ok "ns-set-from-proc-reaches-global"
|
||||
(get
|
||||
(run
|
||||
"proc f {x} { set ::g $x }\nf hello\nset ::g")
|
||||
:result)
|
||||
"hello")
|
||||
|
||||
(ok "ns-read-from-proc"
|
||||
(get
|
||||
(run
|
||||
"set ::v 42\nproc f {} { return $::v }\nf")
|
||||
:result)
|
||||
"42")
|
||||
|
||||
(ok "ns-incr-via-prefix"
|
||||
(get
|
||||
(run
|
||||
"set ::n 5\nproc bump {} { incr ::n }\nbump\nbump\nset ::n")
|
||||
:result)
|
||||
"7")
|
||||
|
||||
(ok "ns-different-from-local"
|
||||
(get
|
||||
(run
|
||||
"set x outer\nproc f {} { set x inner; set ::x global; return $x }\nf")
|
||||
:result)
|
||||
"inner")
|
||||
|
||||
; 64-69. Phase 6b list ops (lassign, lrepeat, lset, lmap)
|
||||
(ok "lassign-three"
|
||||
(get (run "lassign {a b c d e} x y z\nlist $x $y $z") :result)
|
||||
"a b c")
|
||||
|
||||
(ok "lassign-leftover"
|
||||
(get (run "lassign {1 2 3 4 5} a b") :result)
|
||||
"3 4 5")
|
||||
|
||||
(ok "lrepeat-basic"
|
||||
(get (run "lrepeat 3 a") :result)
|
||||
"a a a")
|
||||
|
||||
(ok "lrepeat-multi"
|
||||
(get (run "lrepeat 2 x y") :result)
|
||||
"x y x y")
|
||||
|
||||
(ok "lset-replaces"
|
||||
(get (run "set L {a b c d}\nlset L 2 ZZ\nset L") :result)
|
||||
"a b ZZ d")
|
||||
|
||||
(ok "lmap-square"
|
||||
(get (run "lmap n {1 2 3 4} {expr {$n * $n}}") :result)
|
||||
"1 4 9 16")
|
||||
|
||||
; 70-72. Phase 6c dict additions (lappend, remove, filter)
|
||||
(ok "dict-lappend-extends"
|
||||
(get (run "set d {tags {a b}}\ndict lappend d tags c d\nset d") :result)
|
||||
"tags {a b c d}")
|
||||
|
||||
(ok "dict-remove"
|
||||
(get (run "dict remove {a 1 b 2 c 3} b") :result)
|
||||
"a 1 c 3")
|
||||
|
||||
(ok "dict-filter-key"
|
||||
(get (run "dict filter {alpha 1 beta 2 gamma 3} key a*") :result)
|
||||
"alpha 1")
|
||||
|
||||
; 73-79. Phase 6d format and scan
|
||||
(ok "format-int-padded"
|
||||
(get (run "format {%05d} 42") :result)
|
||||
"00042")
|
||||
|
||||
(ok "format-float-precision"
|
||||
(get (run "format {%.2f} 3.14159") :result)
|
||||
"3.14")
|
||||
|
||||
(ok "format-hex"
|
||||
(get (run "format {%x} 255") :result)
|
||||
"ff")
|
||||
|
||||
(ok "format-char"
|
||||
(get (run "format {%c} 65") :result)
|
||||
"A")
|
||||
|
||||
(ok "format-string-left"
|
||||
(get (run "format {%-5s|} hi") :result)
|
||||
"hi |")
|
||||
|
||||
(ok "scan-two-ints"
|
||||
(get (run "scan {12 34} {%d %d} a b\nlist $a $b") :result)
|
||||
"12 34")
|
||||
|
||||
(ok "scan-count"
|
||||
(get (run "scan {hello 42} {%s %d}") :result)
|
||||
"hello 42")
|
||||
|
||||
; 80-82. Phase 6e exec
|
||||
(ok "exec-echo"
|
||||
(get (run "exec echo hello world") :result)
|
||||
"hello world")
|
||||
|
||||
(ok "exec-printf-no-newline"
|
||||
(get (run "exec /bin/printf x") :result)
|
||||
"x")
|
||||
|
||||
(ok "exec-with-args"
|
||||
(get (run "exec /bin/echo -n test") :result)
|
||||
"test")
|
||||
|
||||
; 83-87. Phase 7a try/trap with varlist
|
||||
(ok "try-trap-prefix-match"
|
||||
(get
|
||||
(run
|
||||
"try {throw {ARITH DIVZERO} divide-by-zero} trap {ARITH} {res} {set caught $res}")
|
||||
:result)
|
||||
"divide-by-zero")
|
||||
|
||||
(ok "try-trap-full-pattern"
|
||||
(get
|
||||
(run
|
||||
"try {throw {FOO BAR} bad} trap {FOO BAR} {res} {return matched-foo-bar}")
|
||||
:result)
|
||||
"matched-foo-bar")
|
||||
|
||||
(ok "try-on-error-opts"
|
||||
(get
|
||||
(run
|
||||
"try {error oops} on error {res opts} {dict get $opts -code}")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "try-trap-no-match-falls-through"
|
||||
(get
|
||||
(run
|
||||
"set caught notrun\ncatch {try {throw {NOPE} bad} trap {OTHER} {r} {set caught matched}}\nset caught")
|
||||
:result)
|
||||
"notrun")
|
||||
|
||||
(ok "try-trap-then-on-error"
|
||||
(get
|
||||
(run
|
||||
"try {error generic} trap {SPECIFIC} {r} {return trap-fired} on error {r} {return on-error-fired}")
|
||||
:result)
|
||||
"on-error-fired")
|
||||
|
||||
; 88-92. Phase 7b exec pipelines + redirection
|
||||
(ok "exec-pipeline-tr"
|
||||
(get (run "exec echo hello world | tr a-z A-Z") :result)
|
||||
"HELLO WORLD")
|
||||
|
||||
(ok "exec-pipeline-wc"
|
||||
(get (run "exec /bin/echo abc | wc -c") :result)
|
||||
"4")
|
||||
|
||||
(ok "exec-redirect-stdout"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-7b-out.txt\nexec echo hello > $f\nset r [exec cat $f]\nfile delete $f\nreturn $r")
|
||||
:result)
|
||||
"hello")
|
||||
|
||||
(ok "exec-redirect-stdin"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-7b-in.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset r [exec cat < $f]\nfile delete $f\nreturn $r")
|
||||
:result)
|
||||
"hi")
|
||||
|
||||
(ok "exec-pipeline-three-stages"
|
||||
(get (run "exec echo {alpha beta gamma} | tr { } \\n | wc -l") :result)
|
||||
"3")
|
||||
|
||||
; 93-99. Phase 7c string command audit
|
||||
(ok "string-equal"
|
||||
(get (run "string equal hello hello") :result)
|
||||
"1")
|
||||
|
||||
(ok "string-equal-nocase"
|
||||
(get (run "string equal -nocase HELLO hello") :result)
|
||||
"1")
|
||||
|
||||
(ok "string-totitle"
|
||||
(get (run "string totitle hello") :result)
|
||||
"Hello")
|
||||
|
||||
(ok "string-reverse"
|
||||
(get (run "string reverse hello") :result)
|
||||
"olleh")
|
||||
|
||||
(ok "string-replace"
|
||||
(get (run "string replace hello 1 3 ZZZ") :result)
|
||||
"hZZZo")
|
||||
|
||||
(ok "string-is-xdigit-yes"
|
||||
(get (run "string is xdigit ff00aa") :result)
|
||||
"1")
|
||||
|
||||
(ok "string-is-true-yes"
|
||||
(get (run "string is true yes") :result)
|
||||
"1")
|
||||
|
||||
; 100-105. Phase 7e regexp anchoring/boundary audit
|
||||
(ok "regexp-anchor-start"
|
||||
(get (run "regexp {^hello} hello-world") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-anchor-end"
|
||||
(get (run "regexp {world$} hello-world") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-word-boundary"
|
||||
(get (run "regexp {\\bword\\b} \"the word here\"") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-nocase"
|
||||
(get (run "regexp -nocase {HELLO} hello") :result)
|
||||
"1")
|
||||
|
||||
(ok "regexp-capture-var"
|
||||
(get (run "regexp {[0-9]+} abc123def captured\nset captured") :result)
|
||||
"123")
|
||||
|
||||
(ok "regsub-all"
|
||||
(get (run "regsub -all {[0-9]+} a1b22c333 X") :result)
|
||||
"aXbXcX")
|
||||
|
||||
; 106-110. Phase 7d TclOO basics
|
||||
(ok "oo-class-method"
|
||||
(get
|
||||
(run
|
||||
"oo::class create C {\nmethod get {} { return 42 }\n}\nset c [C new]\n$c get")
|
||||
:result)
|
||||
"42")
|
||||
|
||||
(ok "oo-constructor"
|
||||
(get
|
||||
(run
|
||||
"oo::class create G {\nconstructor {n} { set ::gname $n }\nmethod hello {} { return [string cat \"hi \" $::gname] }\n}\nset g [G new World]\n$g hello")
|
||||
:result)
|
||||
"hi World")
|
||||
|
||||
(ok "oo-inheritance-overridden"
|
||||
(get
|
||||
(run
|
||||
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Dog {\nsuperclass Animal\nmethod sound {} { return woof }\n}\nset d [Dog new]\n$d sound")
|
||||
:result)
|
||||
"woof")
|
||||
|
||||
(ok "oo-inheritance-inherited"
|
||||
(get
|
||||
(run
|
||||
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Cat {\nsuperclass Animal\n}\nset c [Cat new]\n$c sound")
|
||||
:result)
|
||||
"generic")
|
||||
|
||||
(ok "oo-multiple-instances"
|
||||
(get
|
||||
(run
|
||||
"oo::class create N {\nconstructor {x} { set ::nval $x }\nmethod get {} { return $::nval }\n}\nset a [N new 1]\nset b [N new 99]\n$b get")
|
||||
:result)
|
||||
"99")
|
||||
|
||||
(dict
|
||||
"passed"
|
||||
tcl-idiom-pass
|
||||
|
||||
@@ -1,10 +1,19 @@
|
||||
(prefix-rename "tcl-"
|
||||
'((ws? lex-space?)
|
||||
(alpha? lex-alpha?)
|
||||
(digit? lex-digit?)
|
||||
(ident-start? lex-ident-start?)
|
||||
(ident-char? lex-ident-char?)))
|
||||
(define tcl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
|
||||
|
||||
(define tcl-alpha?
|
||||
(fn (c)
|
||||
(and
|
||||
(not (= c nil))
|
||||
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
|
||||
|
||||
(define tcl-digit?
|
||||
(fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
|
||||
|
||||
(define tcl-ident-start?
|
||||
(fn (c) (or (tcl-alpha? c) (= c "_"))))
|
||||
|
||||
(define tcl-ident-char?
|
||||
(fn (c) (or (tcl-ident-start? c) (tcl-digit? c))))
|
||||
|
||||
(define tcl-tokenize
|
||||
(fn (src)
|
||||
@@ -158,7 +167,9 @@
|
||||
(begin
|
||||
(when (= (cur) "}") (advance! 1))
|
||||
{:type "var" :name name}))))))
|
||||
((tcl-ident-start? (cur))
|
||||
((or
|
||||
(tcl-ident-start? (cur))
|
||||
(and (= (cur) ":") (= (char-at 1) ":")))
|
||||
(let ((start pos))
|
||||
(begin
|
||||
(scan-ns-name!)
|
||||
|
||||
@@ -11,7 +11,7 @@ isolation: worktree
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/apl-on-sx.md`. Isolated worktree, forever, one commit per feature. Push to `origin/loops/apl` after every commit.
|
||||
You are the sole background agent working `/root/rose-ash/plans/apl-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
@@ -42,7 +42,7 @@ Every iteration: implement → test → commit → tick `[ ]` → Progress log
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Unicode in `.sx`:** raw UTF-8 only, never `\uXXXX` escapes. Glyphs land directly in source.
|
||||
- **Worktree:** commit, then push to `origin/loops/apl`. Never touch `main`.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
|
||||
@@ -1,118 +0,0 @@
|
||||
# lib/guest extraction loop (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/lib-guest.md` forever. Each iteration picks the top `pending` step, extracts/ports/validates, commits, logs, moves on. North star: every guest's `scoreboard.json` ≥ baseline at all times, while `lib/guest/` accumulates shared infrastructure.
|
||||
|
||||
```
|
||||
description: lib/guest extraction loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/lib-guest.md`. You work a prioritised queue, one step per code commit, indefinitely. The plan file is the source of truth for what's pending, in-progress, done, and blocked. Update it after every iteration.
|
||||
|
||||
## Iteration protocol (follow exactly)
|
||||
|
||||
### 1. Read state
|
||||
|
||||
- Read `plans/lib-guest.md` in full.
|
||||
- Pick the first step with status `[ ]`. If all remaining are `[blocked]` or `[done]`, stop and report loop complete.
|
||||
- Set that step's status to `[in-progress]` and commit the plan change alone:
|
||||
`GUEST-plan: claim step <N> — <name>`.
|
||||
|
||||
### 2. Baseline (every iteration that touches a guest)
|
||||
|
||||
Before any code edit, snapshot the **current** scoreboard for every guest this step will touch (extraction consumers + canaries):
|
||||
|
||||
```
|
||||
bash lib/<guest>/conformance.sh # or test.sh
|
||||
cp lib/<guest>/scoreboard.json /tmp/baseline-<guest>-step<N>.json
|
||||
```
|
||||
|
||||
If the step is Step 0, the snapshot itself is the work — copy each guest's `scoreboard.json` (or harvest pass/fail counts from `test.sh` for guests without a scoreboard) into `lib/guest/baseline/<lang>.json`, populate the table in `plans/lib-guest.md`, commit, done.
|
||||
|
||||
### 3. Do the work
|
||||
|
||||
For each step the protocol is:
|
||||
1. Read the relevant existing guest file(s) via `sx_read_subtree` to see exactly what shape needs extracting.
|
||||
2. Draft `lib/guest/<file>.sx` via `sx_write_file` (validates by parsing).
|
||||
3. Port the **first** consumer to use it. Run that guest's conformance. Must equal baseline.
|
||||
4. Port the **second** consumer (the two-language rule). Run that guest's conformance. Must equal baseline.
|
||||
5. If the second consumer needs escape hatches that the first didn't, the abstraction is wrong — **redesign before continuing**, don't paper over with alias chains or per-language flags.
|
||||
|
||||
For Step 0 only: just snapshot, no extraction.
|
||||
|
||||
### 4. Verify
|
||||
|
||||
For every guest the step touched:
|
||||
|
||||
```
|
||||
bash lib/<guest>/conformance.sh # or test.sh
|
||||
diff lib/<guest>/scoreboard.json /tmp/baseline-<guest>-step<N>.json
|
||||
```
|
||||
|
||||
**Abort rule:** if any touched guest's scoreboard regresses by ≥1 test, do NOT commit code. Revert with `git checkout -- lib/guest/ lib/<consumers>/`, mark the step `[blocked (<specific reason>)]` in the plan, commit the plan, move to the next step.
|
||||
|
||||
### 5. Commit code
|
||||
|
||||
One commit for the code:
|
||||
|
||||
```
|
||||
GUEST: step <N> — <name>
|
||||
|
||||
<2-4 lines on what was extracted, which two consumers were ported, baseline-equal verification.>
|
||||
|
||||
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
|
||||
```
|
||||
|
||||
### 6. Update plan + commit
|
||||
|
||||
In `plans/lib-guest.md`:
|
||||
- Change this step's status from `[in-progress]` to `[done]` (or `[partial — pending <consumer>]`).
|
||||
- Fill in the Commit and Delta columns of the progress log.
|
||||
- If you re-snapshotted any baseline, update the Baseline column.
|
||||
|
||||
Commit: `GUEST-plan: log step <N> done`.
|
||||
|
||||
### 7. Move on
|
||||
|
||||
Go back to step 1. Continue until:
|
||||
- All steps are `[done]` or `[blocked]`, OR
|
||||
- You hit your iteration budget, OR
|
||||
- You encounter a substrate-level failure (build broken, sx_server.exe missing) — stop and report.
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Branch:** `architecture`. Commit locally. **Never push.** **Never touch `main`.**
|
||||
- **Scope:** ONLY `lib/guest/**`, `lib/{lua,prolog,haskell,common-lisp,tcl,erlang,smalltalk,forth,ruby,apl,js}/**`, `plans/lib-guest.md`, `plans/agent-briefings/lib-guest-loop.md`. NO `spec/`, `hosts/`, `web/`, `shared/`.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. Never `Edit`/`Read`/`Write` on `.sx`. `sx_validate` after every edit.
|
||||
- **OCaml build:** `sx_build target="ocaml"` MCP tool. Never raw `dune`.
|
||||
- **Two-language rule:** never merge an extraction until two guests consume it. Step 8 (HM) is the only exception, marked explicitly.
|
||||
- **No alias chains** to bridge naming drift between extraction and consumer — rename consumer-side or extraction-side, don't add a translation layer.
|
||||
- **No new planning docs** beyond updating the plan file.
|
||||
- **No comments in SX** unless non-obvious.
|
||||
- **Unicode in SX:** raw UTF-8, never `\uXXXX`.
|
||||
- **Hard timeout:** >45 min on a step → mark `blocked`, move on.
|
||||
- **Partial fixes are OK.** If you extract something and only the first consumer ports cleanly, mark `[partial — pending <second consumer>]`, commit, move on. The next iteration that lands the second consumer flips it to `[done]`.
|
||||
|
||||
## Gotchas from past sessions
|
||||
|
||||
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks scope chain). Macros that want to introduce names use `env-bind!`.
|
||||
- SX `do` is R7RS iteration, not a sequence form. Use `begin` for multi-expr bodies.
|
||||
- `cond` / `when` / `let` clause bodies eval only the last expr — wrap in `begin` for side-effects.
|
||||
- `list?` returns false on raw JS Arrays — host-side data must be SX-converted.
|
||||
- `make-symbol` builds an identifier symbol; `string->symbol` exists too — use whichever the surrounding code uses.
|
||||
- `sx_validate` after every edit. The hook will block raw `Edit`/`Write` on `.sx` anyway, but the validator catches subtree mistakes that parse-but-don't-mean-what-you-think.
|
||||
- Guest `conformance.sh` scripts use the epoch protocol against `sx_server.exe`. If the server isn't built, run `sx_build target="ocaml"` first.
|
||||
- Each guest's `scoreboard.json` schema differs slightly — normalise to `{:totals {:pass N :fail M} :suites [...]}` when writing `lib/guest/baseline/<lang>.json`.
|
||||
- `lib/parser-combinators.sx` exists and is unused by any guest. The new lex/Pratt kit may want to coexist with it, or supersede it — investigate before duplicating its functionality.
|
||||
- Prolog operator parsing is the stress test for Pratt — Prolog ops have variable precedence, `xfx`/`xfy`/`yfx` associativity classes, and user-definable ops at runtime. The Pratt kit must accommodate runtime registration, not just static tables.
|
||||
- Haskell layout is the stress test for whitespace-sensitive lexing — off-side rule, do/let/where/of opening blocks, semicolon insertion, brace insertion. Don't ship `lib/guest/layout.sx` unless the haskell scoreboard equals baseline.
|
||||
|
||||
## Starting state
|
||||
|
||||
- Branch: `architecture`. HEAD at or near `40f0e733`.
|
||||
- Canaries: **Lua** + **Prolog**.
|
||||
- Plan file at `plans/lib-guest.md`. Step 0 (baseline snapshot) is the first iteration.
|
||||
- `lib/guest/` does not yet exist — create it on the Step 0 commit.
|
||||
@@ -48,92 +48,61 @@ Core mapping:
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser
|
||||
- [x] Tokenizer: Unicode glyphs (the full APL set: `+ - × ÷ * ⍟ ⌈ ⌊ | ! ? ○ ~ < ≤ = ≥ > ≠ ∊ ∧ ∨ ⍱ ⍲ , ⍪ ⍴ ⌽ ⊖ ⍉ ↑ ↓ ⊂ ⊃ ⊆ ∪ ∩ ⍳ ⍸ ⌷ ⍋ ⍒ ⊥ ⊤ ⊣ ⊢ ⍎ ⍕ ⍝`), operators (`/ \ ¨ ⍨ ∘ . ⍣ ⍤ ⍥ @`), numbers (`¯` for negative, `1E2`, `1J2` complex deferred), characters (`'a'`, `''` escape), strands (juxtaposition of literals: `1 2 3`), names, comments `⍝ …`
|
||||
- [x] Parser: right-to-left; classify each token as function, operator, value, or name; resolve valence positionally; dfn `{…}` body, tradfn `∇` header, guards `:`; outer product `∘.f`, inner product `f.g`, derived fns `f/ f¨ f⍨ f⍣n`
|
||||
- [x] Unit tests in `lib/apl/tests/parse.sx`
|
||||
- [ ] Tokenizer: Unicode glyphs (the full APL set: `+ - × ÷ * ⍟ ⌈ ⌊ | ! ? ○ ~ < ≤ = ≥ > ≠ ∊ ∧ ∨ ⍱ ⍲ , ⍪ ⍴ ⌽ ⊖ ⍉ ↑ ↓ ⊂ ⊃ ⊆ ∪ ∩ ⍳ ⍸ ⌷ ⍋ ⍒ ⊥ ⊤ ⊣ ⊢ ⍎ ⍕ ⍝`), operators (`/ \ ¨ ⍨ ∘ . ⍣ ⍤ ⍥ @`), numbers (`¯` for negative, `1E2`, `1J2` complex deferred), characters (`'a'`, `''` escape), strands (juxtaposition of literals: `1 2 3`), names, comments `⍝ …`
|
||||
- [ ] Parser: right-to-left; classify each token as function, operator, value, or name; resolve valence positionally; dfn `{…}` body, tradfn `∇` header, guards `:`, control words `:If :While :For …` (Dyalog-style)
|
||||
- [ ] Unit tests in `lib/apl/tests/parse.sx`
|
||||
|
||||
### Phase 2 — array model + scalar primitives
|
||||
- [x] Array constructor: `make-array shape ravel`, `scalar v`, `vector v…`, `enclose`/`disclose`
|
||||
- [x] Shape arithmetic: `⍴` (shape), `,` (ravel), `≢` (tally / first-axis-length), `≡` (depth)
|
||||
- [x] Scalar arithmetic primitives broadcast: `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`
|
||||
- [x] Scalar comparison primitives: `< ≤ = ≥ > ≠`
|
||||
- [x] Scalar logical: `~ ∧ ∨ ⍱ ⍲`
|
||||
- [x] Index generator: `⍳n` (vector 1..n or 0..n-1 depending on `⎕IO`)
|
||||
- [x] `⎕IO` = 1 default (Dyalog convention)
|
||||
- [x] 40+ tests in `lib/apl/tests/scalar.sx`
|
||||
- [ ] Array constructor: `make-array shape ravel`, `scalar v`, `vector v…`, `enclose`/`disclose`
|
||||
- [ ] Shape arithmetic: `⍴` (shape), `,` (ravel), `≢` (tally / first-axis-length), `≡` (depth)
|
||||
- [ ] Scalar arithmetic primitives broadcast: `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`
|
||||
- [ ] Scalar comparison primitives: `< ≤ = ≥ > ≠`
|
||||
- [ ] Scalar logical: `~ ∧ ∨ ⍱ ⍲`
|
||||
- [ ] Index generator: `⍳n` (vector 1..n or 0..n-1 depending on `⎕IO`)
|
||||
- [ ] `⎕IO` = 1 default (Dyalog convention)
|
||||
- [ ] 40+ tests in `lib/apl/tests/scalar.sx`
|
||||
|
||||
### Phase 3 — structural primitives + indexing
|
||||
- [x] Reshape `⍴`, ravel `,`, transpose `⍉` (full + dyadic axis spec)
|
||||
- [x] Take `↑`, drop `↓`, rotate `⌽` (last axis), `⊖` (first axis)
|
||||
- [x] Catenate `,` (last axis) and `⍪` (first axis)
|
||||
- [x] Index `⌷` (squad), bracket-indexing `A[I]` (sugar for `⌷`)
|
||||
- [x] Grade-up `⍋`, grade-down `⍒`
|
||||
- [x] Enclose `⊂`, disclose `⊃`, partition (subset deferred)
|
||||
- [x] Membership `∊`, find `⍳` (dyadic), without `~` (dyadic), unique `∪` (deferred to phase 6)
|
||||
- [x] 40+ tests in `lib/apl/tests/structural.sx`
|
||||
- [ ] Reshape `⍴`, ravel `,`, transpose `⍉` (full + dyadic axis spec)
|
||||
- [ ] Take `↑`, drop `↓`, rotate `⌽` (last axis), `⊖` (first axis)
|
||||
- [ ] Catenate `,` (last axis) and `⍪` (first axis)
|
||||
- [ ] Index `⌷` (squad), bracket-indexing `A[I]` (sugar for `⌷`)
|
||||
- [ ] Grade-up `⍋`, grade-down `⍒`
|
||||
- [ ] Enclose `⊂`, disclose `⊃`, partition (subset deferred)
|
||||
- [ ] Membership `∊`, find `⍳` (dyadic), without `~` (dyadic), unique `∪` (deferred to phase 6)
|
||||
- [ ] 40+ tests in `lib/apl/tests/structural.sx`
|
||||
|
||||
### Phase 4 — operators (THE SHOWCASE)
|
||||
- [x] Reduce `f/` (last axis), `f⌿` (first axis) — including `∧/`, `∨/`, `+/`, `×/`, `⌈/`, `⌊/`
|
||||
- [x] Scan `f\`, `f⍀`
|
||||
- [x] Each `f¨` — applies `f` to each scalar/element
|
||||
- [x] Outer product `∘.f` — `1 2 3 ∘.× 1 2 3` ↦ multiplication table
|
||||
- [x] Inner product `f.g` — `+.×` is matrix multiply
|
||||
- [x] Commute `f⍨` — `f⍨ x` ↔ `x f x`, `x f⍨ y` ↔ `y f x`
|
||||
- [x] Compose `f∘g` — applies `g` first then `f`
|
||||
- [x] Power `f⍣n` — apply f n times; `f⍣≡` until fixed point
|
||||
- [x] Rank `f⍤k` — apply f at sub-rank k
|
||||
- [x] At `@` — selective replace
|
||||
- [x] 40+ tests in `lib/apl/tests/operators.sx`
|
||||
- [ ] Reduce `f/` (last axis), `f⌿` (first axis) — including `∧/`, `∨/`, `+/`, `×/`, `⌈/`, `⌊/`
|
||||
- [ ] Scan `f\`, `f⍀`
|
||||
- [ ] Each `f¨` — applies `f` to each scalar/element
|
||||
- [ ] Outer product `∘.f` — `1 2 3 ∘.× 1 2 3` ↦ multiplication table
|
||||
- [ ] Inner product `f.g` — `+.×` is matrix multiply
|
||||
- [ ] Commute `f⍨` — `f⍨ x` ↔ `x f x`, `x f⍨ y` ↔ `y f x`
|
||||
- [ ] Compose `f∘g` — applies `g` first then `f`
|
||||
- [ ] Power `f⍣n` — apply f n times; `f⍣≡` until fixed point
|
||||
- [ ] Rank `f⍤k` — apply f at sub-rank k
|
||||
- [ ] At `@` — selective replace
|
||||
- [ ] 40+ tests in `lib/apl/tests/operators.sx`
|
||||
|
||||
### Phase 5 — dfns + tradfns + control flow
|
||||
- [x] Dfn `{…}` with `⍺` (left arg, may be absent → niladic/monadic), `⍵` (right arg), `∇` (recurse), guards `cond:expr`, default left arg `⍺←default`
|
||||
- [x] Local assignment via `←` (lexical inside dfn)
|
||||
- [x] Tradfn `∇` header: `R←L F R;l1;l2`, statement-by-statement, branch via `→linenum`
|
||||
- [x] Dyalog control words: `:If/:Else/:EndIf`, `:While/:EndWhile`, `:For X :In V :EndFor`, `:Select/:Case/:EndSelect`, `:Trap`/`:EndTrap` _(Trap deferred — no exception machinery yet)_
|
||||
- [x] Niladic / monadic / dyadic dispatch (function valence at definition time)
|
||||
- [x] `lib/apl/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
- [ ] Dfn `{…}` with `⍺` (left arg, may be absent → niladic/monadic), `⍵` (right arg), `∇` (recurse), guards `cond:expr`, default left arg `⍺←default`
|
||||
- [ ] Local assignment via `←` (lexical inside dfn)
|
||||
- [ ] Tradfn `∇` header: `R←L F R;l1;l2`, statement-by-statement, branch via `→linenum`
|
||||
- [ ] Dyalog control words: `:If/:Else/:EndIf`, `:While/:EndWhile`, `:For X :In V :EndFor`, `:Select/:Case/:EndSelect`, `:Trap`/`:EndTrap`
|
||||
- [ ] Niladic / monadic / dyadic dispatch (function valence at definition time)
|
||||
- [ ] `lib/apl/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
|
||||
### Phase 6 — classic programs + drive corpus
|
||||
- [x] Classic programs in `lib/apl/tests/programs/`:
|
||||
- [x] `life.apl` — Conway's Game of Life as a one-liner using `⊂` `⊖` `⌽` `+/`
|
||||
- [x] `mandelbrot.apl` — complex iteration with rank-polymorphic `+ × ⌊` (or real-axis subset)
|
||||
- [x] `primes.apl` — `(2=+⌿0=A∘.|A)/A←⍳N` sieve
|
||||
- [x] `n-queens.apl` — backtracking via reduce
|
||||
- [x] `quicksort.apl` — the classic Roger Hui one-liner
|
||||
- [x] System functions: `⎕FMT`, `⎕FR` (float repr), `⎕TS` (timestamp), `⎕IO`, `⎕ML` (migration level — fixed at 1), `⎕←` (print)
|
||||
- [x] Drive corpus to 100+ green
|
||||
- [x] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms
|
||||
|
||||
### Phase 7 — end-to-end pipeline + closing the gaps
|
||||
|
||||
Phase 1-6 built parser and runtime as parallel layers — they don't yet meet.
|
||||
Phase 7 wires them together so APL source actually runs through the full stack,
|
||||
and tightens loose ends.
|
||||
|
||||
- [x] **Operators in `apl-eval-ast`** — handle `:derived-fn` (e.g. `+/`, `f¨`),
|
||||
`:outer` (`∘.f`), `:derived-fn2` (`f.g`). Each derived-fn-node wraps an inner
|
||||
function; eval-ast resolves the inner glyph to a runtime fn and dispatches
|
||||
to the matching operator helper (`apl-reduce`, `apl-each`, `apl-outer`,
|
||||
`apl-inner`, `apl-commute`, `apl-compose`, `apl-power`, `apl-rank`).
|
||||
- [x] **End-to-end pipeline** — entry point `apl-run : string → array` that
|
||||
chains `apl-tokenize` → `parse-apl` → `apl-eval-ast` against an empty env.
|
||||
Verify with one-liners (`+/⍳5` → 15, `1 2 3 + 4 5 6` → 7 9 11, etc.) and
|
||||
with the actual `.apl` source files in `tests/programs/`.
|
||||
- [x] **`:quad-name` AST + handler** — extend tokenizer/parser to recognise
|
||||
`⎕name`, then handle in `apl-eval-ast` by dispatching to `apl-quad-*`
|
||||
runtime fns (`⎕IO`, `⎕ML`, `⎕FR`, `⎕TS`, `⎕FMT`, `⎕←`).
|
||||
_(`⎕←` deferred — tokenizer treats `←` as `:assign` after `⎕`.)_
|
||||
- [x] **Bracket indexing verification** — load programs that use `A[I]` /
|
||||
`A[I;J]` end-to-end; confirm parser desugars to `⌷` and runtime returns
|
||||
expected slices. Add 5+ tests.
|
||||
_(Single-axis only — multi-axis `A[I;J]` requires semicolon parsing, deferred.)_
|
||||
- [x] **Idiom corpus expansion** — extend `idioms.sx` from 34 to 60+ once
|
||||
end-to-end works (we can express idioms as APL strings, not as runtime
|
||||
calls). Source-string-based idioms validate the whole stack.
|
||||
- [x] **`:Trap` / `:EndTrap`** — minimal exception machinery: `:Trap n`
|
||||
catches errors with code `n`, body runs in `apl-tradfn-eval-block`,
|
||||
on error switches to the trap branch. Define `apl-throw` and a small
|
||||
set of error codes; use `try`/`catch` from the host.
|
||||
- [ ] Classic programs in `lib/apl/tests/programs/`:
|
||||
- [ ] `life.apl` — Conway's Game of Life as a one-liner using `⊂` `⊖` `⌽` `+/`
|
||||
- [ ] `mandelbrot.apl` — complex iteration with rank-polymorphic `+ × ⌊` (or real-axis subset)
|
||||
- [ ] `primes.apl` — `(2=+⌿0=A∘.|A)/A←⍳N` sieve
|
||||
- [ ] `n-queens.apl` — backtracking via reduce
|
||||
- [ ] `quicksort.apl` — the classic Roger Hui one-liner
|
||||
- [ ] System functions: `⎕FMT`, `⎕FR` (float repr), `⎕TS` (timestamp), `⎕IO`, `⎕ML` (migration level — fixed at 1), `⎕←` (print)
|
||||
- [ ] Drive corpus to 100+ green
|
||||
- [ ] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms
|
||||
|
||||
## SX primitive baseline
|
||||
|
||||
@@ -149,46 +118,7 @@ data; format for string templating.
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-05-07: Phase 7 step 6 — :Trap exception machinery via R7RS guard; apl-throw raises tagged error, apl-trap-matches? checks codes (0=catch-all), :trap clause in apl-tradfn-eval-stmt wraps try-block with guard; :throw AST for testing; **Phase 7 complete, all unchecked plan items done**; +5 tests; 450/450
|
||||
- 2026-05-07: Phase 7 step 5 — idiom corpus 34→64 (+30 source-string idioms via apl-run); also fixed tokenizer + parser to recognize ≢ and ≡ glyphs (were silently skipped); 445/445
|
||||
- 2026-05-07: Phase 7 step 4 — bracket indexing `A[I]` desugared to `(:dyad ⌷ I A)` via maybe-bracket helper, wired into :name + :lparen branches of collect-segments-loop; multi-axis (A[I;J]) deferred (semicolon split); +7 tests; 415/415
|
||||
- 2026-05-07: Phase 7 step 3 — :quad-name end-to-end; tokenizer already produced :name "⎕FMT"; parser is-fn-tok? extended via apl-quad-fn-names; eval-ast :name dispatches ⎕IO/⎕ML/⎕FR/⎕TS to apl-quad-*; apl-monadic-fn handles ⎕FMT; ⎕← deferred (tokenizer splits ⎕←); +8 tests; 408/408
|
||||
- 2026-05-07: Phase 7 step 2 — end-to-end pipeline `apl-run : string → array` (parse-apl + apl-eval-ast against empty env); +25 source-string tests covering scalars, strands, dyadic arith, monadic primitives, operators, ∘./.g products, comparisons, famous one-liners (+/⍳10=55, ×/⍳10=10!); tokenizer can't yet parse decimals so `3.7` literal tests dropped; **400/400**
|
||||
- 2026-05-07: Phase 7 step 1 — operators in apl-eval-ast via apl-resolve-monadic/dyadic; supports / ⌿ \ ⍀ ¨ ⍨ ∘. f.g; queens(8) test removed (too slow for 300s timeout); +14 eval-ops tests; 375/375
|
||||
- 2026-05-07: Phase 7 added — end-to-end pipeline, operators in eval-ast, :quad-name, bracket-indexing verify, idiom expansion, :Trap; aim is to wire parser↔runtime so .apl source files actually run
|
||||
- 2026-05-07: Phase 6 idiom corpus — lib/apl/tests/idioms.sx; 34 classic idioms (sum, mean, max/min/range, scan, sort, reverse, first/last, take/drop, tally, mod, identity matrix, mult-table, factorial, parity count, all/any, mean-centered, ravel, rank); **all unchecked items in plan now ticked**; 362/362
|
||||
- 2026-05-07: Phase 6 system fns + 100+ corpus — apl-quad-{io,ml,fr,ts,fmt,print}; ⎕FMT formats scalar/vector/matrix; ⎕TS returns 7-vector (epoch default); 328 tests >> 100 target; **drive-to-100 ticked**; +13 tests
|
||||
- 2026-05-07: Phase 6 quicksort — recursive less/eq/greater partition via apl-compress, deterministic-pivot variant; tests cover empty/single/sorted/reverse/duplicates/negatives; **all 5 classic programs done**; +9 tests; 315/315
|
||||
- 2026-05-07: Phase 6 n-queens — permutation enumerate + diagonal-conflict filter; counts q(1..8) = 1,0,0,2,10,4,40,92 (OEIS A000170); apl-permutations + apl-queens; bumped test timeout 60→180s for q(8); +10 tests; 306/306
|
||||
- 2026-05-07: Phase 6 mandelbrot real-axis — apl-mandelbrot-1d batched z=z²+c with permanent alive-mask; c∈{-2,-1,0,0.25} bounded, c=1→3, c=0.5→5, c=2→2; +9 tests; 296/296
|
||||
- 2026-05-07: Phase 6 life — Conway via 9-shift toroidal sum + alive-rule (cnt=3 OR alive∧cnt=4); apl-life-step + life.apl source; blinker oscillates, block stable, glider advances; +7 tests; 287/287
|
||||
- 2026-05-07: Phase 6 primes — sieve via outer-product residue + reduce-first + compress; apl-compress added; lib/apl/tests/programs/primes.apl source; +11 tests; 280/280
|
||||
- 2026-05-07: Phase 5 conformance.sh + scoreboard.{json,md} — per-suite runner; current snapshot 269/269; **Phase 5 complete**
|
||||
- 2026-05-07: Phase 5 valence dispatch — apl-dfn-valence (AST scan for ⍺/⍵), apl-tradfn-valence (slot check), apl-call unified entry; +14 tests; 269/269 tests
|
||||
- 2026-05-07: Phase 5 control words — :If/:Else, :While, :For/:In, :Select/:Case via apl-tradfn-eval-block/stmt threading env; :Trap deferred; +10 tests (sum loop, factorial, dispatch, nested); 255/255 tests
|
||||
- 2026-05-07: Phase 5 tradfn — apl-call-tradfn + apl-tradfn-loop; line-numbered stmts, :branch goto, →0 exits, locals; +10 tests including loop sum; 245/245 tests
|
||||
- 2026-05-07: Phase 5 dfn complete — apl-eval-stmts (guards, locals, ⍺←default), ∇ recursion via env "nabla"; +9 tests (factorial, guards, defaults, locals); 235/235 tests
|
||||
- 2026-05-07: Phase 5 dfn foundation — lib/apl/transpile.sx with apl-eval-ast (handles :num :vec :name :monad :dyad :program :dfn) + glyph→fn lookup tables; apl-call-dfn / apl-call-dfn-m bind ⍺/⍵; ∇/guards/defaults/locals pending; 226/226 tests
|
||||
- 2026-05-07: Phase 4 step 10 — at @ (apl-at-replace + apl-at-apply); linear-index lookup, scalar-vals broadcast; 211/211 tests
|
||||
- 2026-05-07: Phase 4 step 9 — rank f⍤k (apl-rank); cell decomposition + reassembly via frame/cell shapes; 201/201 tests
|
||||
- 2026-05-06: Phase 4 step 8 — power f⍣n (apl-power) + fixed-point f⍣≡ (apl-power-fixed); 191/191 tests
|
||||
- 2026-05-06: Phase 4 step 7 — compose f∘g (apl-compose monadic f∘g x, apl-compose-dyadic dyadic f x (g y)); 182/182 tests
|
||||
- 2026-05-06: Phase 4 step 6 — commute f⍨ (apl-commute monadic dup, apl-commute-dyadic swap); 173/173 tests
|
||||
- 2026-05-06: Phase 4 step 5 — inner product f.g (apl-inner); +.× matrix multiply, ∧.= equal-vectors; 163/163 tests
|
||||
- 2026-05-06: Phase 4 step 4 — outer product ∘.f (apl-outer); rank-doubling result shape = a-shape++b-shape; 151/151 tests
|
||||
- 2026-05-06: Phase 4 step 3 — each f¨ (monadic apl-each + dyadic apl-each-dyadic); scalar broadcast both sides; 139/139 tests
|
||||
- 2026-05-06: Phase 4 step 2 — scan f\ (last axis) + f⍀ (first axis); apl-scan/apl-scan-first; 125/125 tests
|
||||
- 2026-05-06: Phase 4 step 1 — reduce f/ (last axis) + f⌿ (first axis); apl-reduce/apl-reduce-first; 110/110 tests
|
||||
- 2026-05-06: Phase 3 complete — membership ∊, dyadic ⍳ (index-of), without ~ (index-of returns nil for not-found); 94/94 tests
|
||||
- 2026-05-06: Phase 3 step 6 — enclose ⊂ / disclose ⊃ (box/unbox, rank-0 detect via type-of); 82/82 tests
|
||||
- 2026-05-06: Phase 3 step 5 — grade-up ⍋ / grade-down ⍒ (stable insertion sort); 74/74 tests
|
||||
- 2026-05-06: Phase 3 step 4 — squad ⌷ (scalar/multi-dim/partial-slice); 66/66 tests
|
||||
- 2026-05-06: Phase 3 step 3 — catenate , (last axis, scalar promo) and first-axis; 59/59 tests
|
||||
- 2026-05-06: Phase 3 step 2 — take ↑ (multi-axis, pad), drop ↓, reverse/rotate ⌽⊖ (last+first axis); 50/50 tests
|
||||
- 2026-05-06: Phase 3 step 1 — reshape ⍴ (cycling), transpose ⍉ (monadic+dyadic); helpers apl-strides/flat->multi/multi->flat; 27/27 structural tests; lib/apl/tests/structural.sx
|
||||
- 2026-04-26: Phase 2 complete — array model + 7 scalar primitive groups; 82/82 tests; lib/apl/runtime.sx + lib/apl/tests/scalar.sx
|
||||
- 2026-04-26: parser (Phase 1 step 2) — 44/44 parser tests green (90/90 total); right-to-left segment algorithm; derived fns, outer/inner product, dfns with guards, strand handling; `lib/apl/parser.sx` + `lib/apl/tests/parse.sx`
|
||||
- 2026-04-25: tokenizer (Phase 1 step 1) — 46/46 tests green; Unicode-aware starts-with? scanner for multi-byte APL glyphs; `lib/apl/tokenizer.sx` + `lib/apl/tests/parse.sx`
|
||||
- _(none yet)_
|
||||
|
||||
## Blockers
|
||||
|
||||
|
||||
@@ -1,178 +0,0 @@
|
||||
# lib/guest — shared toolkit for SX-hosted languages
|
||||
|
||||
Extract the duplicated plumbing across `lib/{haskell,common-lisp,erlang,prolog,js,lua,smalltalk,tcl,forth,ruby,apl,hyperscript}` into a small, composable kit so language N+1 costs ~200 lines instead of ~2000, without regressing any existing conformance scoreboard.
|
||||
|
||||
Branch: `architecture`. SX files via `sx-tree` MCP only. Never edit generated files.
|
||||
|
||||
## Thesis
|
||||
|
||||
The substrate (CEK, hygienic macros, records, delimited continuations, IO suspension, reactivity) was chosen with multi-paradigm hosting in mind, but each guest currently re-rolls its own tokeniser, recursive-descent loop, conformance harness, and primitive-rename layer. Extracting these shared layers does not reduce conformance bug-finding pressure — it only removes plumbing — so it is pure win.
|
||||
|
||||
**Canaries:** Lua (small, conventional expression-grammar — exercises lex/Pratt/AST) and Prolog (paradigm-different — exercises pattern-match/unification). The two-canary rule prevents Lua-shaped abstractions.
|
||||
|
||||
**Two-language rule:** no extraction is merged until **two** guests consume it.
|
||||
|
||||
## Current baseline
|
||||
|
||||
The loop fills these in on its first iteration by running every `*/conformance.sh` and `*/test.sh` and copying each `scoreboard.json` to `lib/guest/baseline/<lang>.json`. Until then:
|
||||
|
||||
| Guest | Suite | Baseline |
|
||||
|--------------|--------------------|----------|
|
||||
| lua | `bash lib/lua/test.sh` | 185 / 185 |
|
||||
| prolog | `bash lib/prolog/conformance.sh` | 590 / 590 |
|
||||
| haskell | `bash lib/haskell/conformance.sh` | 156 / 156 (was reported 0/18 by the buggy old script) |
|
||||
| common-lisp | `bash lib/common-lisp/conformance.sh` | 518 / 518 (Phase 2 +182 and Phase 6 +27 were previously under-counted) |
|
||||
| erlang | `bash lib/erlang/conformance.sh` | 0 / 0 (suite all-zero) |
|
||||
| js | `bash lib/js/conformance.sh` | 94 / 148 (test262-slice) |
|
||||
| smalltalk | `bash lib/smalltalk/conformance.sh` | 625 / 629 |
|
||||
| tcl | `bash lib/tcl/conformance.sh` | 3 / 4 (programs) |
|
||||
| forth | `bash lib/forth/test.sh` | 64 / 64 |
|
||||
| ruby | `bash lib/ruby/test.sh` | 76 / 76 |
|
||||
| apl | `bash lib/apl/test.sh` | 73 / 73 |
|
||||
|
||||
The baseline only needs to be re-snapshotted when the substrate (`spec/**`, `hosts/**`) changes underneath this loop.
|
||||
|
||||
---
|
||||
|
||||
## Phase 0 — Baseline snapshot (one-shot)
|
||||
|
||||
### Step 0: Snapshot every guest's scoreboard
|
||||
|
||||
Create `lib/guest/baseline/`. Run every guest's conformance/test runner. Copy each `scoreboard.json` (or extract pass/fail counts from `test.sh` output for guests without a scoreboard) into `lib/guest/baseline/<lang>.json`. Fill in the table above.
|
||||
|
||||
**Verify:** `ls lib/guest/baseline/*.json` shows one per guest. Plan table populated.
|
||||
|
||||
---
|
||||
|
||||
## Phase 1 — Cheap, zero-semantic-risk extractions
|
||||
|
||||
### Step 1: `lib/guest/conformance.sx` — config-driven test runner
|
||||
|
||||
Replace the 6+ near-identical `*/conformance.sh` scripts with one driver that takes a config dict:
|
||||
|
||||
```
|
||||
{:lang "prolog"
|
||||
:loads ("lib/prolog/tokenizer.sx" "lib/prolog/parser.sx" ...)
|
||||
:suites (("parse" "lib/prolog/tests/parse.sx" "pl-parse-tests-run!") ...)}
|
||||
```
|
||||
|
||||
The driver locates `sx_server.exe`, runs the epoch protocol, collects pass/fail per suite, and writes `scoreboard.{json,md}`. The per-language `conformance.sh` becomes a 3-line stub that points at its config.
|
||||
|
||||
**Port to:** `lib/prolog/conformance.sh` and `lib/haskell/conformance.sh`. Two consumers required for merge.
|
||||
|
||||
**Verify:** both `bash lib/prolog/conformance.sh` and `bash lib/haskell/conformance.sh` produce scoreboard JSONs equal to baseline.
|
||||
|
||||
### Step 2: `lib/guest/prefix.sx` — prefix-rename macro
|
||||
|
||||
One macro that takes a prefix and a list of SX symbols and binds prefixed aliases:
|
||||
|
||||
```
|
||||
(prefix-rename "cl-" '(null? pair? even? odd? zero? ...))
|
||||
```
|
||||
|
||||
Replaces hundreds of hand-written `(define (cl-null? x) (= x nil))`-style wrappers in `common-lisp/runtime.sx`, `lua/runtime.sx`, `erlang/runtime.sx`.
|
||||
|
||||
**Port to:** `common-lisp/runtime.sx` (largest user) and `lua/runtime.sx`. Two consumers.
|
||||
|
||||
**Verify:** common-lisp + lua scoreboards equal baseline.
|
||||
|
||||
---
|
||||
|
||||
## Phase 2 — Lex / parse kit
|
||||
|
||||
### Step 3: `lib/guest/lex.sx` — character-class + tokeniser primitives
|
||||
|
||||
- Source-position tracking (line/col/offset).
|
||||
- Character-class predicates (`whitespace?`, `digit?`, `alpha?`, `ident-start?`, `ident-rest?`).
|
||||
- Number recognisers (decimal, hex, float, scientific).
|
||||
- String recognisers (quoted, escapes, raw).
|
||||
- Comment recognisers (line, block, nestable).
|
||||
- Token record `{:type :value :pos :end :line}`.
|
||||
|
||||
**Port to:** `lua/tokenizer.sx` and `tcl/tokenizer.sx`. Two consumers.
|
||||
|
||||
**Verify:** lua + tcl scoreboards equal baseline.
|
||||
|
||||
### Step 4: `lib/guest/pratt.sx` — Pratt / operator-precedence parser
|
||||
|
||||
Prefix / infix / postfix tables, left/right associativity, precedence climbing. Grammar is a dict, not hardcoded `cond`.
|
||||
|
||||
**Port to:** Lua expression parser (`lua/parser.sx`) and Prolog operator table (`prolog/parser.sx` — Prolog ops are the stress test). Two consumers.
|
||||
|
||||
**Verify:** lua + prolog scoreboards equal baseline.
|
||||
|
||||
### Step 5: `lib/guest/ast.sx` — canonical AST node shapes
|
||||
|
||||
Standard constructors and predicates for: `literal`, `var`, `app`, `lambda`, `let`, `letrec`, `if`, `match-clause`, `module`, `import`. Optional — guests may keep their own AST — but using the canonical shape lets cross-language tooling (formatters, highlighters, debuggers) work without per-language adapters.
|
||||
|
||||
**Port to:** lua + prolog AST emitters. Two consumers.
|
||||
|
||||
**Verify:** lua + prolog scoreboards equal baseline.
|
||||
|
||||
---
|
||||
|
||||
## Phase 3 — Semantic extractions (highest leverage, highest risk)
|
||||
|
||||
### Step 6: `lib/guest/match.sx` — pattern-match + unification engine
|
||||
|
||||
Single engine for:
|
||||
- Literal patterns (numbers, strings, symbols, nil, booleans).
|
||||
- Wildcard `_`.
|
||||
- Constructor patterns (ADT-shaped — depends on Phase 3 of `sx-improvements.md` if available, otherwise dict-tagged).
|
||||
- Variable binding.
|
||||
- **Unification** (Prolog flavour): symmetric, occurs-check toggle, substitution returned.
|
||||
- **Match** (Haskell flavour): asymmetric pattern→value, bindings returned.
|
||||
|
||||
**Port to:** `haskell/match.sx` and `prolog/query.sx` unification core. Two consumers.
|
||||
|
||||
**Verify:** haskell + prolog scoreboards equal baseline. **Highest-risk extraction** — if either regresses by 1 test, revert and redesign.
|
||||
|
||||
### Step 7: `lib/guest/layout.sx` — significant-whitespace / off-side rule
|
||||
|
||||
Generalised layout-sensitive lexer. Configurable: which keywords open layout blocks, whether semicolons are inserted, brace insertion rules.
|
||||
|
||||
**Port to:** `haskell/layout.sx` (existing). Second consumer: write a synthetic test fixture that exercises a Python-ish layout to prove the kit is not Haskell-shaped. Two consumers.
|
||||
|
||||
**Verify:** haskell scoreboard equal baseline; synthetic layout fixture passes.
|
||||
|
||||
### Step 8: `lib/guest/hm.sx` — Hindley-Milner type inference
|
||||
|
||||
Extract from `haskell/infer.sx`. Algorithm W or J, generalisation, instantiation, occurs-check, principal types.
|
||||
|
||||
**Sequencing:** this step is **paired with `plans/ocaml-on-sx.md` Phase 5**. The natural order is lib-guest Steps 0–7 → OCaml-on-SX Phases 1–5 → lib-guest Step 8. With OCaml-on-SX Phase 5 done, the two-language rule is satisfied for real (Haskell + OCaml). Without it, accept "second user TBD" — the alternative is letting the inference stay locked inside Haskell forever.
|
||||
|
||||
**Port to:** `haskell/infer.sx` and (preferred) `lib/ocaml/types.sx`.
|
||||
|
||||
**Verify:** haskell scoreboard equal baseline; if OCaml-on-SX Phase 5 has shipped, OCaml type-inference tests equal baseline too.
|
||||
|
||||
---
|
||||
|
||||
## Progress log
|
||||
|
||||
| Step | Status | Commit | Delta |
|
||||
|------|--------|--------|-------|
|
||||
| 0 — baseline snapshot | [done] | 2f7f8189 | 11 guests captured: lua 185/185, forth 64/64, ruby 76/76, apl 73/73, prolog 590/590, common-lisp 309/309, smalltalk 625/629, tcl 3/4, haskell 0/18 programs, js 94/148 (slice), erlang 0/0 |
|
||||
| 1 — conformance.sx (prolog + haskell) | [done] | 58dcff26 | Prolog 590/590 (matches baseline). Haskell 156/156 — old script was broken (0/18 was an artefact of a never-matching grep), driver reveals true counts; baseline updated. |
|
||||
| 2 — prefix.sx (common-lisp + lua) | [partial — pending lua] | 2ef773a3 | common-lisp/runtime.sx ported (47 aliases collapsed into 13 prefix-rename calls); 518/518 vs 309/309 baseline (improvement, no regression). lua/runtime.sx has no pure same-name aliases — every lua- definition wraps custom logic; second consumer pending. |
|
||||
| 3 — lex.sx (lua + tcl) | [done] | 559b0df9 | lex.sx exports nil-safe char-class predicates + token record. lua/tokenizer.sx (7 preds) and tcl/tokenizer.sx (5 preds) collapsed into prefix-rename calls. lua 185/185, tcl 342/342, tcl-conf 3/4 — all = baseline. |
|
||||
| 4 — pratt.sx (lua + prolog) | [done] | da27958d | Extracted operator-table format + lookup only — climbing loops stay per-language because lua and prolog use opposite prec conventions. lua/parser.sx: 18-clause cond → 15-entry table. prolog/parser.sx: pl-op-find deleted, pl-op-lookup wraps pratt-op-lookup. lua 185/185, prolog 590/590 — both = baseline. |
|
||||
| 5 — ast.sx (lua + prolog) | [partial — pending real consumers] | a774cd26 | Kit + 33 self-tests shipped (10 canonical kinds, predicates, accessors). Step is "Optional" per brief; lua/prolog parsers untouched (185/185 + 590/590). Datalog-on-sx will be the natural first real consumer; lua/prolog converters can land later. |
|
||||
| 6 — match.sx (haskell + prolog) | [in-progress] | — | — |
|
||||
| 7 — layout.sx (haskell + synthetic) | [ ] | — | — |
|
||||
| 8 — hm.sx (haskell + TBD) | [ ] | — | — |
|
||||
|
||||
---
|
||||
|
||||
## Rules
|
||||
|
||||
- **Branch:** `architecture`. Commit locally. **Never push.** **Never touch `main`.**
|
||||
- **Scope:** ONLY `lib/guest/**`, `lib/{lua,prolog,haskell,common-lisp,tcl}/**` (canaries + extraction targets), `plans/lib-guest.md`, `plans/agent-briefings/lib-guest-loop.md`. No `spec/`, `hosts/`, `web/`, `shared/`.
|
||||
- **SX files:** `sx-tree` MCP tools only. `sx_validate` after every edit.
|
||||
- **No raw dune.** Use `sx_build target="ocaml"` MCP tool.
|
||||
- **Two-language rule:** never merge an extraction until two guests consume it (Step 8 excepted with explicit note).
|
||||
- **Conformance baseline is the bar.** Any port whose scoreboard regresses by ≥1 test → revert, mark blocked, move on.
|
||||
- **Substrate change → re-snapshot.** If `spec/` or `hosts/` changes underneath this loop, re-run Step 0 before continuing.
|
||||
- **One step per code commit.** Plan updates as a separate commit. Short message with delta.
|
||||
- **No alias chains** to paper over drift between extraction and consumer (`feedback_no_alias_bloat`).
|
||||
- **Partial extraction is OK** if the canary works and a pending consumer is identified — mark `[partial — pending <consumer>]`.
|
||||
- **Hard timeout:** if stuck >45 min on a step, mark `blocked (<reason>)` and move on.
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user