GUEST-plan: claim step 6 — match.sx

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>

hosts/javascript/platform.py

@@ -1129,6 +1129,7 @@ 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;
 ''',
 
@@ -1475,6 +1476,22 @@ 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": '''
@@ -1933,12 +1950,30 @@ 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); }
@@ -2105,6 +2140,13 @@ 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;
@@ -2126,7 +2168,16 @@ PLATFORM_JS_PRE = '''
   }
 
   function error(msg) { throw new Error(msg); }
-  function inspect(x) { return JSON.stringify(x); }
+  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 debugLog() { console.error.apply(console, ["[sx-debug]"].concat(Array.prototype.slice.call(arguments))); }
 
 '''
@@ -2450,6 +2501,7 @@ 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;
@@ -2771,8 +2823,8 @@ PLATFORM_DOM_JS = """
     // If lambda takes 0 params, call without event arg (convenience for on-click handlers)
     var wrapped = isLambda(handler)
       ? (lambdaParams(handler).length === 0
-        ? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
-        : function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
+        ? function(e) { try { var r = cekCall(handler, NIL); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
+        : function(e) { try { var r = cekCall(handler, [e]); if (globalThis._driveAsync) globalThis._driveAsync(r); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
       : handler;
     if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler));
     var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 };
@@ -3981,6 +4033,11 @@ 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(), [], []));
@@ -4103,7 +4160,56 @@ 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;''']
+  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;''']
     if has_deps:
         lines.append('''
   // Platform deps functions (native JS, not transpiled — need explicit registration)

hosts/ocaml/bin/bench_cek.ml

@@ -0,0 +1,73 @@
+(** 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%!"

hosts/ocaml/bin/bench_inspect.ml

@@ -0,0 +1,46 @@
+(* 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

hosts/ocaml/bin/bench_vm.ml

@@ -0,0 +1,155 @@
+(** 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%!"

hosts/ocaml/bin/dune

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

hosts/ocaml/bin/mcp_tree.ml

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

hosts/ocaml/bin/run_tests.ml

@@ -2899,6 +2899,9 @@ 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 *)

hosts/ocaml/bin/sx_server.ml

@@ -703,6 +703,11 @@ let setup_evaluator_bridge env =
     | [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
     | [expr] -> Sx_ref.eval_expr expr (Env env)
     | _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
+  (* eval-in-env: (env expr) → result.  Evaluates expr in the given env. *)
+  Sx_primitives.register "eval-in-env" (fun args ->
+    match args with
+    | [e; expr] -> Sx_ref.eval_expr expr e
+    | _ -> raise (Eval_error "eval-in-env: (env expr)"));
   bind "trampoline" (fun args ->
     match args with
     | [v] ->
@@ -764,7 +769,13 @@ let setup_evaluator_bridge env =
     | _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
   ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
   ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args ->
-    List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))))
+    List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))));
+  (* current-env: special form — returns current lexical env as a first-class value *)
+  ignore (Sx_ref.register_special_form (String "current-env")
+    (NativeFn ("current-env", fun args ->
+      match args with
+      | [_arg_list; env_val] -> env_val
+      | _ -> Nil)))
 
 (* ---- Type predicates and introspection ---- *)
 let setup_introspection env =
@@ -950,7 +961,24 @@ let setup_env_operations env =
   bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string"));
   bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value"));
   bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value"));
-  bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env"));
+  bind "env-extend" (fun args ->
+    match args with
+    | e :: pairs ->
+      let child = Sx_types.env_extend (uw e) in
+      let rec go = function
+        | [] -> ()
+        | k :: v :: rest ->
+          ignore (Sx_types.env_bind child (Sx_runtime.value_to_str k) v); go rest
+        | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
+      go pairs; Env child
+    | _ -> raise (Eval_error "env-extend: expected env"));
+  bind "env-lookup" (fun args ->
+    match args with
+    | [e; key] ->
+      let k = Sx_runtime.value_to_str key in
+      let raw = uw e in
+      if Sx_types.env_has raw k then Sx_types.env_get raw k else Nil
+    | _ -> raise (Eval_error "env-lookup: (env key)"));
   bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs"))
 
 (* ---- Strict mode (gradual type system support) ---- *)

hosts/ocaml/bootstrap.py

@@ -82,7 +82,10 @@ let cek_run_iterative state =
       s := cek_step !s
     done;
     (match cek_suspended_p !s with
-     | Bool true -> raise (Eval_error "IO suspension in non-IO context")
+     | Bool true ->
+       (match !_cek_io_suspend_hook with
+        | Some hook -> hook !s
+        | None -> raise (Eval_error "IO suspension in non-IO context"))
      | _ -> cek_value !s)
   with Eval_error msg ->
     _last_error_kont_ref := cek_kont !s;
@@ -308,6 +311,23 @@ 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
 
 

hosts/ocaml/bootstrap_vm.py

@@ -355,7 +355,9 @@ 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 (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

hosts/ocaml/browser/bundle.sh

@@ -75,6 +75,9 @@ 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)

hosts/ocaml/browser/compile-modules.js

@@ -85,6 +85,7 @@ 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',
 ];
@@ -455,8 +456,10 @@ for (const file of FILES) {
         'hs-parser': ['hs-tokenizer'],
         'hs-compiler': ['hs-tokenizer', 'hs-parser'],
         'hs-runtime': ['hs-tokenizer', 'hs-parser', 'hs-compiler'],
-        'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
-        'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration'],
+        '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'],
       };
       manifest[key] = {
         file: sxbcFile,
@@ -477,7 +480,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-integration', 'hs-htmx'];
+  const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-worker', 'hs-prolog', 'hs-integration', 'hs-htmx'];
   for (const m of HS_LAZY) {
     if (manifest[m] && !lazyDeps.includes(m)) lazyDeps.push(m);
   }

hosts/ocaml/browser/sx_browser.ml

@@ -344,6 +344,12 @@ 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))
 
@@ -371,6 +377,8 @@ 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")
@@ -381,7 +389,10 @@ 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 Eval_error msg ->
+  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))
 
 let api_load src_js =
@@ -704,8 +715,10 @@ let () =
         | List (Symbol "code" :: rest) ->
           let d = Hashtbl.create 8 in
           let rec parse_kv = function
-            | 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 "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 "bytecode" :: List nums :: rest ->
               Hashtbl.replace d "bytecode" (List nums); parse_kv rest
             | Keyword "constants" :: List consts :: rest ->

hosts/ocaml/browser/test_letrec_resume.js

@@ -0,0 +1,172 @@
+#!/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);

hosts/ocaml/lib/dune

@@ -1,4 +1,4 @@
 (library
  (name sx)
  (wrapped false)
- (libraries re re.pcre))
+ (libraries re re.pcre unix))

hosts/ocaml/lib/sx_compiler.ml

@@ -200,7 +200,30 @@ 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 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))))))))))
+  (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))))))))))
 
 (* compile *)
 and compile expr =

hosts/ocaml/lib/sx_primitives.ml

@@ -666,7 +666,9 @@ 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 | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
+    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"));
   register "symbol?" (fun args ->
     match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
   register "keyword?" (fun args ->
@@ -1279,6 +1281,11 @@ 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] ->
@@ -1600,6 +1607,32 @@ 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 ->
@@ -3000,4 +3033,705 @@ let () =
       List.iteri (fun i c -> Bytes.set b i c) bytes_list;
       SxBytevector b
     | [Nil] -> SxBytevector (Bytes.create 0)
-    | _ -> raise (Eval_error "list->bytevector: expected list"))
+    | _ -> raise (Eval_error "list->bytevector: expected list"));
+
+  (* === File I/O === *)
+  register "file-read" (fun args ->
+    match args with
+    | [String path] ->
+      (try
+        let ic = open_in path in
+        let n = in_channel_length ic in
+        let s = Bytes.create n in
+        really_input ic s 0 n;
+        close_in ic;
+        String (Bytes.to_string s)
+      with Sys_error msg -> raise (Eval_error ("file-read: " ^ msg)))
+    | _ -> raise (Eval_error "file-read: (path)"));
+
+  register "file-write" (fun args ->
+    match args with
+    | [String path; String content] ->
+      (try
+        let oc = open_out path in
+        output_string oc content;
+        close_out oc;
+        Nil
+      with Sys_error msg -> raise (Eval_error ("file-write: " ^ msg)))
+    | _ -> raise (Eval_error "file-write: (path content)"));
+
+  register "file-append" (fun args ->
+    match args with
+    | [String path; String content] ->
+      (try
+        let oc = open_out_gen [Open_append; Open_creat; Open_wronly; Open_text] 0o644 path in
+        output_string oc content;
+        close_out oc;
+        Nil
+      with Sys_error msg -> raise (Eval_error ("file-append: " ^ msg)))
+    | _ -> raise (Eval_error "file-append: (path content)"));
+
+  register "file-exists?" (fun args ->
+    match args with
+    | [String path] -> Bool (Sys.file_exists path)
+    | _ -> raise (Eval_error "file-exists?: (path)"));
+
+  register "file-glob" (fun args ->
+    let glob_match pat str =
+      let pn = String.length pat and sn = String.length str in
+      let rec go pi si =
+        if pi = pn then si = sn
+        else match pat.[pi] with
+          | '*' ->
+            let rec try_from i = i <= sn && (go (pi+1) i || try_from (i+1)) in
+            try_from si
+          | '?' -> si < sn && go (pi+1) (si+1)
+          | '[' ->
+            let pi' = ref (pi+1) in
+            let negate = !pi' < pn && pat.[!pi'] = '^' in
+            if negate then incr pi';
+            let matched = ref false in
+            while !pi' < pn && pat.[!pi'] <> ']' do
+              let c1 = pat.[!pi'] in
+              incr pi';
+              if !pi' + 1 < pn && pat.[!pi'] = '-' then begin
+                let c2 = pat.[!pi' + 1] in
+                pi' := !pi' + 2;
+                if si < sn && str.[si] >= c1 && str.[si] <= c2 then matched := true
+              end else if si < sn && str.[si] = c1 then matched := true
+            done;
+            if !pi' < pn then incr pi';
+            ((!matched && not negate) || (not !matched && negate)) && go !pi' (si+1)
+          | c -> si < sn && str.[si] = c && go (pi+1) (si+1)
+      in go 0 0
+    in
+    let glob_paths pat =
+      let dir = Filename.dirname pat in
+      let base_pat = Filename.basename pat in
+      let dir' = if dir = "." && not (String.length pat > 1 && pat.[0] = '.') then "." else dir in
+      (try
+        let entries = Sys.readdir dir' in
+        Array.fold_left (fun acc entry ->
+          if glob_match base_pat entry then
+            let full = if dir' = "." then entry else Filename.concat dir' entry in
+            full :: acc
+          else acc
+        ) [] entries
+        |> List.sort String.compare
+      with Sys_error _ -> [])
+    in
+    match args with
+    | [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
+    | _ -> raise (Eval_error "file-glob: (pattern)"));
+
+  (* === File metadata + ops (Phase 5d) === *)
+  let stat_or = function
+    | String path -> (try Some (Unix.stat path) with _ -> None)
+    | _ -> raise (Eval_error "file: path must be a string")
+  in
+  register "file-size" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Integer s.Unix.st_size | None -> Integer 0)
+    | _ -> raise (Eval_error "file-size: (path)"));
+  register "file-mtime" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Integer (int_of_float s.Unix.st_mtime) | None -> Integer 0)
+    | _ -> raise (Eval_error "file-mtime: (path)"));
+  register "file-isfile?" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_REG) | None -> Bool false)
+    | _ -> raise (Eval_error "file-isfile?: (path)"));
+  register "file-isdir?" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_DIR) | None -> Bool false)
+    | _ -> raise (Eval_error "file-isdir?: (path)"));
+  register "file-readable?" (fun args ->
+    match args with
+    | [String path] ->
+      Bool (try Unix.access path [Unix.R_OK]; true with _ -> false)
+    | _ -> raise (Eval_error "file-readable?: (path)"));
+  register "file-writable?" (fun args ->
+    match args with
+    | [String path] ->
+      Bool (try Unix.access path [Unix.W_OK]; true with _ -> false)
+    | _ -> raise (Eval_error "file-writable?: (path)"));
+  register "file-stat" (fun args ->
+    match args with
+    | [v] ->
+      (match stat_or v with
+       | None -> Nil
+       | Some s ->
+         let d = Hashtbl.create 6 in
+         Hashtbl.replace d "size" (Integer s.Unix.st_size);
+         Hashtbl.replace d "mtime" (Integer (int_of_float s.Unix.st_mtime));
+         Hashtbl.replace d "atime" (Integer (int_of_float s.Unix.st_atime));
+         Hashtbl.replace d "ctime" (Integer (int_of_float s.Unix.st_ctime));
+         Hashtbl.replace d "mode" (Integer s.Unix.st_perm);
+         Hashtbl.replace d "type" (String (match s.Unix.st_kind with
+           | Unix.S_REG -> "file" | Unix.S_DIR -> "directory"
+           | Unix.S_LNK -> "link" | Unix.S_CHR -> "characterSpecial"
+           | Unix.S_BLK -> "blockSpecial" | Unix.S_FIFO -> "fifo"
+           | Unix.S_SOCK -> "socket"));
+         Dict d)
+    | _ -> raise (Eval_error "file-stat: (path)"));
+  register "file-delete" (fun args ->
+    match args with
+    | [String path] ->
+      (try
+        if Sys.is_directory path then Unix.rmdir path
+        else Unix.unlink path
+      with
+      | Unix.Unix_error (Unix.ENOENT, _, _) -> ()  (* tolerate missing *)
+      | Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-delete: " ^ Unix.error_message e)));
+      Nil
+    | _ -> raise (Eval_error "file-delete: (path)"));
+  register "file-mkdir" (fun args ->
+    match args with
+    | [String path] ->
+      let rec mk p =
+        if p = "" || p = "." || p = "/" then ()
+        else if Sys.file_exists p then ()
+        else begin
+          mk (Filename.dirname p);
+          (try Unix.mkdir p 0o755
+           with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
+        end
+      in
+      (try mk path
+       with Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-mkdir: " ^ Unix.error_message e)));
+      Nil
+    | _ -> raise (Eval_error "file-mkdir: (path)"));
+  register "file-copy" (fun args ->
+    match args with
+    | [String src; String dst] ->
+      (try
+        let ic = open_in_bin src in
+        let oc = open_out_bin dst in
+        let buf = Bytes.create 8192 in
+        let rec loop () =
+          let n = input ic buf 0 (Bytes.length buf) in
+          if n > 0 then (output oc buf 0 n; loop ())
+        in
+        loop ();
+        close_in ic;
+        close_out oc;
+        Nil
+      with
+      | Sys_error msg -> raise (Eval_error ("file-copy: " ^ msg)))
+    | _ -> raise (Eval_error "file-copy: (src dst)"));
+  register "file-rename" (fun args ->
+    match args with
+    | [String src; String dst] ->
+      (try Sys.rename src dst with Sys_error msg -> raise (Eval_error ("file-rename: " ^ msg)));
+      Nil
+    | _ -> raise (Eval_error "file-rename: (src dst)"));
+
+  (* === Channels (random-access + blocking control) === *)
+  let channel_table : (string, Unix.file_descr * string * bool ref * bool ref) Hashtbl.t = Hashtbl.create 16 in
+  let channel_next_id = ref 0 in
+  let parse_open_mode mode =
+    match mode with
+    | "r"  -> [Unix.O_RDONLY]
+    | "w"  -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC]
+    | "a"  -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND]
+    | "r+" -> [Unix.O_RDWR]
+    | "w+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC]
+    | "a+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_APPEND]
+    | _ -> raise (Eval_error ("channel-open: invalid mode " ^ mode))
+  in
+  let chan_get name =
+    match Hashtbl.find_opt channel_table name with
+    | Some c -> c
+    | None -> raise (Eval_error ("channel: no such channel " ^ name))
+  in
+  register "channel-open" (fun args ->
+    match args with
+    | [String path; String mode] ->
+      (try
+        let fd = Unix.openfile path (parse_open_mode mode) 0o644 in
+        let id = !channel_next_id in
+        incr channel_next_id;
+        let name = Printf.sprintf "file%d" id in
+        Hashtbl.replace channel_table name (fd, mode, ref false, ref true);
+        String name
+      with Unix.Unix_error (e, _, _) -> raise (Eval_error ("channel-open: " ^ Unix.error_message e)))
+    | _ -> raise (Eval_error "channel-open: (path mode)"));
+
+  register "channel-close" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, _, _) = chan_get name in
+      (try Unix.close fd with _ -> ());
+      Hashtbl.remove channel_table name;
+      Nil
+    | _ -> raise (Eval_error "channel-close: (channel)"));
+
+  register "channel-read" (fun args ->
+    let (name, max_n) = match args with
+      | [String n] -> (n, -1)
+      | [String n; Integer m] -> (n, m)
+      | [String n; Number m] -> (n, int_of_float m)
+      | _ -> raise (Eval_error "channel-read: (channel ?n?)")
+    in
+    let (fd, _, eof, _) = chan_get name in
+    let chunk = 8192 in
+    let buf = Bytes.create chunk in
+    let buffer = Buffer.create chunk in
+    let total = ref 0 in
+    let stop = ref false in
+    while not !stop do
+      let want = if max_n < 0 then chunk else min chunk (max_n - !total) in
+      if want <= 0 then stop := true
+      else begin
+        try
+          let r = Unix.read fd buf 0 want in
+          if r = 0 then begin eof := true; stop := true end
+          else begin
+            Buffer.add_subbytes buffer buf 0 r;
+            total := !total + r
+          end
+        with
+        | Unix.Unix_error (Unix.EAGAIN, _, _)
+        | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
+      end
+    done;
+    String (Buffer.contents buffer));
+
+  register "channel-read-line" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, eof, _) = chan_get name in
+      let buf = Buffer.create 80 in
+      let one = Bytes.create 1 in
+      let got_data = ref false in
+      let stop = ref false in
+      while not !stop do
+        try
+          let r = Unix.read fd one 0 1 in
+          if r = 0 then begin eof := true; stop := true end
+          else begin
+            got_data := true;
+            let c = Bytes.get one 0 in
+            if c = '\n' then stop := true
+            else Buffer.add_char buf c
+          end
+        with
+        | Unix.Unix_error (Unix.EAGAIN, _, _)
+        | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
+      done;
+      if !got_data then String (Buffer.contents buf) else Nil
+    | _ -> raise (Eval_error "channel-read-line: (channel)"));
+
+  register "channel-write" (fun args ->
+    match args with
+    | [String name; String s] ->
+      let (fd, _, _, _) = chan_get name in
+      let b = Bytes.of_string s in
+      let n = Bytes.length b in
+      let written = ref 0 in
+      while !written < n do
+        (try
+          let w = Unix.write fd b !written (n - !written) in
+          written := !written + w
+        with
+        | Unix.Unix_error (Unix.EAGAIN, _, _)
+        | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) ->
+          (* short write — let caller retry *)
+          written := n)
+      done;
+      Nil
+    | _ -> raise (Eval_error "channel-write: (channel string)"));
+
+  register "channel-flush" (fun args ->
+    match args with
+    | [String name] -> let _ = chan_get name in Nil  (* no userspace buffer *)
+    | _ -> raise (Eval_error "channel-flush: (channel)"));
+
+  register "channel-seek" (fun args ->
+    let (name, offset, whence) = match args with
+      | [String n; Integer o] -> (n, o, "start")
+      | [String n; Number o] -> (n, int_of_float o, "start")
+      | [String n; Integer o; String w] -> (n, o, w)
+      | [String n; Number o; String w] -> (n, int_of_float o, w)
+      | _ -> raise (Eval_error "channel-seek: (channel offset ?whence?)")
+    in
+    let (fd, _, eof, _) = chan_get name in
+    let cmd = match whence with
+      | "start" -> Unix.SEEK_SET
+      | "current" -> Unix.SEEK_CUR
+      | "end" -> Unix.SEEK_END
+      | _ -> raise (Eval_error ("channel-seek: invalid whence " ^ whence))
+    in
+    let _ = Unix.lseek fd offset cmd in
+    eof := false;
+    Nil);
+
+  register "channel-tell" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, _, _) = chan_get name in
+      Integer (Unix.lseek fd 0 Unix.SEEK_CUR)
+    | _ -> raise (Eval_error "channel-tell: (channel)"));
+
+  register "channel-eof?" (fun args ->
+    match args with
+    | [String name] ->
+      let (_, _, eof, _) = chan_get name in
+      Bool !eof
+    | _ -> raise (Eval_error "channel-eof?: (channel)"));
+
+  register "channel-blocking?" (fun args ->
+    match args with
+    | [String name] ->
+      let (_, _, _, blocking) = chan_get name in
+      Bool !blocking
+    | _ -> raise (Eval_error "channel-blocking?: (channel)"));
+
+  register "channel-set-blocking!" (fun args ->
+    match args with
+    | [String name; Bool b] ->
+      let (fd, _, _, blocking) = chan_get name in
+      blocking := b;
+      (try
+        if b then Unix.clear_nonblock fd
+        else Unix.set_nonblock fd
+      with _ -> ());
+      Nil
+    | _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
+
+  (* === 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
+    else if host = "localhost" then Unix.inet_addr_loopback
+    else
+      try Unix.inet_addr_of_string host
+      with _ ->
+        try
+          let entry = Unix.gethostbyname host in
+          if Array.length entry.Unix.h_addr_list = 0 then
+            raise (Eval_error ("socket: cannot resolve " ^ host))
+          else entry.Unix.h_addr_list.(0)
+        with Not_found -> raise (Eval_error ("socket: cannot resolve " ^ host))
+  in
+  let port_of v = match v with
+    | Integer n -> n
+    | Number n -> int_of_float n
+    | _ -> raise (Eval_error "socket: port must be a number")
+  in
+  let alloc_chan_name () =
+    let id = !channel_next_id in
+    incr channel_next_id;
+    Printf.sprintf "sock%d" id
+  in
+
+  register "socket-connect" (fun args ->
+    match args with
+    | [String host; port_v] ->
+      let port = port_of port_v in
+      let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
+      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      (try Unix.connect sock addr
+       with Unix.Unix_error (e, _, _) ->
+         (try Unix.close sock with _ -> ());
+         raise (Eval_error ("socket-connect: " ^ Unix.error_message e)));
+      let name = alloc_chan_name () in
+      Hashtbl.replace channel_table name (sock, "rw", ref false, ref true);
+      String name
+    | _ -> raise (Eval_error "socket-connect: (host port)"));
+
+  (* Non-blocking connect: returns channel immediately. Connection completes
+     when the channel becomes writable; query channel-async-error? after to
+     confirm success or get the error. *)
+  register "socket-connect-async" (fun args ->
+    match args with
+    | [String host; port_v] ->
+      let port = port_of port_v in
+      let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
+      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      Unix.set_nonblock sock;
+      (try Unix.connect sock addr
+       with
+       | Unix.Unix_error (Unix.EINPROGRESS, _, _)
+       | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> ()
+       | Unix.Unix_error (e, _, _) ->
+         (try Unix.close sock with _ -> ());
+         raise (Eval_error ("socket-connect-async: " ^ Unix.error_message e)));
+      let name = alloc_chan_name () in
+      Hashtbl.replace channel_table name (sock, "rw", ref false, ref false);
+      String name
+    | _ -> raise (Eval_error "socket-connect-async: (host port)"));
+
+  (* After a non-blocking connect completes (channel writable), check whether
+     the connect succeeded. Returns "" on success, error message on failure. *)
+  register "channel-async-error" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, _, _) = chan_get name in
+      (try
+        let err = Unix.getsockopt_error fd in
+        match err with
+        | None -> String ""
+        | Some e -> String (Unix.error_message e)
+      with
+      | Unix.Unix_error (e, _, _) -> String (Unix.error_message e))
+    | _ -> raise (Eval_error "channel-async-error: (channel)"));
+
+  register "socket-server" (fun args ->
+    let (host, port) = match args with
+      | [port_v] -> ("", port_of port_v)
+      | [String h; port_v] -> (h, port_of port_v)
+      | _ -> raise (Eval_error "socket-server: (port) or (host port)")
+    in
+    let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
+    let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+    Unix.setsockopt sock Unix.SO_REUSEADDR true;
+    (try Unix.bind sock addr
+     with Unix.Unix_error (e, _, _) ->
+       (try Unix.close sock with _ -> ());
+       raise (Eval_error ("socket-server: bind: " ^ Unix.error_message e)));
+    Unix.listen sock 8;
+    let name = alloc_chan_name () in
+    Hashtbl.replace channel_table name (sock, "server", ref false, ref true);
+    String name);
+
+  register "socket-accept" (fun args ->
+    match args with
+    | [String name] ->
+      let (sock, _, _, _) = chan_get name in
+      let (client_sock, client_addr) =
+        try Unix.accept sock
+        with Unix.Unix_error (e, _, _) ->
+          raise (Eval_error ("socket-accept: " ^ Unix.error_message e))
+      in
+      let (host_str, port) = match client_addr with
+        | Unix.ADDR_INET (addr, p) -> (Unix.string_of_inet_addr addr, p)
+        | Unix.ADDR_UNIX path -> (path, 0)
+      in
+      let client_name = alloc_chan_name () in
+      Hashtbl.replace channel_table client_name (client_sock, "rw", ref false, ref true);
+      let d = Hashtbl.create 3 in
+      Hashtbl.replace d "channel" (String client_name);
+      Hashtbl.replace d "host" (String host_str);
+      Hashtbl.replace d "port" (Integer port);
+      Dict d
+    | _ -> raise (Eval_error "socket-accept: (server-channel)"));
+
+  (* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]}
+     timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *)
+  register "io-select-channels" (fun args ->
+    let to_ms v = match v with
+      | Integer n -> n
+      | Number n -> int_of_float n
+      | _ -> raise (Eval_error "io-select-channels: timeout must be a number")
+    in
+    let to_list v = match v with
+      | List xs | ListRef { contents = xs } -> xs
+      | Nil -> []
+      | _ -> raise (Eval_error "io-select-channels: expected list")
+    in
+    let chan_name_of v = match v with
+      | String s -> s
+      | _ -> raise (Eval_error "io-select-channels: channel must be a string")
+    in
+    let (read_list, write_list, timeout_ms) = match args with
+      | [r; w; t] -> (to_list r, to_list w, to_ms t)
+      | _ -> raise (Eval_error "io-select-channels: (read-list write-list timeout-ms)")
+    in
+    let read_pairs = List.map (fun v ->
+      let name = chan_name_of v in
+      let (fd, _, _, _) = chan_get name in (name, fd)) read_list in
+    let write_pairs = List.map (fun v ->
+      let name = chan_name_of v in
+      let (fd, _, _, _) = chan_get name in (name, fd)) write_list in
+    let read_fds = List.map snd read_pairs in
+    let write_fds = List.map snd write_pairs in
+    let timeout = if timeout_ms < 0 then -1.0 else float_of_int timeout_ms /. 1000.0 in
+    let (ready_r, ready_w, _) =
+      try Unix.select read_fds write_fds [] timeout
+      with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
+    in
+    let names_of pairs ready =
+      List.filter_map (fun (n, fd) ->
+        if List.exists (fun rfd -> rfd = fd) ready then Some (String n) else None
+      ) pairs
+    in
+    let d = Hashtbl.create 2 in
+    Hashtbl.replace d "readable" (List (names_of read_pairs ready_r));
+    Hashtbl.replace d "writable" (List (names_of write_pairs ready_w));
+    Dict d);
+
+  (* === Clock === *)
+  register "clock-seconds" (fun args ->
+    match args with
+    | [] -> Integer (int_of_float (Unix.gettimeofday ()))
+    | _ -> raise (Eval_error "clock-seconds: no args"));
+
+  register "clock-milliseconds" (fun args ->
+    match args with
+    | [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0))
+    | _ -> raise (Eval_error "clock-milliseconds: no args"));
+
+  let format_tm tm tz_label =
+    fun fmt ->
+      let buf = Buffer.create 32 in
+      let n = String.length fmt in
+      let i = ref 0 in
+      while !i < n do
+        if fmt.[!i] = '%' && !i + 1 < n then begin
+          (match fmt.[!i + 1] with
+           | 'Y' -> Buffer.add_string buf (Printf.sprintf "%04d" (1900 + tm.Unix.tm_year))
+           | 'y' -> Buffer.add_string buf (Printf.sprintf "%02d" ((1900 + tm.Unix.tm_year) mod 100))
+           | 'm' -> Buffer.add_string buf (Printf.sprintf "%02d" (tm.Unix.tm_mon + 1))
+           | 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday)
+           | 'e' -> Buffer.add_string buf (Printf.sprintf "%2d"  tm.Unix.tm_mday)
+           | 'H' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_hour)
+           | 'I' -> let h = tm.Unix.tm_hour mod 12 in
+                    Buffer.add_string buf (Printf.sprintf "%02d" (if h = 0 then 12 else h))
+           | 'p' -> Buffer.add_string buf (if tm.Unix.tm_hour < 12 then "AM" else "PM")
+           | 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min)
+           | 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec)
+           | 'j' -> Buffer.add_string buf (Printf.sprintf "%03d" (tm.Unix.tm_yday + 1))
+           | 'w' -> Buffer.add_string buf (string_of_int tm.Unix.tm_wday)
+           | 'Z' -> Buffer.add_string buf tz_label
+           | 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in
+                    Buffer.add_string buf days.(tm.Unix.tm_wday)
+           | 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in
+                    Buffer.add_string buf days.(tm.Unix.tm_wday)
+           | 'b' | 'h' -> let mons = [|"Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"|] in
+                    Buffer.add_string buf mons.(tm.Unix.tm_mon)
+           | 'B' -> let mons = [|"January";"February";"March";"April";"May";"June";"July";"August";"September";"October";"November";"December"|] in
+                    Buffer.add_string buf mons.(tm.Unix.tm_mon)
+           | '%' -> Buffer.add_char buf '%'
+           | c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
+          i := !i + 2
+        end else begin
+          Buffer.add_char buf fmt.[!i];
+          incr i
+        end
+      done;
+      Buffer.contents buf
+  in
+  register "clock-format" (fun args ->
+    let (t, fmt, tz) = match args with
+      | [Integer t] -> (t, "%a %b %e %H:%M:%S %Z %Y", "utc")
+      | [Integer t; String f] -> (t, f, "utc")
+      | [Integer t; String f; String z] -> (t, f, z)
+      | _ -> raise (Eval_error "clock-format: (seconds [format [tz]])")
+    in
+    let tm =
+      if tz = "local" then Unix.localtime (float_of_int t)
+      else Unix.gmtime (float_of_int t)
+    in
+    let label = if tz = "local" then "" else "UTC" in
+    String (format_tm tm label fmt));
+
+  (* clock-scan: parse a date string with format, return seconds.
+     Supports the same format specifiers as clock-format (fixed-width ones).
+     tz: "utc" (default) or "local". *)
+  let timegm (tm : Unix.tm) =
+    let is_leap y = y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) in
+    let days_in_month = [|31;28;31;30;31;30;31;31;30;31;30;31|] in
+    let year = tm.Unix.tm_year + 1900 in
+    let mon = tm.Unix.tm_mon in
+    let mday = tm.Unix.tm_mday in
+    let total_days = ref 0 in
+    if year >= 1970 then begin
+      for y = 1970 to year - 1 do
+        total_days := !total_days + (if is_leap y then 366 else 365)
+      done
+    end else begin
+      for y = year to 1969 do
+        total_days := !total_days - (if is_leap y then 366 else 365)
+      done
+    end;
+    for m = 0 to mon - 1 do
+      total_days := !total_days + days_in_month.(m);
+      if m = 1 && is_leap year then incr total_days
+    done;
+    total_days := !total_days + mday - 1;
+    !total_days * 86400
+    + tm.Unix.tm_hour * 3600
+    + tm.Unix.tm_min * 60
+    + tm.Unix.tm_sec
+  in
+  register "clock-scan" (fun args ->
+    let (str, fmt, tz) = match args with
+      | [String s; String f] -> (s, f, "utc")
+      | [String s; String f; String z] -> (s, f, z)
+      | _ -> raise (Eval_error "clock-scan: (str fmt [tz])")
+    in
+    let n = String.length fmt and sn = String.length str in
+    let tm = ref { Unix.tm_year = 70; tm_mon = 0; tm_mday = 1;
+                   tm_hour = 0; tm_min = 0; tm_sec = 0;
+                   tm_wday = 0; tm_yday = 0; tm_isdst = false } in
+    let i = ref 0 and j = ref 0 in
+    let read_n_digits k =
+      let s = ref "" in
+      let cnt = ref 0 in
+      while !cnt < k && !j < sn && str.[!j] >= '0' && str.[!j] <= '9' do
+        s := !s ^ String.make 1 str.[!j];
+        incr j; incr cnt
+      done;
+      if !s = "" then 0 else int_of_string !s
+    in
+    let skip_ws () =
+      while !j < sn && (str.[!j] = ' ' || str.[!j] = '\t') do incr j done
+    in
+    while !i < n do
+      if fmt.[!i] = '%' && !i + 1 < n then begin
+        (match fmt.[!i + 1] with
+         | 'Y' -> tm := { !tm with tm_year = read_n_digits 4 - 1900 }
+         | 'y' -> let y = read_n_digits 2 in
+                  tm := { !tm with tm_year = (if y < 70 then 100 + y else y) }
+         | 'm' -> tm := { !tm with tm_mon = read_n_digits 2 - 1 }
+         | 'd' | 'e' -> skip_ws (); tm := { !tm with tm_mday = read_n_digits 2 }
+         | 'H' | 'I' -> tm := { !tm with tm_hour = read_n_digits 2 }
+         | 'M' -> tm := { !tm with tm_min = read_n_digits 2 }
+         | 'S' -> tm := { !tm with tm_sec = read_n_digits 2 }
+         | '%' -> if !j < sn && str.[!j] = '%' then incr j
+         | _ -> ()  (* unsupported specifier — skip *)
+        );
+        i := !i + 2
+      end else begin
+        if fmt.[!i] = ' ' then skip_ws ()
+        else if !j < sn && str.[!j] = fmt.[!i] then incr j;
+        incr i
+      end
+    done;
+    let secs =
+      if tz = "local" then int_of_float (fst (Unix.mktime !tm))
+      else timegm !tm
+    in
+    Integer secs);
+
+  (* === Env-as-value (Phase 4) === *)
+
+  (* env-lookup: (env key) → value or nil.  Works on Env, Dict, or Nil. *)
+  register "env-lookup" (fun args ->
+    let unwrap = function
+      | Env e -> e
+      | Nil -> make_env ()
+      | _ -> raise (Eval_error "env-lookup: first arg must be an environment") in
+    match args with
+    | [env_val; key] ->
+      let e = unwrap env_val in
+      let k = value_to_string key in
+      if env_has e k then env_get e k else Nil
+    | _ -> raise (Eval_error "env-lookup: (env key)"));
+
+  (* env-extend: (env [key val ...]) → new child env with optional bindings. *)
+  register "env-extend" (fun args ->
+    match args with
+    | [] -> raise (Eval_error "env-extend: requires at least one arg")
+    | env_val :: pairs ->
+      let parent_env = match env_val with
+        | Env e -> e
+        | Nil -> make_env ()
+        | _ -> raise (Eval_error "env-extend: first arg must be an environment") in
+      let child = env_extend parent_env in
+      let rec add_bindings = function
+        | [] -> ()
+        | k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
+        | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
+      add_bindings pairs;
+      Env child)

hosts/ocaml/lib/sx_ref.ml

@@ -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 (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 (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))))
 
 (* cek-resume *)
 and cek_resume suspended_state result' =
@@ -759,7 +759,78 @@ 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 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)))))
+  (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)
 
 (* step-sf-handler-bind *)
 and step_sf_handler_bind args env kont =
@@ -981,7 +1052,14 @@ let cek_run_iterative state =
       s := cek_step !s
     done;
     (match cek_suspended_p !s with
-     | Bool true -> raise (Eval_error "IO suspension in non-IO context")
+     | 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"))
      | _ -> cek_value !s)
   with Eval_error msg ->
     _last_error_kont_ref := cek_kont !s;
@@ -1054,8 +1132,7 @@ let sf_define_type args env_val =
       (match pargs with
       | [v] ->
         (match v with
-        | Dict d -> Bool (Hashtbl.mem d "_adt" &&
-          (match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false))
+        | AdtValue a -> Bool (a.av_type = type_name)
         | _ -> Bool false)
       | _ -> Bool false)));
   List.iter (fun spec ->
@@ -1069,21 +1146,18 @@ 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 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));
+          else
+            AdtValue {
+              av_type = type_name;
+              av_ctor = cn;
+              av_fields = Array.of_list ctor_args;
+            }));
       env_bind_v (cn ^ "?")
         (NativeFn (cn ^ "?", fun pargs ->
           (match pargs with
           | [v] ->
             (match v with
-            | Dict d -> Bool (Hashtbl.mem d "_adt" &&
-              (match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false))
+            | AdtValue a -> Bool (a.av_ctor = cn)
             | _ -> Bool false)
           | _ -> Bool false)));
       List.iteri (fun idx fname ->
@@ -1092,13 +1166,10 @@ let sf_define_type args env_val =
             (match pargs with
             | [v] ->
               (match v with
-              | Dict d ->
-                (match Hashtbl.find_opt d "_fields" with
-                | Some (List fs) ->
-                  if idx < List.length fs then List.nth fs idx
-                  else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
-                | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
-              | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict")))
+              | 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")))
             | _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg")))))
       ) field_names
     | _ -> ())

hosts/ocaml/lib/sx_runtime.ml

@@ -6,11 +6,72 @@
 
 open Sx_types
 
-(** Call a registered primitive by name. *)
+(** 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. *)
 let prim_call name args =
-  match Hashtbl.find_opt Sx_primitives.primitives name with
-  | Some f -> f args
-  | None -> raise (Eval_error ("Unknown primitive: " ^ name))
+  (* 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))
 
 (** Convert any SX value to an OCaml string (internal). *)
 let value_to_str = function
@@ -209,6 +270,13 @@ 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 ->
@@ -404,6 +472,10 @@ 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
@@ -539,3 +611,4 @@ let jit_try_call f args =
       (match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; _jit_skip_sentinel)
     | _ -> incr _jit_skip; _jit_skip_sentinel
 
+

hosts/ocaml/lib/sx_types.ml

@@ -82,6 +82,16 @@ 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 =
@@ -520,6 +530,7 @@ 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
@@ -806,14 +817,15 @@ let dict_vals (d : dict) =
 
 (** {1 Value display} *)
 
-let rec inspect = function
-  | Nil -> "nil"
-  | Bool true -> "true"
-  | Bool false -> "false"
-  | Integer n -> string_of_int n
-  | Number n -> format_number n
+(* 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)
   | String s ->
-    let buf = Buffer.create (String.length s + 2) in
     Buffer.add_char buf '"';
     String.iter (function
       | '"'  -> Buffer.add_string buf "\\\""
@@ -822,66 +834,129 @@ let rec inspect = function
       | '\r' -> Buffer.add_string buf "\\r"
       | '\t' -> Buffer.add_string buf "\\t"
       | c    -> Buffer.add_char buf c) s;
-    Buffer.add_char buf '"';
-    Buffer.contents buf
-  | Symbol s -> s
-  | Keyword k -> ":" ^ k
+    Buffer.add_char buf '"'
+  | Symbol s -> Buffer.add_string buf s
+  | Keyword k -> Buffer.add_char buf ':'; Buffer.add_string buf k
   | List items | ListRef { contents = items } ->
-    "(" ^ String.concat " " (List.map inspect 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 ')'
   | Dict d ->
-    let pairs = Hashtbl.fold (fun k v acc ->
-      (Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
-    "{" ^ String.concat " " pairs ^ "}"
+    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 '}'
   | Lambda l ->
     let tag = match l.l_name with Some n -> n | None -> "lambda" in
-    Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
+    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 ")>"
   | Component c ->
-    Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
+    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 ")>"
   | Island i ->
-    Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
+    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 ")>"
   | Macro m ->
     let tag = match m.m_name with Some n -> n | None -> "macro" in
-    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")
+    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 '>'
   | Record r ->
-    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
+    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 '>'
   | Vector arr ->
-    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)
+    Buffer.add_string buf "#(";
+    Array.iteri (fun i v ->
+      if i > 0 then Buffer.add_char buf ' ';
+      inspect_into buf v) arr;
+    Buffer.add_char buf ')'
+  | VmFrame f ->
+    Buffer.add_string buf (Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base)
+  | VmMachine m ->
+    Buffer.add_string buf (Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames))
+  | StringBuffer b ->
+    Buffer.add_string buf (Printf.sprintf "<string-buffer:%d>" (Buffer.length b))
+  | HashTable ht ->
+    Buffer.add_string buf (Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht))
   | Char n ->
-    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"
+    Buffer.add_string buf "#\\";
+    (match n with
+     | 32 -> Buffer.add_string buf "space"
+     | 10 -> Buffer.add_string buf "newline"
+     | 9 -> Buffer.add_string buf "tab"
+     | 13 -> Buffer.add_string buf "return"
+     | 0 -> Buffer.add_string buf "nul"
+     | 27 -> Buffer.add_string buf "escape"
+     | 127 -> Buffer.add_string buf "delete"
+     | 8 -> Buffer.add_string buf "backspace"
+     | _ -> Buffer.add_utf_8_uchar buf (Uchar.of_int n))
+  | Eof -> Buffer.add_string buf "#!eof"
   | Port { sp_kind = PortInput (_, pos); sp_closed } ->
-    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)))))
+    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

hosts/ocaml/lib/sx_vm.ml

@@ -327,7 +327,18 @@ and call_closure_reuse cl args =
        vm.sp <- saved_sp;
        raise e);
     vm.frames <- saved_frames;
-    pop vm
+    (* 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
   | None ->
     call_closure cl args cl.vm_env_ref
 
@@ -631,7 +642,9 @@ 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 (Number n) -> int_of_float n | _ -> 0)
+                | Some (Integer n) -> n
+                | Some (Number n) -> int_of_float n
+                | _ -> 0)
             | _ -> 0
           in
           let upvalues = Array.init uv_count (fun _ ->
@@ -731,38 +744,57 @@ 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 ((Hashtbl.find Sx_primitives.primitives "=") [a; b])
+          push vm (Bool (Sx_runtime._fast_eq 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)
-            | _ -> (Hashtbl.find Sx_primitives.primitives "<") [a; b])
+            | _ -> Sx_runtime.prim_call "<" [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)
-            | _ -> (Hashtbl.find Sx_primitives.primitives ">") [a; b])
+            | _ -> Sx_runtime.prim_call ">" [a; b])
         | 167 (* OP_NOT *) ->
           let v = pop vm in
           push vm (Bool (not (sx_truthy v)))
@@ -885,9 +917,17 @@ 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;
@@ -1269,7 +1309,9 @@ 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 (Number n) -> int_of_float n | _ -> 0)
+                  | Some (Integer n) -> n
+                  | Some (Number n) -> int_of_float n
+                  | _ -> 0)
               | _ -> 0 in
             let upvalues = Array.init uv_count (fun _ ->
               let is_local = read_u8 frame in
@@ -1390,7 +1432,9 @@ 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 (Number n) -> int_of_float n | _ -> 0)
+                | Some (Integer n) -> n
+                | Some (Number n) -> int_of_float n
+                | _ -> 0)
             | _ -> 0 in
           ip := !ip + uv_count * 2
         end

hosts/ocaml/lib/sx_vm_ref.ml

@@ -270,7 +270,9 @@ 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 (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

hosts/ocaml/sx_vm_ref.ml

@@ -265,7 +265,9 @@ 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 (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

lib/apl/conformance.sh

@@ -0,0 +1,116 @@
+#!/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 ]

lib/apl/parser.sx

@@ -0,0 +1,576 @@
+; 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))))

lib/apl/scoreboard.json

@@ -0,0 +1,17 @@
+{
+  "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
+}

lib/apl/scoreboard.md

@@ -0,0 +1,22 @@
+# 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.

lib/apl/test.sh

@@ -4,9 +4,9 @@
 set -uo pipefail
 cd "$(git rev-parse --show-toplevel)"
 
-SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
 if [ ! -x "$SX_SERVER" ]; then
-  SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
+  SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
 fi
 if [ ! -x "$SX_SERVER" ]; then
   echo "ERROR: sx_server.exe not found."
@@ -18,19 +18,37 @@ 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)
-(load "lib/apl/tests/runtime.sx")
+(eval "(define apl-test-pass 0)")
+(eval "(define apl-test-fail 0)")
+(eval "(define apl-test-fails (list))")
+(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (begin (set! apl-test-fail (+ apl-test-fail 1)) (set! apl-test-fails (append apl-test-fails (list {:name name :got got :expected expected})))))))")
 (epoch 3)
+(load "lib/apl/tests/structural.sx")
+(load "lib/apl/tests/operators.sx")
+(load "lib/apl/tests/dfn.sx")
+(load "lib/apl/tests/tradfn.sx")
+(load "lib/apl/tests/valence.sx")
+(load "lib/apl/tests/programs.sx")
+(load "lib/apl/tests/system.sx")
+(load "lib/apl/tests/idioms.sx")
+(load "lib/apl/tests/eval-ops.sx")
+(load "lib/apl/tests/pipeline.sx")
+(epoch 4)
 (eval "(list apl-test-pass apl-test-fail)")
 EPOCHS
 
-OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
+OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
 
-LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}')
+LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {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/\)$//')
+  LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
+          | sed -E 's/^\(ok 4 //; s/\)$//')
 fi
 if [ -z "$LINE" ]; then
   echo "ERROR: could not extract summary"

lib/apl/tests/dfn.sx

@@ -0,0 +1,227 @@
+; 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))

lib/apl/tests/eval-ops.sx

@@ -0,0 +1,147 @@
+; 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))

lib/apl/tests/idioms.sx

@@ -0,0 +1,359 @@
+; 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))

lib/apl/tests/operators.sx

@@ -0,0 +1,791 @@
+(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))

lib/apl/tests/parse.sx

@@ -0,0 +1,340 @@
+(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))))

lib/apl/tests/pipeline.sx

@@ -0,0 +1,180 @@
+; 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))

lib/apl/tests/programs.sx

@@ -0,0 +1,304 @@
+; 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)

lib/apl/tests/programs/life.apl

@@ -0,0 +1,22 @@
+⍝ 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 ⌽¨ ⊂⍵}

lib/apl/tests/programs/mandelbrot.apl

@@ -0,0 +1,29 @@
+⍝ 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}⍣⍺⊢⍵}

lib/apl/tests/programs/n-queens.apl

@@ -0,0 +1,18 @@
+⍝ 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 ⍵)}

lib/apl/tests/programs/primes.apl

@@ -0,0 +1,16 @@
+⍝ 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=⍵∘.|⍵)/⍵←⍳⍵}

lib/apl/tests/programs/quicksort.apl

@@ -0,0 +1,25 @@
+⍝ 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}

lib/apl/tests/scalar.sx

@@ -0,0 +1,369 @@
+; 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))))

lib/apl/tests/structural.sx

@@ -0,0 +1,608 @@
+;; 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))

lib/apl/tests/system.sx

@@ -0,0 +1,48 @@
+; 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))

lib/apl/tests/tradfn.sx

@@ -0,0 +1,156 @@
+; 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))

lib/apl/tests/valence.sx

@@ -0,0 +1,81 @@
+; 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)

lib/apl/tokenizer.sx

@@ -0,0 +1,168 @@
+(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)))

lib/apl/transpile.sx

@@ -0,0 +1,460 @@
+; 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) {})))

lib/common-lisp/clos.sx

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

lib/common-lisp/conformance.sh

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

lib/common-lisp/loop.sx

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

lib/common-lisp/parser.sx

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

lib/common-lisp/reader.sx

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

lib/common-lisp/runtime.sx

@@ -1,18 +1,14 @@
-;; lib/common-lisp/runtime.sx — CL built-ins using SX spec primitives
+;; lib/common-lisp/runtime.sx — CL built-ins + condition system on SX
 ;;
-;; Provides CL-specific wrappers and helpers. Deliberately thin: wherever
-;; an SX spec primitive already does the job, we alias it rather than
-;; reinventing it.
+;; Section 1-9:  Type predicates, arithmetic, characters, strings, gensym,
+;;               multiple values, sets, radix formatting, list utilities.
+;; Section 10:   Condition system (define-condition, signal/error/warn,
+;;               handler-bind, handler-case, restart-case, invoke-restart).
 ;;
 ;; Primitives used from spec:
 ;;   char/char->integer/integer->char/char-upcase/char-downcase
-;;   format   (Phase 21 — must be loaded before this file)
-;;   gensym   (Phase 12)
-;;   rational/rational?  (Phase 16)
-;;   make-set/set-member?/set-union/etc  (Phase 18)
-;;   open-input-string/read-char/etc  (Phase 14)
-;;   modulo/remainder/quotient/gcd/lcm/expt  (Phase 2 / Phase 15)
-;;   number->string with radix  (Phase 15)
+;;   format   gensym   rational/rational?   make-set/set-member?/etc
+;;   modulo/remainder/quotient/gcd/lcm/expt   number->string
 
 ;; ---------------------------------------------------------------------------
 ;; 1.  Type predicates
@@ -27,13 +23,19 @@
   (cl-numberp? x)
   (let ((t (type-of x))) (or (= t "number") (= t "rational"))))
 
-(define cl-integerp? integer?)
-(define cl-floatp? float?)
-(define cl-rationalp? rational?)
+(prefix-rename "cl-"
+  '(
+    (integerp? integer?)
+    (floatp? float?)
+    (rationalp? rational?)
+    ))
 
 (define (cl-realp? x) (or (integer? x) (float? x) (rational? x)))
 
-(define cl-characterp? char?)
+(prefix-rename "cl-"
+  '(
+    (characterp? char?)
+    ))
 (define cl-stringp? (fn (x) (= (type-of x) "string")))
 (define cl-symbolp? (fn (x) (= (type-of x) "symbol")))
 (define cl-keywordp? (fn (x) (= (type-of x) "keyword")))
@@ -48,8 +50,11 @@
       (= t "native-fn")
       (= t "component"))))
 
-(define cl-vectorp? vector?)
-(define cl-arrayp? vector?)
+(prefix-rename "cl-"
+  '(
+    (vectorp? vector?)
+    (arrayp? vector?)
+    ))
 
 ;; sx_server: (rest (list x)) returns () not nil — cl-empty? handles both
 (define
@@ -60,19 +65,25 @@
 ;; 2.  Arithmetic — thin aliases to spec primitives
 ;; ---------------------------------------------------------------------------
 
-(define cl-mod modulo)
-(define cl-rem remainder)
-(define cl-gcd gcd)
-(define cl-lcm lcm)
-(define cl-expt expt)
-(define cl-floor floor)
-(define cl-ceiling ceil)
-(define cl-truncate truncate)
-(define cl-round round)
+(prefix-rename "cl-"
+  '(
+    (mod modulo)
+    (rem remainder)
+    gcd
+    lcm
+    expt
+    floor
+    (ceiling ceil)
+    truncate
+    round
+    ))
 (define cl-abs (fn (x) (if (< x 0) (- 0 x) x)))
 (define cl-min (fn (a b) (if (< a b) a b)))
 (define cl-max (fn (a b) (if (> a b) a b)))
-(define cl-quotient quotient)
+(prefix-rename "cl-"
+  '(
+    quotient
+    ))
 
 (define
   (cl-signum x)
@@ -91,21 +102,27 @@
 ;; 3.  Character functions — alias spec char primitives + CL name mapping
 ;; ---------------------------------------------------------------------------
 
-(define cl-char->integer char->integer)
-(define cl-integer->char integer->char)
-(define cl-char-upcase char-upcase)
-(define cl-char-downcase char-downcase)
-(define cl-char-code char->integer)
-(define cl-code-char integer->char)
+(prefix-rename "cl-"
+  '(
+    char->integer
+    integer->char
+    char-upcase
+    char-downcase
+    (char-code char->integer)
+    (code-char integer->char)
+    ))
 
-(define cl-char=? char=?)
-(define cl-char<? char<?)
-(define cl-char>? char>?)
-(define cl-char<=? char<=?)
-(define cl-char>=? char>=?)
-(define cl-char-ci=? char-ci=?)
-(define cl-char-ci<? char-ci<?)
-(define cl-char-ci>? char-ci>?)
+(prefix-rename "cl-"
+  '(
+    char=?
+    char<?
+    char>?
+    char<=?
+    char>=?
+    char-ci=?
+    char-ci<?
+    char-ci>?
+    ))
 
 ;; Inline predicates — char-alphabetic?/char-numeric? unreliable in sx_server
 (define
@@ -156,8 +173,11 @@
   (cl-format dest template &rest args)
   (let ((s (apply format (cons template args)))) (if (= dest nil) s s)))
 
-(define cl-write-to-string write-to-string)
-(define cl-princ-to-string display-to-string)
+(prefix-rename "cl-"
+  '(
+    write-to-string
+    (princ-to-string display-to-string)
+    ))
 
 ;; CL read-from-string: parse value from a string using SX port
 (define
@@ -165,18 +185,27 @@
   (let ((p (open-input-string s))) (read p)))
 
 ;; String stream (output)
-(define cl-make-string-output-stream open-output-string)
-(define cl-get-output-stream-string get-output-string)
+(prefix-rename "cl-"
+  '(
+    (make-string-output-stream open-output-string)
+    (get-output-stream-string get-output-string)
+    ))
 
 ;; String stream (input)
-(define cl-make-string-input-stream open-input-string)
+(prefix-rename "cl-"
+  '(
+    (make-string-input-stream open-input-string)
+    ))
 
 ;; ---------------------------------------------------------------------------
 ;; 5.  Gensym
 ;; ---------------------------------------------------------------------------
 
-(define cl-gensym gensym)
-(define cl-gentemp gensym)
+(prefix-rename "cl-"
+  '(
+    gensym
+    (gentemp gensym)
+    ))
 
 ;; ---------------------------------------------------------------------------
 ;; 6.  Multiple values (CL: values / nth-value)
@@ -207,16 +236,19 @@
 ;; 7.  Sets (CL: adjoin / member / union / intersection / set-difference)
 ;; ---------------------------------------------------------------------------
 
-(define cl-make-set make-set)
-(define cl-set? set?)
-(define cl-set-add set-add!)
-(define cl-set-memberp set-member?)
-(define cl-set-remove set-remove!)
-(define cl-set-union set-union)
-(define cl-set-intersect set-intersection)
-(define cl-set-difference set-difference)
-(define cl-list->set list->set)
-(define cl-set->list set->list)
+(prefix-rename "cl-"
+  '(
+    make-set
+    set?
+    (set-add set-add!)
+    (set-memberp set-member?)
+    (set-remove set-remove!)
+    set-union
+    (set-intersect set-intersection)
+    set-difference
+    list->set
+    set->list
+    ))
 
 ;; CL: (member item list) — returns tail starting at item, or nil
 (define
@@ -304,3 +336,425 @@
     ((or (cl-empty? plist) (cl-empty? (rest plist))) nil)
     ((equal? (first plist) key) (first (rest plist)))
     (else (cl-getf (rest (rest plist)) key))))
+
+;; ---------------------------------------------------------------------------
+;; 10.  Condition system (Phase 3)
+;;
+;; Condition objects:
+;;   {:cl-type "cl-condition" :class "NAME" :slots {slot-name val ...}}
+;;
+;; The built-in handler-bind / restart-case expect LITERAL handler specs in
+;; source (they operate on the raw AST), so we implement our own handler and
+;; restart stacks as mutable SX globals.
+;; ---------------------------------------------------------------------------
+
+;; ── condition class registry ───────────────────────────────────────────────
+;;
+;; Populated at load time with all ANSI standard condition types.
+;; Also mutated by cl-define-condition.
+
+(define
+  cl-condition-classes
+  (dict
+    "condition"
+    {:parents (list) :slots (list) :name "condition"}
+    "serious-condition"
+    {:parents (list "condition") :slots (list) :name "serious-condition"}
+    "error"
+    {:parents (list "serious-condition") :slots (list) :name "error"}
+    "warning"
+    {:parents (list "condition") :slots (list) :name "warning"}
+    "simple-condition"
+    {:parents (list "condition") :slots (list "format-control" "format-arguments") :name "simple-condition"}
+    "simple-error"
+    {:parents (list "error" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-error"}
+    "simple-warning"
+    {:parents (list "warning" "simple-condition") :slots (list "format-control" "format-arguments") :name "simple-warning"}
+    "type-error"
+    {:parents (list "error") :slots (list "datum" "expected-type") :name "type-error"}
+    "arithmetic-error"
+    {:parents (list "error") :slots (list "operation" "operands") :name "arithmetic-error"}
+    "division-by-zero"
+    {:parents (list "arithmetic-error") :slots (list) :name "division-by-zero"}
+    "cell-error"
+    {:parents (list "error") :slots (list "name") :name "cell-error"}
+    "unbound-variable"
+    {:parents (list "cell-error") :slots (list) :name "unbound-variable"}
+    "undefined-function"
+    {:parents (list "cell-error") :slots (list) :name "undefined-function"}
+    "program-error"
+    {:parents (list "error") :slots (list) :name "program-error"}
+    "storage-condition"
+    {:parents (list "serious-condition") :slots (list) :name "storage-condition"}))
+
+;; ── condition predicates ───────────────────────────────────────────────────
+
+(define
+  cl-condition?
+  (fn (x) (and (dict? x) (= (get x "cl-type") "cl-condition"))))
+
+;; cl-condition-of-type? walks the class hierarchy.
+;; We capture cl-condition-classes at define time via let to avoid
+;; free-variable scoping issues at call time.
+
+(define
+  cl-condition-of-type?
+  (let
+    ((classes cl-condition-classes))
+    (fn
+      (c type-name)
+      (if
+        (not (cl-condition? c))
+        false
+        (let
+          ((class-name (get c "class")))
+          (define
+            check
+            (fn
+              (n)
+              (if
+                (= n type-name)
+                true
+                (let
+                  ((entry (get classes n)))
+                  (if
+                    (nil? entry)
+                    false
+                    (some (fn (p) (check p)) (get entry "parents")))))))
+          (check class-name))))))
+
+;; ── condition constructors ─────────────────────────────────────────────────
+
+;; cl-define-condition registers a new condition class.
+;; name:       string (condition class name)
+;; parents:    list of strings (parent class names)
+;; slot-names: list of strings
+
+(define
+  cl-define-condition
+  (fn
+    (name parents slot-names)
+    (begin (dict-set! cl-condition-classes name {:parents parents :slots slot-names :name name}) name)))
+
+;; cl-make-condition constructs a condition object.
+;; Keyword args (alternating slot-name/value pairs) populate the slots dict.
+
+(define
+  cl-make-condition
+  (fn
+    (name &rest kw-args)
+    (let
+      ((slots (dict)))
+      (define
+        fill
+        (fn
+          (args)
+          (when
+            (>= (len args) 2)
+            (begin
+              (dict-set! slots (first args) (first (rest args)))
+              (fill (rest (rest args)))))))
+      (fill kw-args)
+      {:cl-type "cl-condition" :slots slots :class name})))
+
+;; ── condition accessors ────────────────────────────────────────────────────
+
+(define
+  cl-condition-slot
+  (fn
+    (c slot-name)
+    (if (cl-condition? c) (get (get c "slots") slot-name) nil)))
+
+(define
+  cl-condition-message
+  (fn
+    (c)
+    (if
+      (not (cl-condition? c))
+      (str c)
+      (let
+        ((slots (get c "slots")))
+        (or
+          (get slots "message")
+          (get slots "format-control")
+          (str "Condition: " (get c "class")))))))
+
+(define
+  cl-simple-condition-format-control
+  (fn (c) (cl-condition-slot c "format-control")))
+
+(define
+  cl-simple-condition-format-arguments
+  (fn (c) (cl-condition-slot c "format-arguments")))
+
+(define cl-type-error-datum (fn (c) (cl-condition-slot c "datum")))
+
+(define
+  cl-type-error-expected-type
+  (fn (c) (cl-condition-slot c "expected-type")))
+
+(define
+  cl-arithmetic-error-operation
+  (fn (c) (cl-condition-slot c "operation")))
+
+(define
+  cl-arithmetic-error-operands
+  (fn (c) (cl-condition-slot c "operands")))
+
+;; ── mutable handler + restart stacks ──────────────────────────────────────
+;;
+;; Handler entry: {:type "type-name" :fn (fn (condition) result)}
+;; Restart entry: {:name "restart-name" :fn (fn (&optional arg) result) :escape k}
+;;
+;; New handlers are prepended (checked first = most recent handler wins).
+
+(define cl-handler-stack (list))
+(define cl-restart-stack (list))
+
+(define
+  cl-push-handlers
+  (fn (entries) (set! cl-handler-stack (append entries cl-handler-stack))))
+
+(define
+  cl-pop-handlers
+  (fn
+    (n)
+    (set! cl-handler-stack (slice cl-handler-stack n (len cl-handler-stack)))))
+
+(define
+  cl-push-restarts
+  (fn (entries) (set! cl-restart-stack (append entries cl-restart-stack))))
+
+(define
+  cl-pop-restarts
+  (fn
+    (n)
+    (set! cl-restart-stack (slice cl-restart-stack n (len cl-restart-stack)))))
+
+;; ── *debugger-hook* + invoke-debugger ────────────────────────────────────
+;;
+;; cl-debugger-hook: called when an error propagates with no handler.
+;; Signature: (fn (condition hook) result). The hook arg is itself
+;; (so the hook can rebind it to nil to prevent recursion).
+;; nil = use default (re-raise as host error).
+
+(define cl-debugger-hook nil)
+
+(define cl-invoke-debugger
+  (fn (c)
+    (if (nil? cl-debugger-hook)
+      (error (str "Debugger: " (cl-condition-message c)))
+      (let ((hook cl-debugger-hook))
+        (set! cl-debugger-hook nil)
+        (let ((result (hook c hook)))
+          (set! cl-debugger-hook hook)
+          result)))))
+
+;; ── *break-on-signals* ────────────────────────────────────────────────────
+;;
+;; When set to a type name string, cl-signal invokes the debugger hook
+;; before walking handlers if the condition is of that type.
+;; nil = disabled (ANSI default).
+
+(define cl-break-on-signals nil)
+
+;; ── invoke-restart-interactively ──────────────────────────────────────────
+;;
+;; Like invoke-restart but calls the restart's fn with no arguments
+;; (real CL would prompt the user for each arg via :interactive).
+
+(define cl-invoke-restart-interactively
+  (fn (name)
+    (let ((entry (cl-find-restart-entry name cl-restart-stack)))
+      (if (nil? entry)
+        (error (str "No active restart: " name))
+        (let ((restart-fn (get entry "fn"))
+              (escape     (get entry "escape")))
+          (escape (restart-fn)))))))
+
+;; ── cl-signal (non-unwinding) ─────────────────────────────────────────────
+;;
+;; Walks cl-handler-stack; for each matching entry, calls the handler fn.
+;; Handlers return normally — signal continues to the next matching handler.
+
+(define
+  cl-signal-obj
+  (fn
+    (obj stack)
+    (if
+      (empty? stack)
+      nil
+      (let
+        ((entry (first stack)))
+        (if
+          (cl-condition-of-type? obj (get entry "type"))
+          (begin ((get entry "fn") obj) (cl-signal-obj obj (rest stack)))
+          (cl-signal-obj obj (rest stack)))))))
+
+(define cl-signal
+  (fn (c)
+    (let ((obj (if (cl-condition? c)
+                 c
+                 (cl-make-condition "simple-condition"
+                   "format-control" (str c)))))
+      ;; *break-on-signals*: invoke debugger hook when type matches
+      (when (and (not (nil? cl-break-on-signals))
+                 (cl-condition-of-type? obj cl-break-on-signals))
+        (cl-invoke-debugger obj))
+      (cl-signal-obj obj cl-handler-stack))))
+
+;; ── cl-error ───────────────────────────────────────────────────────────────
+;;
+;; Signals an error. If no handler catches it, raises a host-level error.
+
+(define
+  cl-error
+  (fn
+    (c &rest args)
+    (let
+      ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
+      (cl-signal-obj obj cl-handler-stack)
+      (cl-invoke-debugger obj))))
+
+;; ── cl-warn ────────────────────────────────────────────────────────────────
+
+(define
+  cl-warn
+  (fn
+    (c &rest args)
+    (let
+      ((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-warning" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-warning" "format-control" (str c))))))
+      (cl-signal-obj obj cl-handler-stack))))
+
+;; ── cl-handler-bind (non-unwinding) ───────────────────────────────────────
+;;
+;; bindings: list of (type-name handler-fn) pairs
+;; thunk:    (fn () body)
+
+(define
+  cl-handler-bind
+  (fn
+    (bindings thunk)
+    (let
+      ((entries (map (fn (b) {:fn (first (rest b)) :type (first b)}) bindings)))
+      (begin
+        (cl-push-handlers entries)
+        (let
+          ((result (thunk)))
+          (begin (cl-pop-handlers (len entries)) result))))))
+
+;; ── cl-handler-case (unwinding) ───────────────────────────────────────────
+;;
+;; thunk: (fn () body)
+;; cases: list of (type-name handler-fn) pairs
+;;
+;; Uses call/cc for the escape continuation.
+
+(define
+  cl-handler-case
+  (fn
+    (thunk &rest cases)
+    (call/cc
+      (fn
+        (escape)
+        (let
+          ((entries (map (fn (c) {:fn (fn (x) (escape ((first (rest c)) x))) :type (first c)}) cases)))
+          (begin
+            (cl-push-handlers entries)
+            (let
+              ((result (thunk)))
+              (begin (cl-pop-handlers (len entries)) result))))))))
+
+;; ── cl-restart-case ────────────────────────────────────────────────────────
+;;
+;; thunk:    (fn () body)
+;; restarts: list of (name params body-fn) triples
+;;   body-fn is (fn () val) or (fn (arg) val)
+
+(define
+  cl-restart-case
+  (fn
+    (thunk &rest restarts)
+    (call/cc
+      (fn
+        (escape)
+        (let
+          ((entries (map (fn (r) {:fn (first (rest (rest r))) :escape escape :name (first r)}) restarts)))
+          (begin
+            (cl-push-restarts entries)
+            (let
+              ((result (thunk)))
+              (begin (cl-pop-restarts (len entries)) result))))))))
+
+;; ── cl-with-simple-restart ─────────────────────────────────────────────────
+
+(define
+  cl-with-simple-restart
+  (fn
+    (name description thunk)
+    (cl-restart-case thunk (list name (list) (fn () nil)))))
+
+;; ── find-restart / invoke-restart / compute-restarts ──────────────────────
+
+(define
+  cl-find-restart-entry
+  (fn
+    (name stack)
+    (if
+      (empty? stack)
+      nil
+      (let
+        ((entry (first stack)))
+        (if
+          (= (get entry "name") name)
+          entry
+          (cl-find-restart-entry name (rest stack)))))))
+
+(define
+  cl-find-restart
+  (fn (name) (cl-find-restart-entry name cl-restart-stack)))
+
+(define
+  cl-invoke-restart
+  (fn
+    (name &rest args)
+    (let
+      ((entry (cl-find-restart-entry name cl-restart-stack)))
+      (if
+        (nil? entry)
+        (error (str "No active restart: " name))
+        (let
+          ((restart-fn (get entry "fn")) (escape (get entry "escape")))
+          (escape
+            (if (empty? args) (restart-fn) (restart-fn (first args)))))))))
+
+(define
+  cl-compute-restarts
+  (fn () (map (fn (e) (get e "name")) cl-restart-stack)))
+
+;; ── with-condition-restarts (stub — association is advisory) ──────────────
+
+(define cl-with-condition-restarts (fn (c restarts thunk) (thunk)))
+
+;; ── cl-cerror ──────────────────────────────────────────────────────────────
+;;
+;; Signals a continuable error. The "continue" restart is established;
+;; invoke-restart "continue" to proceed past the error.
+
+
+
+;; ── cl-cerror ──────────────────────────────────────────────────────────────
+;;
+;; Signals a continuable error. The "continue" restart is established;
+;; invoke-restart "continue" to proceed past the error.
+
+(define cl-cerror
+  (fn (continue-string c &rest args)
+    (let ((obj (if (cl-condition? c)
+                 c
+                 (cl-make-condition "simple-error"
+                   "format-control" (str c)
+                   "format-arguments" args))))
+      (cl-restart-case
+        (fn () (cl-signal-obj obj cl-handler-stack))
+        (list "continue" (list) (fn () nil))))))

lib/common-lisp/scoreboard.json

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

lib/common-lisp/scoreboard.md

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

lib/common-lisp/test.sh

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

lib/common-lisp/tests/clos.sx

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

lib/common-lisp/tests/conditions.sx

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

lib/common-lisp/tests/eval.sx

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

lib/common-lisp/tests/lambda.sx

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

lib/common-lisp/tests/macros.sx

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

lib/common-lisp/tests/parse.sx

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

lib/common-lisp/tests/programs/geometry.sx

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

lib/common-lisp/tests/programs/interactive-debugger.sx

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

lib/common-lisp/tests/programs/mop-trace.sx

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

lib/common-lisp/tests/programs/parse-recover.sx

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

lib/common-lisp/tests/programs/restart-demo.sx

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

lib/common-lisp/tests/read.sx

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

lib/common-lisp/tests/runtime.sx

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

lib/common-lisp/tests/stdlib.sx

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

lib/compiler.sx

@@ -1008,11 +1008,27 @@
             (let
               ((name (symbol-name head))
                 (argc (len args))
-                (name-idx (pool-add (get em "pool") name)))
+                (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)))
               (for-each (fn (a) (compile-expr em a scope false)) args)
-              (emit-op em 52)
-              (emit-u16 em name-idx)
-              (emit-byte em argc))
+              (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))))
             (do
               (compile-expr em head scope false)
               (for-each (fn (a) (compile-expr em a scope false)) args)

lib/erlang/scoreboard.json

@@ -1,16 +1,16 @@
 {
   "language": "erlang",
-  "total_pass": 530,
-  "total": 530,
+  "total_pass": 0,
+  "total": 0,
   "suites": [
-    {"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"}
+    {"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"}
   ]
 }

lib/erlang/scoreboard.md

@@ -1,18 +1,18 @@
 # Erlang-on-SX Scoreboard
 
-**Total: 530 / 530 tests passing**
+**Total: 0 / 0 tests passing**
 
 |  | Suite | Pass | Total |
 |---|---|---|---|
-| ✅ | 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 |
+| ✅ | 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 |
 
 
 Generated by `lib/erlang/conformance.sh`.

lib/fiber.sx

@@ -0,0 +1,44 @@
+; lib/fiber.sx — pure SX fiber library using call/cc
+;
+; A fiber is a cooperative coroutine with true suspension (no eager
+; pre-execution). Each fiber is a dict {:resume fn :done? fn}.
+;
+; make-fiber body   → fiber dict
+;   body = (fn (yield init-val) ...)  — body receives yield + first resume val
+;   yield = (fn (val) ...)            — suspends fiber, returns val to resumer
+;
+; fiber-resume f v  → next yielded value, or nil when body returns
+; fiber-done? f     → true after body has returned
+
+(define make-fiber
+  (fn (body)
+    (let
+      ((resume-k nil)
+        (caller-k nil)
+        (done false))
+      (let
+        ((yield
+            (fn (val)
+              (call/cc
+                (fn (k)
+                  (set! resume-k k)
+                  (caller-k val))))))
+        {:resume
+         (fn (val)
+           (if
+             done
+             nil
+             (call/cc
+               (fn (k)
+                 (set! caller-k k)
+                 (if
+                   (nil? resume-k)
+                   (begin
+                     (body yield val)
+                     (set! done true)
+                     (k nil))
+                   (resume-k val))))))
+         :done? (fn () done)}))))
+
+(define fiber-resume (fn (f v) ((get f :resume) v)))
+(define fiber-done?  (fn (f) ((get f :done?))))

lib/forth/ans-tests/README.md

@@ -1,14 +0,0 @@
-ANS Forth conformance tests — vendored from
-https://github.com/gerryjackson/forth2012-test-suite (master, commit-locked
-on first fetch: 2026-04-24).
-
-Files in this directory are pristine copies of upstream — do not edit them.
-They are consumed by the conformance runner in `lib/forth/conformance.sh`.
-
-- `tester.fr` — John Hayes' test harness (`T{ ... -> ... }T`). (C) 1995
-  Johns Hopkins APL, distributable under its notice.
-- `core.fr` — Core word set tests (Hayes, ~1000 lines).
-- `coreexttest.fth` — Core Extension tests (Gerry Jackson).
-
-Only `core.fr` is expected to run green end-to-end for Phase 3; the others
-stay parked until later phases.

lib/forth/ans-tests/coreexttest.fth

@@ -1,775 +0,0 @@
-\ To test the ANS Forth Core Extension word set
-
-\ This program was written by Gerry Jackson in 2006, with contributions from
-\ others where indicated, and is in the public domain - it can be distributed
-\ and/or modified in any way but please retain this notice.
-
-\ This program is distributed in the hope that it will be useful,
-\ but WITHOUT ANY WARRANTY; without even the implied warranty of
-\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
-\ The tests are not claimed to be comprehensive or correct 
-
-\ ------------------------------------------------------------------------------
-\ Version 0.15 1 August 2025 Added two tests to VALUE
-\         0.14 21 July 2022 Updated first line of BUFFER: test as recommended
-\              in issue 32
-\         0.13 28 October 2015
-\              Replace <FALSE> and <TRUE> with FALSE and TRUE to avoid
-\              dependence on Core tests
-\              Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth
-\              Use of 2VARIABLE (from optional wordset) replaced with CREATE.
-\              Minor lower to upper case conversions.
-\              Calls to COMPARE replaced by S= (in utilities.fth) to avoid use
-\              of a word from an optional word set.
-\              UNUSED tests revised as UNUSED UNUSED = may return FALSE when an
-\              implementation has the data stack sharing unused dataspace.
-\              Double number input dependency removed from the HOLDS tests.
-\              Minor case sensitivities removed in definition names.
-\         0.11 25 April 2015
-\              Added tests for PARSE-NAME HOLDS BUFFER:
-\              S\" tests added
-\              DEFER IS ACTION-OF DEFER! DEFER@ tests added
-\              Empty CASE statement test added
-\              [COMPILE] tests removed because it is obsolescent in Forth 2012
-\         0.10 1 August 2014
-\             Added tests contributed by James Bowman for:
-\                <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R>
-\                HEX WITHIN UNUSED AGAIN MARKER
-\             Added tests for:
-\                .R U.R ERASE PAD REFILL SOURCE-ID 
-\             Removed ABORT from NeverExecuted to enable Win32
-\             to continue after failure of RESTORE-INPUT.
-\             Removed max-intx which is no longer used.
-\         0.7 6 June 2012 Extra CASE test added
-\         0.6 1 April 2012 Tests placed in the public domain.
-\             SAVE-INPUT & RESTORE-INPUT tests, position
-\             of T{ moved so that tests work with ttester.fs
-\             CONVERT test deleted - obsolete word removed from Forth 200X
-\             IMMEDIATE VALUEs tested
-\             RECURSE with :NONAME tested
-\             PARSE and .( tested
-\             Parsing behaviour of C" added
-\         0.5 14 September 2011 Removed the double [ELSE] from the
-\             initial SAVE-INPUT & RESTORE-INPUT test
-\         0.4 30 November 2009  max-int replaced with max-intx to
-\             avoid redefinition warnings.
-\         0.3  6 March 2009 { and } replaced with T{ and }T
-\                           CONVERT test now independent of cell size
-\         0.2  20 April 2007 ANS Forth words changed to upper case
-\                            Tests qd3 to qd6 by Reinhold Straub
-\         0.1  Oct 2006 First version released
-\ -----------------------------------------------------------------------------
-\ The tests are based on John Hayes test program for the core word set
-
-\ Words tested in this file are:
-\     .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE
-\     ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL
-\     RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED
-\     VALUE WITHIN [COMPILE]
-
-\ Words not tested or partially tested:
-\     \ because it has been extensively used already and is, hence, unnecessary
-\     REFILL and SOURCE-ID from the user input device which are not possible
-\     when testing from a file such as this one
-\     UNUSED (partially tested) as the value returned is system dependent
-\     Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been
-\     removed from the Forth 2012 standard
-
-\ Results from words that output to the user output device have to visually
-\ checked for correctness. These are .R U.R .(
-
-\ -----------------------------------------------------------------------------
-\ Assumptions & dependencies:
-\     - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been
-\       included prior to this file
-\     - the Core word set available
-\ -----------------------------------------------------------------------------
-TESTING Core Extension words
-
-DECIMAL
-
-TESTING TRUE FALSE
-
-T{ TRUE  -> 0 INVERT }T
-T{ FALSE -> 0 }T
-
-\ -----------------------------------------------------------------------------
-TESTING <> U>   (contributed by James Bowman)
-
-T{ 0 0 <> -> FALSE }T
-T{ 1 1 <> -> FALSE }T
-T{ -1 -1 <> -> FALSE }T
-T{ 1 0 <> -> TRUE }T
-T{ -1 0 <> -> TRUE }T
-T{ 0 1 <> -> TRUE }T
-T{ 0 -1 <> -> TRUE }T
-
-T{ 0 1 U> -> FALSE }T
-T{ 1 2 U> -> FALSE }T
-T{ 0 MID-UINT U> -> FALSE }T
-T{ 0 MAX-UINT U> -> FALSE }T
-T{ MID-UINT MAX-UINT U> -> FALSE }T
-T{ 0 0 U> -> FALSE }T
-T{ 1 1 U> -> FALSE }T
-T{ 1 0 U> -> TRUE }T
-T{ 2 1 U> -> TRUE }T
-T{ MID-UINT 0 U> -> TRUE }T
-T{ MAX-UINT 0 U> -> TRUE }T
-T{ MAX-UINT MID-UINT U> -> TRUE }T
-
-\ -----------------------------------------------------------------------------
-TESTING 0<> 0>   (contributed by James Bowman)
-
-T{ 0 0<> -> FALSE }T
-T{ 1 0<> -> TRUE }T
-T{ 2 0<> -> TRUE }T
-T{ -1 0<> -> TRUE }T
-T{ MAX-UINT 0<> -> TRUE }T
-T{ MIN-INT 0<> -> TRUE }T
-T{ MAX-INT 0<> -> TRUE }T
-
-T{ 0 0> -> FALSE }T
-T{ -1 0> -> FALSE }T
-T{ MIN-INT 0> -> FALSE }T
-T{ 1 0> -> TRUE }T
-T{ MAX-INT 0> -> TRUE }T
-
-\ -----------------------------------------------------------------------------
-TESTING NIP TUCK ROLL PICK   (contributed by James Bowman)
-
-T{ 1 2 NIP -> 2 }T
-T{ 1 2 3 NIP -> 1 3 }T
-
-T{ 1 2 TUCK -> 2 1 2 }T
-T{ 1 2 3 TUCK -> 1 3 2 3 }T
-
-T{ : RO5 100 200 300 400 500 ; -> }T
-T{ RO5 3 ROLL -> 100 300 400 500 200 }T
-T{ RO5 2 ROLL -> RO5 ROT }T
-T{ RO5 1 ROLL -> RO5 SWAP }T
-T{ RO5 0 ROLL -> RO5 }T
-
-T{ RO5 2 PICK -> 100 200 300 400 500 300 }T
-T{ RO5 1 PICK -> RO5 OVER }T
-T{ RO5 0 PICK -> RO5 DUP }T
-
-\ -----------------------------------------------------------------------------
-TESTING 2>R 2R@ 2R>   (contributed by James Bowman)
-
-T{ : RR0 2>R 100 R> R> ; -> }T
-T{ 300 400 RR0 -> 100 400 300 }T
-T{ 200 300 400 RR0 -> 200 100 400 300 }T
-
-T{ : RR1 2>R 100 2R@ R> R> ; -> }T
-T{ 300 400 RR1 -> 100 300 400 400 300 }T
-T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T
-
-T{ : RR2 2>R 100 2R> ; -> }T
-T{ 300 400 RR2 -> 100 300 400 }T
-T{ 200 300 400 RR2 -> 200 100 300 400 }T
-
-\ -----------------------------------------------------------------------------
-TESTING HEX   (contributed by James Bowman)
-
-T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T
-
-\ -----------------------------------------------------------------------------
-TESTING WITHIN   (contributed by James Bowman)
-
-T{ 0 0 0 WITHIN -> FALSE }T
-T{ 0 0 MID-UINT WITHIN -> TRUE }T
-T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T
-T{ 0 0 MAX-UINT WITHIN -> TRUE }T
-T{ 0 MID-UINT 0 WITHIN -> FALSE }T
-T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T
-T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T
-T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T
-T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T
-T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T
-T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
-T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T
-T{ 0 MAX-UINT 0 WITHIN -> FALSE }T
-T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T
-T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T
-T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T
-T{ MID-UINT 0 0 WITHIN -> FALSE }T
-T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T
-T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T
-T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T
-T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T
-T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T
-T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T
-T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T
-T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T
-T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T
-T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
-T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T
-T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T
-T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T
-T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T
-T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T
-T{ MID-UINT+1 0 0 WITHIN -> FALSE }T
-T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T
-T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T
-T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T
-T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T
-T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T
-T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T
-T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T
-T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T
-T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T
-T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
-T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T
-T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T
-T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T
-T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T
-T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T
-T{ MAX-UINT 0 0 WITHIN -> FALSE }T
-T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T
-T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T
-T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T
-T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T
-T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T
-T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T
-T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T
-T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T
-T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T
-T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T
-T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T
-T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T
-T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T
-T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T
-T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T
-
-T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T
-T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T
-T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T
-T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T
-T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T
-T{ MIN-INT 0 0 WITHIN -> FALSE }T
-T{ MIN-INT 0 1 WITHIN -> FALSE }T
-T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T
-T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T
-T{ MIN-INT 1 0 WITHIN -> TRUE }T
-T{ MIN-INT 1 1 WITHIN -> FALSE }T
-T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T
-T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T
-T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T
-T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T
-T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T
-T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T
-T{ 0 MIN-INT 0 WITHIN -> FALSE }T
-T{ 0 MIN-INT 1 WITHIN -> TRUE }T
-T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T
-T{ 0 0 MIN-INT WITHIN -> TRUE }T
-T{ 0 0 0 WITHIN -> FALSE }T
-T{ 0 0 1 WITHIN -> TRUE }T
-T{ 0 0 MAX-INT WITHIN -> TRUE }T
-T{ 0 1 MIN-INT WITHIN -> FALSE }T
-T{ 0 1 0 WITHIN -> FALSE }T
-T{ 0 1 1 WITHIN -> FALSE }T
-T{ 0 1 MAX-INT WITHIN -> FALSE }T
-T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T
-T{ 0 MAX-INT 0 WITHIN -> FALSE }T
-T{ 0 MAX-INT 1 WITHIN -> TRUE }T
-T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T
-T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T
-T{ 1 MIN-INT 0 WITHIN -> FALSE }T
-T{ 1 MIN-INT 1 WITHIN -> FALSE }T
-T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T
-T{ 1 0 MIN-INT WITHIN -> TRUE }T
-T{ 1 0 0 WITHIN -> FALSE }T
-T{ 1 0 1 WITHIN -> FALSE }T
-T{ 1 0 MAX-INT WITHIN -> TRUE }T
-T{ 1 1 MIN-INT WITHIN -> TRUE }T
-T{ 1 1 0 WITHIN -> TRUE }T
-T{ 1 1 1 WITHIN -> FALSE }T
-T{ 1 1 MAX-INT WITHIN -> TRUE }T
-T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T
-T{ 1 MAX-INT 0 WITHIN -> FALSE }T
-T{ 1 MAX-INT 1 WITHIN -> FALSE }T
-T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T
-T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T
-T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T
-T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T
-T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T
-T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T
-T{ MAX-INT 0 0 WITHIN -> FALSE }T
-T{ MAX-INT 0 1 WITHIN -> FALSE }T
-T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T
-T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T
-T{ MAX-INT 1 0 WITHIN -> TRUE }T
-T{ MAX-INT 1 1 WITHIN -> FALSE }T
-T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T
-T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T
-T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T
-T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T
-T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T
-
-\ -----------------------------------------------------------------------------
-TESTING UNUSED  (contributed by James Bowman & Peter Knaggs)
-
-VARIABLE UNUSED0
-T{ UNUSED DROP -> }T                  
-T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T
-T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ =
-         -> TRUE }T  \ aligned -> unaligned
-T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T  \ unaligned -> ?
-
-\ -----------------------------------------------------------------------------
-TESTING AGAIN   (contributed by James Bowman)
-
-T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T
-T{ AG0 -> 707 }T
-
-\ -----------------------------------------------------------------------------
-TESTING MARKER   (contributed by James Bowman)
-
-T{ : MA? BL WORD FIND NIP 0<> ; -> }T
-T{ MARKER MA0 -> }T
-T{ : MA1 111 ; -> }T
-T{ MARKER MA2 -> }T
-T{ : MA1 222 ; -> }T
-T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T
-T{ MA1 MA2 MA1 -> 222 111 }T
-T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T
-T{ MA0 -> }T
-T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T
-
-\ -----------------------------------------------------------------------------
-TESTING ?DO
-
-: QD ?DO I LOOP ;
-T{ 789 789 QD -> }T
-T{ -9876 -9876 QD -> }T
-T{ 5 0 QD -> 0 1 2 3 4 }T
-
-: QD1 ?DO I 10 +LOOP ;
-T{ 50 1 QD1 -> 1 11 21 31 41 }T
-T{ 50 0 QD1 -> 0 10 20 30 40 }T
-
-: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ;
-T{ 5 -1 QD2 -> -1 0 1 2 3 }T
-
-: QD3 ?DO I 1 +LOOP ;
-T{ 4  4 QD3 -> }T
-T{ 4  1 QD3 -> 1 2 3 }T
-T{ 2 -1 QD3 -> -1 0 1 }T
-
-: QD4 ?DO I -1 +LOOP ;
-T{  4 4 QD4 -> }T
-T{  1 4 QD4 -> 4 3 2 1 }T
-T{ -1 2 QD4 -> 2 1 0 -1 }T
-
-: QD5 ?DO I -10 +LOOP ;
-T{   1 50 QD5 -> 50 40 30 20 10 }T
-T{   0 50 QD5 -> 50 40 30 20 10 0 }T
-T{ -25 10 QD5 -> 10 0 -10 -20 }T
-
-VARIABLE ITERS
-VARIABLE INCRMNT
-
-: QD6 ( limit start increment -- )
-   INCRMNT !
-   0 ITERS !
-   ?DO
-      1 ITERS +!
-      I
-      ITERS @  6 = IF LEAVE THEN
-      INCRMNT @
-   +LOOP ITERS @
-;
-
-T{  4  4 -1 QD6 -> 0 }T
-T{  1  4 -1 QD6 -> 4 3 2 1 4 }T
-T{  4  1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T
-T{  4  1  0 QD6 -> 1 1 1 1 1 1 6 }T
-T{  0  0  0 QD6 -> 0 }T
-T{  1  4  0 QD6 -> 4 4 4 4 4 4 6 }T
-T{  1  4  1 QD6 -> 4 5 6 7 8 9 6 }T
-T{  4  1  1 QD6 -> 1 2 3 3 }T
-T{  4  4  1 QD6 -> 0 }T
-T{  2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T
-T{ -1  2 -1 QD6 -> 2 1 0 -1 4 }T
-T{  2 -1  0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T
-T{ -1  2  0 QD6 -> 2 2 2 2 2 2 6 }T
-T{ -1  2  1 QD6 -> 2 3 4 5 6 7 6 }T
-T{  2 -1  1 QD6 -> -1 0 1 3 }T
-
-\ -----------------------------------------------------------------------------
-TESTING BUFFER:
-
-T{ 2 CELLS BUFFER: BUF:TEST -> }T
-T{ BUF:TEST DUP ALIGNED = -> TRUE }T
-T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T
-T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T
-
-\ -----------------------------------------------------------------------------
-TESTING VALUE TO
-
-T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T
-T{ VAL1 -> 111 }T
-T{ VAL2 -> -999 }T
-T{ 222 TO VAL1 -> }T
-T{ VAL1 -> 222 }T
-T{ : VD1 VAL1 ; -> }T
-T{ VD1 -> 222 }T
-T{ : VD2 TO VAL2 ; -> }T
-T{ VAL2 -> -999 }T
-T{ -333 VD2 -> }T
-T{ VAL2 -> -333 }T
-T{ VAL1 -> 222 }T
-T{ 444 TO VAL1 -> }T
-T{ VD1 -> 444 }T
-T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T
-T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T
-
-\ -----------------------------------------------------------------------------
-TESTING CASE OF ENDOF ENDCASE
-
-: CS1 CASE 1 OF 111 ENDOF
-           2 OF 222 ENDOF
-           3 OF 333 ENDOF
-           >R 999 R>
-      ENDCASE
-;
-
-T{ 1 CS1 -> 111 }T
-T{ 2 CS1 -> 222 }T
-T{ 3 CS1 -> 333 }T
-T{ 4 CS1 -> 999 }T
-
-\ Nested CASE's
-
-: CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF
-                            2 OF 200 ENDOF
-                           >R -300 R>
-                    ENDCASE
-                 ENDOF
-              -2 OF CASE R@ 1 OF -99  ENDOF
-                            >R -199 R>
-                    ENDCASE
-                 ENDOF
-                 >R 299 R>
-         ENDCASE R> DROP
-;
-
-T{ -1 1 CS2 ->  100 }T
-T{ -1 2 CS2 ->  200 }T
-T{ -1 3 CS2 -> -300 }T
-T{ -2 1 CS2 -> -99  }T
-T{ -2 2 CS2 -> -199 }T
-T{  0 2 CS2 ->  299 }T
-
-\ Boolean short circuiting using CASE
-
-: CS3  ( N1 -- N2 )
-   CASE 1- FALSE OF 11 ENDOF
-        1- FALSE OF 22 ENDOF
-        1- FALSE OF 33 ENDOF
-        44 SWAP
-   ENDCASE
-;
-
-T{ 1 CS3 -> 11 }T
-T{ 2 CS3 -> 22 }T
-T{ 3 CS3 -> 33 }T
-T{ 9 CS3 -> 44 }T
-
-\ Empty CASE statements with/without default
-
-T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T
-T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T
-T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T
-T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T
-
-\ -----------------------------------------------------------------------------
-TESTING :NONAME RECURSE
-
-VARIABLE NN1
-VARIABLE NN2
-:NONAME 1234 ; NN1 !
-:NONAME 9876 ; NN2 !
-T{ NN1 @ EXECUTE -> 1234 }T
-T{ NN2 @ EXECUTE -> 9876 }T
-
-T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ;
-   CONSTANT RN1 -> }T
-T{ 0 RN1 EXECUTE -> 0 }T
-T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T
-
-:NONAME  ( n -- n1 )    \ Multiple RECURSEs in one definition
-   1- DUP
-   CASE 0 OF EXIT ENDOF
-        1 OF 11 SWAP RECURSE ENDOF
-        2 OF 22 SWAP RECURSE ENDOF
-        3 OF 33 SWAP RECURSE ENDOF
-        DROP ABS RECURSE EXIT
-   ENDCASE
-; CONSTANT RN2
-
-T{  1 RN2 EXECUTE -> 0 }T
-T{  2 RN2 EXECUTE -> 11 0 }T
-T{  4 RN2 EXECUTE -> 33 22 11 0 }T
-T{ 25 RN2 EXECUTE -> 33 22 11 0 }T
-
-\ -----------------------------------------------------------------------------
-TESTING C"
-
-T{ : CQ1 C" 123" ; -> }T
-T{ CQ1 COUNT EVALUATE -> 123 }T
-T{ : CQ2 C" " ; -> }T
-T{ CQ2 COUNT EVALUATE -> }T
-T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T
-
-\ -----------------------------------------------------------------------------
-TESTING COMPILE,
-
-:NONAME DUP + ; CONSTANT DUP+
-T{ : Q DUP+ COMPILE, ; -> }T
-T{ : AS1 [ Q ] ; -> }T
-T{ 123 AS1 -> 246 }T
-
-\ -----------------------------------------------------------------------------
-\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source
-
-TESTING SAVE-INPUT and RESTORE-INPUT with a string source
-
-VARIABLE SI_INC 0 SI_INC !
-
-: SI1
-   SI_INC @ >IN +!
-   15 SI_INC !
-;
-
-: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ;
-
-T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T
-
-\ -----------------------------------------------------------------------------
-TESTING .(
-
-CR CR .( Output from .() 
-T{ CR .( You should see -9876: ) -9876 . -> }T
-T{ CR .( and again: ).( -9876)CR -> }T
-
-CR CR .( On the next 2 lines you should see First then Second messages:)
-T{ : DOTP  CR ." Second message via ." [CHAR] " EMIT    \ Check .( is immediate
-     [ CR ] .( First message via .( ) ; DOTP -> }T
-CR CR
-T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T
-
-\ -----------------------------------------------------------------------------
-TESTING .R and U.R - has to handle different cell sizes
-
-\ Create some large integers just below/above MAX and Min INTs
-MAX-INT 73 79 */ CONSTANT LI1
-MIN-INT 71 73 */ CONSTANT LI2
-
-LI1 0 <# #S #> NIP CONSTANT LENLI1
-
-: (.R&U.R)  ( u1 u2 -- )  \ u1 <= string length, u2 is required indentation
-   TUCK + >R
-   LI1 OVER SPACES  . CR R@    LI1 SWAP  .R CR
-   LI2 OVER SPACES  . CR R@ 1+ LI2 SWAP  .R CR
-   LI1 OVER SPACES U. CR R@    LI1 SWAP U.R CR
-   LI2 SWAP SPACES U. CR R>    LI2 SWAP U.R CR
-;
-
-: .R&U.R  ( -- )
-   CR ." You should see lines duplicated:" CR
-   ." indented by 0 spaces" CR 0      0 (.R&U.R) CR
-   ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width
-   ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR
-;
-
-CR CR .( Output from .R and U.R)
-T{ .R&U.R -> }T
-
-\ -----------------------------------------------------------------------------
-TESTING PAD ERASE
-\ Must handle different size characters i.e. 1 CHARS >= 1 
-
-84 CONSTANT CHARS/PAD      \ Minimum size of PAD in chars
-CHARS/PAD CHARS CONSTANT AUS/PAD
-: CHECKPAD  ( caddr u ch -- f )  \ f = TRUE if u chars = ch
-   SWAP 0
-   ?DO
-      OVER I CHARS + C@ OVER <>
-      IF 2DROP UNLOOP FALSE EXIT THEN
-   LOOP  
-   2DROP TRUE
-;
-
-T{ PAD DROP -> }T
-T{ 0 INVERT PAD C! -> }T
-T{ PAD C@ CONSTANT MAXCHAR -> }T
-T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T
-T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T
-T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T
-T{ PAD 43 CHARS + 9 CHARS ERASE -> }T
-T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T
-T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T
-T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T
-
-\ Check that use of WORD and pictured numeric output do not corrupt PAD
-\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively
-\ where n is number of bits per cell
-
-PAD CHARS/PAD ERASE
-2 BASE !
-MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP
-DECIMAL
-BL WORD 12345678123456781234567812345678 DROP
-T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T
-
-\ -----------------------------------------------------------------------------
-TESTING PARSE
-
-T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T
-T{ CHAR ^ PARSE  23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T
-: PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ;
-T{ PA1 3456
-   DUP ROT ROT EVALUATE -> 4 3456 }T
-T{ CHAR A PARSE A SWAP DROP -> 0 }T
-T{ CHAR Z PARSE
-   SWAP DROP -> 0 }T
-T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T
- 
-\ -----------------------------------------------------------------------------
-TESTING PARSE-NAME  (Forth 2012)
-\ Adapted from the PARSE-NAME RfD tests
-
-T{ PARSE-NAME abcd  STR1  S= -> TRUE }T        \ No leading spaces
-T{ PARSE-NAME      abcde STR2 S= -> TRUE }T    \ Leading spaces
-
-\ Test empty parse area, new lines are necessary
-T{ PARSE-NAME
-  NIP -> 0 }T
-\ Empty parse area with spaces after PARSE-NAME
-T{ PARSE-NAME         
-  NIP -> 0 }T
-
-T{ : PARSE-NAME-TEST ( "name1" "name2" -- n )
-    PARSE-NAME PARSE-NAME S= ; -> }T
-T{ PARSE-NAME-TEST abcd abcd  -> TRUE }T
-T{ PARSE-NAME-TEST abcd   abcd  -> TRUE }T  \ Leading spaces
-T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T
-T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T
-T{ PARSE-NAME-TEST abcde abcde
-   -> TRUE }T         \ Parse to end of line
-T{ PARSE-NAME-TEST abcde           abcde         
-   -> TRUE }T         \ Leading and trailing spaces
-
-\ -----------------------------------------------------------------------------
-TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012)
-\ Adapted from the Forth 200X RfD tests
-
-T{ DEFER DEFER1 -> }T
-T{ : MY-DEFER DEFER ; -> }T
-T{ : IS-DEFER1 IS DEFER1 ; -> }T
-T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T
-T{ : DEF! DEFER! ; -> }T
-T{ : DEF@ DEFER@ ; -> }T
-
-T{ ' * ' DEFER1 DEFER! -> }T
-T{ 2 3 DEFER1 -> 6 }T
-T{ ' DEFER1 DEFER@ -> ' * }T
-T{ ' DEFER1 DEF@ -> ' * }T
-T{ ACTION-OF DEFER1 -> ' * }T
-T{ ACTION-DEFER1 -> ' * }T
-T{ ' + IS DEFER1 -> }T
-T{ 1 2 DEFER1 -> 3 }T
-T{ ' DEFER1 DEFER@ -> ' + }T
-T{ ' DEFER1 DEF@ -> ' + }T
-T{ ACTION-OF DEFER1 -> ' + }T
-T{ ACTION-DEFER1 -> ' + }T
-T{ ' - IS-DEFER1 -> }T
-T{ 1 2 DEFER1 -> -1 }T
-T{ ' DEFER1 DEFER@ -> ' - }T
-T{ ' DEFER1 DEF@ -> ' - }T
-T{ ACTION-OF DEFER1 -> ' - }T
-T{ ACTION-DEFER1 -> ' - }T
-
-T{ MY-DEFER DEFER2 -> }T
-T{ ' DUP IS DEFER2 -> }T
-T{ 1 DEFER2 -> 1 1 }T
-
-\ -----------------------------------------------------------------------------
-TESTING HOLDS  (Forth 2012)
-
-: HTEST S" Testing HOLDS" ;
-: HTEST2 S" works" ;
-: HTEST3 S" Testing HOLDS works 123" ;
-T{ 0 0 <#  HTEST HOLDS #> HTEST S= -> TRUE }T
-T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #>
-   HTEST3 S= -> TRUE }T
-T{ : HLD HOLDS ; -> }T
-T{ 0 0 <#  HTEST HLD #> HTEST S= -> TRUE }T
-
-\ -----------------------------------------------------------------------------
-TESTING REFILL SOURCE-ID
-\ REFILL and SOURCE-ID from the user input device can't be tested from a file,
-\ can only be tested from a string via EVALUATE
-
-T{ : RF1  S" REFILL" EVALUATE ; RF1 -> FALSE }T
-T{ : SID1  S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T
-
-\ ------------------------------------------------------------------------------
-TESTING S\"  (Forth 2012 compilation mode)
-\ Extended the Forth 200X RfD tests
-\ Note this tests the Core Ext definition of S\" which has unedfined
-\ interpretation semantics. S\" in interpretation mode is tested in the tests on
-\ the File-Access word set
-
-T{ : SSQ1 S\" abc" S" abc" S= ; -> }T  \ No escapes
-T{ SSQ1 -> TRUE }T
-T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T    \ Empty string
-
-T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T
-T{ SSQ3 SWAP DROP          ->  20 }T    \ String length
-T{ SSQ3 DROP            C@ ->   7 }T    \ \a   BEL  Bell
-T{ SSQ3 DROP  1 CHARS + C@ ->   8 }T    \ \b   BS   Backspace
-T{ SSQ3 DROP  2 CHARS + C@ ->  27 }T    \ \e   ESC  Escape
-T{ SSQ3 DROP  3 CHARS + C@ ->  12 }T    \ \f   FF   Form feed
-T{ SSQ3 DROP  4 CHARS + C@ ->  10 }T    \ \l   LF   Line feed
-T{ SSQ3 DROP  5 CHARS + C@ ->  13 }T    \ \m        CR of CR/LF pair
-T{ SSQ3 DROP  6 CHARS + C@ ->  10 }T    \           LF of CR/LF pair
-T{ SSQ3 DROP  7 CHARS + C@ ->  34 }T    \ \q   "    Double Quote
-T{ SSQ3 DROP  8 CHARS + C@ ->  13 }T    \ \r   CR   Carriage Return
-T{ SSQ3 DROP  9 CHARS + C@ ->   9 }T    \ \t   TAB  Horizontal Tab
-T{ SSQ3 DROP 10 CHARS + C@ ->  11 }T    \ \v   VT   Vertical Tab
-T{ SSQ3 DROP 11 CHARS + C@ ->  15 }T    \ \x0F      Given Char
-T{ SSQ3 DROP 12 CHARS + C@ ->  48 }T    \ 0    0    Digit follow on
-T{ SSQ3 DROP 13 CHARS + C@ ->  31 }T    \ \x1F      Given Char
-T{ SSQ3 DROP 14 CHARS + C@ ->  97 }T    \ a    a    Hex follow on
-T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T    \ \xaB      Insensitive Given Char
-T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T    \ x    x    Non hex follow on
-T{ SSQ3 DROP 17 CHARS + C@ ->   0 }T    \ \z   NUL  No Character
-T{ SSQ3 DROP 18 CHARS + C@ ->  34 }T    \ \"   "    Double Quote
-T{ SSQ3 DROP 19 CHARS + C@ ->  92 }T    \ \\   \    Back Slash
-
-\ The above does not test \n as this is a system dependent value.
-\ Check it displays a new line
-CR .( The next test should display:)
-CR .( One line...)
-CR .( another line)
-T{ : SSQ4 S\" \nOne line...\nanotherLine\n" TYPE ; SSQ4 -> }T
-
-\ Test bare escapable characters appear as themselves
-T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T
-
-T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour
-
-T{ : SSQ7  S\" 111 : SSQ8 S\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T
-T{ SSQ7 -> 111 222 333 }T
-T{ : SSQ9  S\" 11 : SSQ10 S\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T
-T{ SSQ9 -> 11 22 33 }T
-
-\ -----------------------------------------------------------------------------
-CORE-EXT-ERRORS SET-ERROR-COUNT
-
-CR .( End of Core Extension word tests) CR
-
-

lib/forth/ans-tests/tester.fr

@@ -1,66 +0,0 @@
-\ From: John Hayes S1I
-\ Subject: tester.fr
-\ Date: Mon, 27 Nov 95 13:10:09 PST  
-
-\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
-\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
-\ VERSION 1.2
-
-\ 24/11/2015 Replaced Core Ext word <> with = 0=
-\ 31/3/2015 Variable #ERRORS added and incremented for each error reported.
-\ 22/1/09 The words { and } have been changed to T{ and }T respectively to
-\ agree with the Forth 200X file ttester.fs. This avoids clashes with
-\ locals using { ... } and the FSL use of } 
-
-HEX
-
-\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
-\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
-VARIABLE VERBOSE
-   FALSE VERBOSE !
-\   TRUE VERBOSE !
-
-: EMPTY-STACK   \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
-   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
-
-VARIABLE #ERRORS 0 #ERRORS !
-
-: ERROR      \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
-      \ THE LINE THAT HAD THE ERROR.
-   CR TYPE SOURCE TYPE       \ DISPLAY LINE CORRESPONDING TO ERROR
-   EMPTY-STACK               \ THROW AWAY EVERY THING ELSE
-   #ERRORS @ 1 + #ERRORS !
-\   QUIT  \ *** Uncomment this line to QUIT on an error
-;
-
-VARIABLE ACTUAL-DEPTH         \ STACK RECORD
-CREATE ACTUAL-RESULTS 20 CELLS ALLOT
-
-: T{      \ ( -- ) SYNTACTIC SUGAR.
-   ;
-
-: ->      \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
-   DEPTH DUP ACTUAL-DEPTH !      \ RECORD DEPTH
-   ?DUP IF            \ IF THERE IS SOMETHING ON STACK
-      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
-   THEN ;
-
-: }T      \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
-      \ (ACTUAL) CONTENTS.
-   DEPTH ACTUAL-DEPTH @ = IF      \ IF DEPTHS MATCH
-      DEPTH ?DUP IF         \ IF THERE IS SOMETHING ON THE STACK
-         0  DO            \ FOR EACH STACK ITEM
-           ACTUAL-RESULTS I CELLS + @   \ COMPARE ACTUAL WITH EXPECTED
-           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN
-         LOOP
-      THEN
-   ELSE               \ DEPTH MISMATCH
-      S" WRONG NUMBER OF RESULTS: " ERROR
-   THEN ;
-
-: TESTING   \ ( -- ) TALKING COMMENT.
-  SOURCE VERBOSE @
-   IF DUP >R TYPE CR R> >IN !
-   ELSE >IN ! DROP [CHAR] * EMIT
-   THEN ;
-

lib/forth/conformance.sh

@@ -1,170 +0,0 @@
-#!/usr/bin/env bash
-# Run the Hayes/Gerry-Jackson Core conformance suite against our Forth
-# interpreter and emit scoreboard.json + scoreboard.md.
-#
-# Method:
-#   1. Preprocess lib/forth/ans-tests/core.fr — strip \ comments, ( ... )
-#      comments, and TESTING … metadata lines.
-#   2. Split into chunks ending at each `}T` so an error in one test
-#      chunk doesn't abort the run.
-#   3. Emit an SX file that exposes those chunks as a list.
-#   4. Run our Forth + hayes-runner under sx_server; record pass/fail/error.
-
-set -e
-FORTH_DIR="$(cd "$(dirname "$0")" && pwd)"
-ROOT="$(cd "$FORTH_DIR/../.." && pwd)"
-SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
-SOURCE="$FORTH_DIR/ans-tests/core.fr"
-OUT_JSON="$FORTH_DIR/scoreboard.json"
-OUT_MD="$FORTH_DIR/scoreboard.md"
-TMP="$(mktemp -d)"
-PREPROC="$TMP/preproc.forth"
-CHUNKS_SX="$TMP/chunks.sx"
-
-cd "$ROOT"
-
-# 1. preprocess
-awk '
-{
-  line = $0
-  # protect POSTPONE \ so the comment-strip below leaves the literal \ alone
-  gsub(/POSTPONE[ \t]+\\/, "POSTPONE @@BS@@", line)
-  # strip leading/embedded \ line comments (must be \ followed by space or EOL)
-  gsub(/(^|[ \t])\\([ \t].*|$)/, " ", line)
-  # strip ( ... ) block comments that sit on one line
-  gsub(/\([^)]*\)/, " ", line)
-  # strip TESTING … metadata lines (rest of line, incl. bare TESTING)
-  sub(/TESTING([ \t].*)?$/, " ", line)
-  # restore the protected backslash
-  gsub(/@@BS@@/, "\\", line)
-  print line
-}' "$SOURCE" > "$PREPROC"
-
-# 2 + 3: split into chunks at each `}T` and emit as a SX file
-#
-# Cap chunks via MAX_CHUNKS env (default 638 = full Hayes Core). Lower
-# it temporarily if later tests regress into an infinite loop while you
-# are iterating on primitives.
-MAX_CHUNKS="${MAX_CHUNKS:-638}"
-
-MAX_CHUNKS="$MAX_CHUNKS" python3 - "$PREPROC" "$CHUNKS_SX" <<'PY'
-import os, re, sys
-preproc_path, out_path = sys.argv[1], sys.argv[2]
-max_chunks = int(os.environ.get("MAX_CHUNKS", "590"))
-text = open(preproc_path).read()
-# keep the `}T` attached to the preceding chunk
-parts = re.split(r'(\}T)', text)
-chunks = []
-buf = ""
-for p in parts:
-    buf += p
-    if p == "}T":
-        s = buf.strip()
-        if s:
-            chunks.append(s)
-        buf = ""
-if buf.strip():
-    chunks.append(buf.strip())
-chunks = chunks[:max_chunks]
-
-def esc(s):
-    s = s.replace('\\', '\\\\').replace('"', '\\"')
-    s = s.replace('\r', ' ').replace('\n', ' ')
-    s = re.sub(r'\s+', ' ', s).strip()
-    return s
-
-with open(out_path, "w") as f:
-    f.write("(define hayes-chunks (list\n")
-    for c in chunks:
-        f.write('  "' + esc(c) + '"\n')
-    f.write("))\n\n")
-    f.write("(define\n")
-    f.write("  hayes-run-all\n")
-    f.write("  (fn\n")
-    f.write("    ()\n")
-    f.write("    (hayes-reset!)\n")
-    f.write("    (let ((s (hayes-boot)))\n")
-    f.write("      (for-each (fn (c) (hayes-run-chunk s c)) hayes-chunks))\n")
-    f.write("    (hayes-summary)))\n")
-PY
-
-# 4. run it
-OUT=$(printf '(epoch 1)\n(load "lib/forth/runtime.sx")\n(epoch 2)\n(load "lib/forth/reader.sx")\n(epoch 3)\n(load "lib/forth/interpreter.sx")\n(epoch 4)\n(load "lib/forth/compiler.sx")\n(epoch 5)\n(load "lib/forth/hayes-runner.sx")\n(epoch 6)\n(load "%s")\n(epoch 7)\n(eval "(hayes-run-all)")\n' "$CHUNKS_SX" \
-  | timeout 180 "$SX_SERVER" 2>&1)
-STATUS=$?
-
-SUMMARY=$(printf '%s\n' "$OUT" | awk '/^\{:pass / {print; exit}')
-PASS=$(printf '%s' "$SUMMARY" | sed -n 's/.*:pass \([0-9-]*\).*/\1/p')
-FAIL=$(printf '%s' "$SUMMARY" | sed -n 's/.*:fail \([0-9-]*\).*/\1/p')
-ERR=$(printf '%s' "$SUMMARY" | sed -n 's/.*:error \([0-9-]*\).*/\1/p')
-TOTAL=$(printf '%s' "$SUMMARY" | sed -n 's/.*:total \([0-9-]*\).*/\1/p')
-CHUNK_COUNT=$(grep -c '^  "' "$CHUNKS_SX" || echo 0)
-TOTAL_AVAILABLE=$(grep -c '}T' "$PREPROC" || echo 0)
-
-NOW="$(date -u +%Y-%m-%dT%H:%M:%SZ)"
-
-if [ -z "$PASS" ]; then
-  PASS=0; FAIL=0; ERR=0; TOTAL=0
-  NOTE="runner halted before completing (timeout or SX error)"
-else
-  NOTE="completed"
-fi
-
-PCT=0
-if [ "$TOTAL" -gt 0 ]; then
-  PCT=$((PASS * 100 / TOTAL))
-fi
-
-cat > "$OUT_JSON" <<JSON
-{
-  "source": "gerryjackson/forth2012-test-suite src/core.fr",
-  "generated_at": "$NOW",
-  "chunks_available": $TOTAL_AVAILABLE,
-  "chunks_fed": $CHUNK_COUNT,
-  "total": $TOTAL,
-  "pass": $PASS,
-  "fail": $FAIL,
-  "error": $ERR,
-  "percent": $PCT,
-  "note": "$NOTE"
-}
-JSON
-
-cat > "$OUT_MD" <<MD
-# Forth Hayes Core scoreboard
-
-| metric            | value |
-| ----------------- | ----: |
-| chunks available  | $TOTAL_AVAILABLE |
-| chunks fed        | $CHUNK_COUNT |
-| total             | $TOTAL |
-| pass              | $PASS |
-| fail              | $FAIL |
-| error             | $ERR |
-| percent           | ${PCT}% |
-
-- **Source**: \`gerryjackson/forth2012-test-suite\` \`src/core.fr\`
-- **Generated**: $NOW
-- **Note**: $NOTE
-
-A "chunk" is any preprocessed segment ending at a \`}T\` (every Hayes test
-is one chunk, plus the small declaration blocks between tests).
-The runner catches raised errors at chunk boundaries so one bad chunk
-does not abort the rest. \`error\` covers chunks that raised; \`fail\`
-covers tests whose \`->\` / \`}T\` comparison mismatched.
-
-### Chunk cap
-
-\`conformance.sh\` processes the first \`\$MAX_CHUNKS\` chunks (default
-**638**, i.e. the whole Hayes Core file). Lower the cap temporarily
-while iterating on primitives if a regression re-opens an infinite
-loop in later tests.
-MD
-
-echo "$SUMMARY"
-echo "Scoreboard: $OUT_JSON"
-echo "           $OUT_MD"
-
-if [ "$STATUS" -ne 0 ] && [ "$TOTAL" -eq 0 ]; then
-  exit 1
-fi

lib/forth/hayes-runner.sx

@@ -1,158 +0,0 @@
-;; Hayes conformance test runner.
-;; Installs T{ -> }T as Forth primitives that snapshot and compare dstack,
-;; plus stub TESTING / HEX / DECIMAL so the Hayes Core file can stream
-;; through the interpreter without halting on unsupported metadata words.
-
-(define hayes-pass 0)
-(define hayes-fail 0)
-(define hayes-error 0)
-(define hayes-start-depth 0)
-(define hayes-actual (list))
-(define hayes-actual-set false)
-(define hayes-failures (list))
-(define hayes-first-error "")
-(define hayes-error-hist (dict))
-
-(define
-  hayes-reset!
-  (fn
-    ()
-    (set! hayes-pass 0)
-    (set! hayes-fail 0)
-    (set! hayes-error 0)
-    (set! hayes-start-depth 0)
-    (set! hayes-actual (list))
-    (set! hayes-actual-set false)
-    (set! hayes-failures (list))
-    (set! hayes-first-error "")
-    (set! hayes-error-hist (dict))))
-
-(define
-  hayes-slice
-  (fn
-    (state base)
-    (let
-      ((n (- (forth-depth state) base)))
-      (if (<= n 0) (list) (take (get state "dstack") n)))))
-
-(define
-  hayes-truncate!
-  (fn
-    (state base)
-    (let
-      ((n (- (forth-depth state) base)))
-      (when (> n 0) (dict-set! state "dstack" (drop (get state "dstack") n))))))
-
-(define
-  hayes-install!
-  (fn
-    (state)
-    (forth-def-prim!
-      state
-      "T{"
-      (fn
-        (s)
-        (set! hayes-start-depth (forth-depth s))
-        (set! hayes-actual-set false)
-        (set! hayes-actual (list))))
-    (forth-def-prim!
-      state
-      "->"
-      (fn
-        (s)
-        (set! hayes-actual (hayes-slice s hayes-start-depth))
-        (set! hayes-actual-set true)
-        (hayes-truncate! s hayes-start-depth)))
-    (forth-def-prim!
-      state
-      "}T"
-      (fn
-        (s)
-        (let
-          ((expected (hayes-slice s hayes-start-depth)))
-          (hayes-truncate! s hayes-start-depth)
-          (if
-            (and hayes-actual-set (= expected hayes-actual))
-            (set! hayes-pass (+ hayes-pass 1))
-            (begin
-              (set! hayes-fail (+ hayes-fail 1))
-              (set!
-                hayes-failures
-                (concat
-                  hayes-failures
-                  (list
-                    (dict
-                      "kind"
-                      "fail"
-                      "expected"
-                      (str expected)
-                      "actual"
-                      (str hayes-actual))))))))))
-    (forth-def-prim! state "TESTING" (fn (s) nil))
-    ;; HEX/DECIMAL are real primitives now (runtime.sx) — no stub needed.
-    state))
-
-(define
-  hayes-boot
-  (fn () (let ((s (forth-boot))) (hayes-install! s) (hayes-reset!) s)))
-
-;; Run a single preprocessed chunk (string of Forth source) on the shared
-;; state. Catch any raised error and move on — the chunk boundary is a
-;; safe resume point.
-(define
-  hayes-bump-error-key!
-  (fn
-    (err)
-    (let
-      ((msg (str err)))
-      (let
-        ((space-idx (index-of msg " ")))
-        (let
-          ((key
-            (if
-              (> space-idx 0)
-              (substr msg 0 space-idx)
-              msg)))
-          (dict-set!
-            hayes-error-hist
-            key
-            (+ 1 (or (get hayes-error-hist key) 0))))))))
-
-(define
-  hayes-run-chunk
-  (fn
-    (state src)
-    (guard
-      (err
-        ((= 1 1)
-          (begin
-            (set! hayes-error (+ hayes-error 1))
-            (when
-              (= (len hayes-first-error) 0)
-              (set! hayes-first-error (str err)))
-            (hayes-bump-error-key! err)
-            (dict-set! state "dstack" (list))
-            (dict-set! state "rstack" (list))
-            (dict-set! state "compiling" false)
-            (dict-set! state "current-def" nil)
-            (dict-set! state "cstack" (list))
-            (dict-set! state "input" (list)))))
-      (forth-interpret state src))))
-
-(define
-  hayes-summary
-  (fn
-    ()
-    (dict
-      "pass"
-      hayes-pass
-      "fail"
-      hayes-fail
-      "error"
-      hayes-error
-      "total"
-      (+ (+ hayes-pass hayes-fail) hayes-error)
-      "first-error"
-      hayes-first-error
-      "error-hist"
-      hayes-error-hist)))

lib/forth/interpreter.sx

@@ -5,39 +5,7 @@
 
 (define
   forth-execute-word
-  (fn
-    (state word)
-    (dict-set! word "call-count" (+ 1 (or (get word "call-count") 0)))
-    (let ((body (get word "body"))) (body state))))
-
-(define
-  forth-hot-words
-  (fn
-    (state threshold)
-    (forth-hot-walk
-      (keys (get state "dict"))
-      (get state "dict")
-      threshold
-      (list))))
-
-(define
-  forth-hot-walk
-  (fn
-    (names dict threshold acc)
-    (if
-      (= (len names) 0)
-      acc
-      (let
-        ((n (first names)))
-        (let
-          ((w (get dict n)))
-          (let
-            ((c (or (get w "call-count") 0)))
-            (forth-hot-walk
-              (rest names)
-              dict
-              threshold
-              (if (>= c threshold) (cons (list n c) acc) acc))))))))
+  (fn (state word) (let ((body (get word "body"))) (body state))))
 
 (define
   forth-interpret-token
@@ -49,7 +17,7 @@
         (not (nil? w))
         (forth-execute-word state w)
         (let
-          ((n (forth-parse-number tok (get (get state "vars") "base"))))
+          ((n (forth-parse-number tok (get state "base"))))
           (if
             (not (nil? n))
             (forth-push state n)

lib/forth/scoreboard.json

@@ -1,12 +0,0 @@
-{
-  "source": "gerryjackson/forth2012-test-suite src/core.fr",
-  "generated_at": "2026-05-05T21:30:21Z",
-  "chunks_available": 638,
-  "chunks_fed": 638,
-  "total": 638,
-  "pass": 632,
-  "fail": 6,
-  "error": 0,
-  "percent": 99,
-  "note": "completed"
-}

lib/forth/scoreboard.md

@@ -1,28 +0,0 @@
-# Forth Hayes Core scoreboard
-
-| metric            | value |
-| ----------------- | ----: |
-| chunks available  | 638 |
-| chunks fed        | 638 |
-| total             | 638 |
-| pass              | 632 |
-| fail              | 6 |
-| error             | 0 |
-| percent           | 99% |
-
-- **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr`
-- **Generated**: 2026-05-05T21:30:21Z
-- **Note**: completed
-
-A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test
-is one chunk, plus the small declaration blocks between tests).
-The runner catches raised errors at chunk boundaries so one bad chunk
-does not abort the rest. `error` covers chunks that raised; `fail`
-covers tests whose `->` / `}T` comparison mismatched.
-
-### Chunk cap
-
-`conformance.sh` processes the first `$MAX_CHUNKS` chunks (default
-**638**, i.e. the whole Hayes Core file). Lower the cap temporarily
-while iterating on primitives if a regression re-opens an infinite
-loop in later tests.

lib/forth/tests/test-phase3.sx

@@ -1,239 +0,0 @@
-;; Phase 3 — control flow (IF/ELSE/THEN, BEGIN/UNTIL/WHILE/REPEAT/AGAIN,
-;; DO/LOOP, return stack). Grows as each control construct lands.
-
-(define forth-p3-passed 0)
-(define forth-p3-failed 0)
-(define forth-p3-failures (list))
-
-(define
-  forth-p3-assert
-  (fn
-    (label expected actual)
-    (if
-      (= expected actual)
-      (set! forth-p3-passed (+ forth-p3-passed 1))
-      (begin
-        (set! forth-p3-failed (+ forth-p3-failed 1))
-        (set!
-          forth-p3-failures
-          (concat
-            forth-p3-failures
-            (list
-              (str label ": expected " (str expected) " got " (str actual)))))))))
-
-(define
-  forth-p3-check-stack
-  (fn
-    (label src expected)
-    (let ((r (forth-run src))) (forth-p3-assert label expected (nth r 2)))))
-
-(define
-  forth-p3-if-tests
-  (fn
-    ()
-    (forth-p3-check-stack
-      "IF taken (-1)"
-      ": Q -1 IF 10 THEN ; Q"
-      (list 10))
-    (forth-p3-check-stack
-      "IF not taken (0)"
-      ": Q 0 IF 10 THEN ; Q"
-      (list))
-    (forth-p3-check-stack
-      "IF with non-zero truthy"
-      ": Q 42 IF 10 THEN ; Q"
-      (list 10))
-    (forth-p3-check-stack
-      "IF ELSE — true branch"
-      ": Q -1 IF 10 ELSE 20 THEN ; Q"
-      (list 10))
-    (forth-p3-check-stack
-      "IF ELSE — false branch"
-      ": Q 0 IF 10 ELSE 20 THEN ; Q"
-      (list 20))
-    (forth-p3-check-stack
-      "IF consumes flag"
-      ": Q IF 1 ELSE 2 THEN ; 0 Q"
-      (list 2))
-    (forth-p3-check-stack
-      "absolute value via IF"
-      ": ABS2 DUP 0 < IF NEGATE THEN ; -7 ABS2"
-      (list 7))
-    (forth-p3-check-stack
-      "abs leaves positive alone"
-      ": ABS2 DUP 0 < IF NEGATE THEN ; 7 ABS2"
-      (list 7))
-    (forth-p3-check-stack
-      "sign: negative"
-      ": SIGN DUP 0 < IF DROP -1 ELSE DROP 1 THEN ; -3 SIGN"
-      (list -1))
-    (forth-p3-check-stack
-      "sign: positive"
-      ": SIGN DUP 0 < IF DROP -1 ELSE DROP 1 THEN ; 3 SIGN"
-      (list 1))
-    (forth-p3-check-stack
-      "nested IF (both true)"
-      ": Q 1 IF 1 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q"
-      (list 10))
-    (forth-p3-check-stack
-      "nested IF (inner false)"
-      ": Q 1 IF 0 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q"
-      (list 20))
-    (forth-p3-check-stack
-      "nested IF (outer false)"
-      ": Q 0 IF 0 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q"
-      (list 30))
-    (forth-p3-check-stack
-      "IF before other ops"
-      ": Q 1 IF 5 ELSE 6 THEN 2 * ; Q"
-      (list 10))
-    (forth-p3-check-stack
-      "IF in chained def"
-      ": POS? 0 > ;
-       : DOUBLE-IF-POS DUP POS? IF 2 * THEN ;
-       3 DOUBLE-IF-POS"
-      (list 6))
-    (forth-p3-check-stack
-      "empty then branch"
-      ": Q 1 IF THEN 99 ; Q"
-      (list 99))
-    (forth-p3-check-stack
-      "empty else branch"
-      ": Q 0 IF 99 ELSE THEN ; Q"
-      (list))
-    (forth-p3-check-stack
-      "sequential IF blocks"
-      ": Q -1 IF 1 THEN -1 IF 2 THEN ; Q"
-      (list 1 2))))
-
-(define
-  forth-p3-loop-tests
-  (fn
-    ()
-    (forth-p3-check-stack
-      "BEGIN UNTIL (countdown to zero)"
-      ": CD BEGIN 1- DUP 0 = UNTIL ; 3 CD"
-      (list 0))
-    (forth-p3-check-stack
-      "BEGIN UNTIL — single pass (UNTIL true immediately)"
-      ": Q BEGIN -1 UNTIL 42 ; Q"
-      (list 42))
-    (forth-p3-check-stack
-      "BEGIN UNTIL — accumulate sum 1+2+3"
-      ": SUM3 0 3 BEGIN TUCK + SWAP 1- DUP 0 = UNTIL DROP ; SUM3"
-      (list 6))
-    (forth-p3-check-stack
-      "BEGIN WHILE REPEAT — triangular sum 5"
-      ": TRI 0 5 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ; TRI"
-      (list 15))
-    (forth-p3-check-stack
-      "BEGIN WHILE REPEAT — zero iterations"
-      ": TRI 0 0 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ; TRI"
-      (list 0))
-    (forth-p3-check-stack
-      "BEGIN WHILE REPEAT — one iteration"
-      ": TRI 0 1 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ; TRI"
-      (list 1))
-    (forth-p3-check-stack
-      "nested BEGIN UNTIL"
-      ": INNER BEGIN 1- DUP 0 = UNTIL DROP ;
-       : OUTER BEGIN 3 INNER 1- DUP 0 = UNTIL ;
-       2 OUTER"
-      (list 0))
-    (forth-p3-check-stack
-      "BEGIN UNTIL after colon prefix"
-      ": TEN 10 ;
-       : CD TEN BEGIN 1- DUP 0 = UNTIL ;
-       CD"
-      (list 0))
-    (forth-p3-check-stack
-      "WHILE inside IF branch"
-      ": Q 1 IF 0 3 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ELSE 99 THEN ; Q"
-      (list 6))))
-
-(define
-  forth-p3-do-tests
-  (fn
-    ()
-    (forth-p3-check-stack
-      "DO LOOP — simple sum 0..4"
-      ": SUM 0 5 0 DO I + LOOP ; SUM"
-      (list 10))
-    (forth-p3-check-stack
-      "DO LOOP — 10..14 sum using I"
-      ": SUM 0 15 10 DO I + LOOP ; SUM"
-      (list 60))
-    (forth-p3-check-stack
-      "DO LOOP — limit = start runs one pass"
-      ": SUM 0 5 5 DO I + LOOP ; SUM"
-      (list 5))
-    (forth-p3-check-stack
-      "DO LOOP — count iterations"
-      ": COUNT 0 4 0 DO 1+ LOOP ; COUNT"
-      (list 4))
-    (forth-p3-check-stack
-      "DO LOOP — nested, I inner / J outer"
-      ": MATRIX 0 3 0 DO 3 0 DO I J + + LOOP LOOP ; MATRIX"
-      (list 18))
-    (forth-p3-check-stack
-      "DO LOOP — I used in arithmetic"
-      ": DBL 0 5 1 DO I 2 * + LOOP ; DBL"
-      (list 20))
-    (forth-p3-check-stack
-      "+LOOP — count by 2"
-      ": Q 0 10 0 DO I + 2 +LOOP ; Q"
-      (list 20))
-    (forth-p3-check-stack
-      "+LOOP — count by 3"
-      ": Q 0 10 0 DO I + 3 +LOOP ; Q"
-      (list 18))
-    (forth-p3-check-stack
-      "+LOOP — negative step"
-      ": Q 0 0 10 DO I + -1 +LOOP ; Q"
-      (list 55))
-    (forth-p3-check-stack
-      "LEAVE — early exit at I=3"
-      ": Q 0 10 0 DO I 3 = IF LEAVE THEN I + LOOP ; Q"
-      (list 3))
-    (forth-p3-check-stack
-      "LEAVE — in nested loop exits only inner"
-      ": Q 0 3 0 DO 5 0 DO I 2 = IF LEAVE THEN I + LOOP LOOP ; Q"
-      (list 3))
-    (forth-p3-check-stack
-      "DO LOOP preserves outer stack"
-      ": Q 99 5 0 DO I + LOOP ; Q"
-      (list 109))
-    (forth-p3-check-stack
-      ">R R>"
-      ": Q 7 >R 11 R> ; Q"
-      (list 11 7))
-    (forth-p3-check-stack
-      ">R R@ R>"
-      ": Q 7 >R R@ R> ; Q"
-      (list 7 7))
-    (forth-p3-check-stack
-      "2>R 2R>"
-      ": Q 1 2 2>R 99 2R> ; Q"
-      (list 99 1 2))
-    (forth-p3-check-stack
-      "2>R 2R@ 2R>"
-      ": Q 3 4 2>R 2R@ 2R> ; Q"
-      (list 3 4 3 4))))
-
-(define
-  forth-p3-run-all
-  (fn
-    ()
-    (set! forth-p3-passed 0)
-    (set! forth-p3-failed 0)
-    (set! forth-p3-failures (list))
-    (forth-p3-if-tests)
-    (forth-p3-loop-tests)
-    (forth-p3-do-tests)
-    (dict
-      "passed"
-      forth-p3-passed
-      "failed"
-      forth-p3-failed
-      "failures"
-      forth-p3-failures)))

lib/forth/tests/test-phase4.sx

@@ -1,268 +0,0 @@
-;; Phase 4 — strings + more Core.
-;; Uses the byte-memory model on state ("mem" dict + "here" cursor).
-
-(define forth-p4-passed 0)
-(define forth-p4-failed 0)
-(define forth-p4-failures (list))
-
-(define
-  forth-p4-assert
-  (fn
-    (label expected actual)
-    (if
-      (= expected actual)
-      (set! forth-p4-passed (+ forth-p4-passed 1))
-      (begin
-        (set! forth-p4-failed (+ forth-p4-failed 1))
-        (set!
-          forth-p4-failures
-          (concat
-            forth-p4-failures
-            (list
-              (str label ": expected " (str expected) " got " (str actual)))))))))
-
-(define
-  forth-p4-check-output
-  (fn
-    (label src expected)
-    (let ((r (forth-run src))) (forth-p4-assert label expected (nth r 1)))))
-
-(define
-  forth-p4-check-stack-size
-  (fn
-    (label src expected-n)
-    (let
-      ((r (forth-run src)))
-      (forth-p4-assert label expected-n (len (nth r 2))))))
-
-(define
-  forth-p4-check-top
-  (fn
-    (label src expected)
-    (let
-      ((r (forth-run src)))
-      (let
-        ((stk (nth r 2)))
-        (forth-p4-assert label expected (nth stk (- (len stk) 1)))))))
-
-(define
-  forth-p4-check-typed
-  (fn
-    (label src expected)
-    (forth-p4-check-output label (str src " TYPE") expected)))
-
-(define
-  forth-p4-string-tests
-  (fn
-    ()
-    (forth-p4-check-typed
-      "S\" + TYPE — hello"
-      "S\" HELLO\""
-      "HELLO")
-    (forth-p4-check-typed
-      "S\" + TYPE — two words"
-      "S\" HELLO WORLD\""
-      "HELLO WORLD")
-    (forth-p4-check-typed
-      "S\" + TYPE — empty"
-      "S\" \""
-      "")
-    (forth-p4-check-typed
-      "S\" + TYPE — single char"
-      "S\" X\""
-      "X")
-    (forth-p4-check-stack-size
-      "S\" pushes (addr len)"
-      "S\" HI\""
-      2)
-    (forth-p4-check-top
-      "S\" length is correct"
-      "S\" HELLO\""
-      5)
-    (forth-p4-check-output
-      ".\" prints at interpret time"
-      ".\" HELLO\""
-      "HELLO")
-    (forth-p4-check-output
-      ".\" in colon def"
-      ": GREET .\" HI \" ; GREET GREET"
-      "HI HI ")))
-
-(define
-  forth-p4-count-tests
-  (fn
-    ()
-    (forth-p4-check-typed
-      "C\" + COUNT + TYPE"
-      "C\" ABC\" COUNT"
-      "ABC")
-    (forth-p4-check-typed
-      "C\" then COUNT leaves right len"
-      "C\" HI THERE\" COUNT"
-      "HI THERE")))
-
-(define
-  forth-p4-fill-tests
-  (fn
-    ()
-    (forth-p4-check-typed
-      "FILL overwrites prefix bytes"
-      "S\" ABCDE\" 2DUP DROP 3 65 FILL"
-      "AAADE")
-    (forth-p4-check-typed
-      "BLANK sets spaces"
-      "S\" XYZAB\" 2DUP DROP 3 BLANK"
-      "   AB")))
-
-(define
-  forth-p4-cmove-tests
-  (fn
-    ()
-    (forth-p4-check-output
-      "CMOVE copies HELLO forward"
-      ": MKH 72 0 C! 69 1 C! 76 2 C! 76 3 C! 79 4 C! ;
-       : T MKH 0 10 5 CMOVE 10 5 TYPE ; T"
-      "HELLO")
-    (forth-p4-check-output
-      "CMOVE> copies overlapping backward"
-      ": MKA 65 0 C! 66 1 C! 67 2 C! ;
-       : T MKA 0 1 2 CMOVE> 0 3 TYPE ; T"
-      "AAB")
-    (forth-p4-check-output
-      "MOVE picks direction for overlap"
-      ": MKA 65 0 C! 66 1 C! 67 2 C! ;
-       : T MKA 0 1 2 MOVE 0 3 TYPE ; T"
-      "AAB")))
-
-(define
-  forth-p4-charplus-tests
-  (fn
-    ()
-    (forth-p4-check-top
-      "CHAR+ increments"
-      "5 CHAR+"
-      6)))
-
-(define
-  forth-p4-char-tests
-  (fn
-    ()
-    (forth-p4-check-top "CHAR A -> 65" "CHAR A" 65)
-    (forth-p4-check-top "CHAR x -> 120" "CHAR x" 120)
-    (forth-p4-check-top "CHAR takes only first char" "CHAR HELLO" 72)
-    (forth-p4-check-top
-      "[CHAR] compiles literal"
-      ": AA [CHAR] A ; AA"
-      65)
-    (forth-p4-check-top
-      "[CHAR] reads past IMMEDIATE"
-      ": ZZ [CHAR] Z ; ZZ"
-      90)
-    (forth-p4-check-stack-size
-      "[CHAR] doesn't leak at compile time"
-      ": FOO [CHAR] A ; "
-      0)))
-
-(define
-  forth-p4-key-accept-tests
-  (fn
-    ()
-    (let
-      ((r (forth-run "1000 2 ACCEPT")))
-      (let ((stk (nth r 2))) (forth-p4-assert "ACCEPT empty buf -> 0" (list 0) stk)))))
-
-(define
-  forth-p4-shift-tests
-  (fn
-    ()
-    (forth-p4-check-top "1 0 LSHIFT" "1 0 LSHIFT" 1)
-    (forth-p4-check-top "1 1 LSHIFT" "1 1 LSHIFT" 2)
-    (forth-p4-check-top "1 2 LSHIFT" "1 2 LSHIFT" 4)
-    (forth-p4-check-top "1 15 LSHIFT" "1 15 LSHIFT" 32768)
-    (forth-p4-check-top "1 31 LSHIFT" "1 31 LSHIFT" -2147483648)
-    (forth-p4-check-top "1 0 RSHIFT" "1 0 RSHIFT" 1)
-    (forth-p4-check-top "1 1 RSHIFT" "1 1 RSHIFT" 0)
-    (forth-p4-check-top "2 1 RSHIFT" "2 1 RSHIFT" 1)
-    (forth-p4-check-top "4 2 RSHIFT" "4 2 RSHIFT" 1)
-    (forth-p4-check-top "-1 1 RSHIFT (logical, not arithmetic)" "-1 1 RSHIFT" 2147483647)
-    (forth-p4-check-top "MSB via 1S 1 RSHIFT INVERT" "0 INVERT 1 RSHIFT INVERT" -2147483648)))
-
-(define
-  forth-p4-sp-tests
-  (fn
-    ()
-    (forth-p4-check-top "SP@ returns depth (0)" "SP@" 0)
-    (forth-p4-check-top
-      "SP@ after pushes"
-      "1 2 3 SP@ SWAP DROP SWAP DROP SWAP DROP"
-      3)
-    (forth-p4-check-stack-size
-      "SP! truncates"
-      "1 2 3 4 5 2 SP!"
-      2)
-    (forth-p4-check-top
-      "SP! leaves base items intact"
-      "1 2 3 4 5 2 SP!"
-      2)))
-
-(define
-  forth-p4-base-tests
-  (fn
-    ()
-    (forth-p4-check-top
-      "BASE default is 10"
-      "BASE @"
-      10)
-    (forth-p4-check-top
-      "HEX switches base to 16"
-      "HEX BASE @"
-      16)
-    (forth-p4-check-top
-      "DECIMAL resets to 10"
-      "HEX DECIMAL BASE @"
-      10)
-    (forth-p4-check-top
-      "HEX parses 10 as 16"
-      "HEX 10"
-      16)
-    (forth-p4-check-top
-      "HEX parses FF as 255"
-      "HEX FF"
-      255)
-    (forth-p4-check-top
-      "DECIMAL parses 10 as 10"
-      "HEX DECIMAL 10"
-      10)
-    (forth-p4-check-top
-      "OCTAL parses 17 as 15"
-      "OCTAL 17"
-      15)
-    (forth-p4-check-top
-      "BASE @ ; 16 BASE ! ; BASE @"
-      "BASE @ 16 BASE ! BASE @ SWAP DROP"
-      16)))
-
-(define
-  forth-p4-run-all
-  (fn
-    ()
-    (set! forth-p4-passed 0)
-    (set! forth-p4-failed 0)
-    (set! forth-p4-failures (list))
-    (forth-p4-string-tests)
-    (forth-p4-count-tests)
-    (forth-p4-fill-tests)
-    (forth-p4-cmove-tests)
-    (forth-p4-charplus-tests)
-    (forth-p4-char-tests)
-    (forth-p4-key-accept-tests)
-    (forth-p4-base-tests)
-    (forth-p4-shift-tests)
-    (forth-p4-sp-tests)
-    (dict
-      "passed"
-      forth-p4-passed
-      "failed"
-      forth-p4-failed
-      "failures"
-      forth-p4-failures)))

lib/forth/tests/test-phase5.sx

@@ -1,333 +0,0 @@
-;; Phase 5 — Core Extension + memory primitives.
-
-(define forth-p5-passed 0)
-(define forth-p5-failed 0)
-(define forth-p5-failures (list))
-
-(define
-  forth-p5-assert
-  (fn
-    (label expected actual)
-    (if
-      (= expected actual)
-      (set! forth-p5-passed (+ forth-p5-passed 1))
-      (begin
-        (set! forth-p5-failed (+ forth-p5-failed 1))
-        (set!
-          forth-p5-failures
-          (concat
-            forth-p5-failures
-            (list
-              (str label ": expected " (str expected) " got " (str actual)))))))))
-
-(define
-  forth-p5-check-stack
-  (fn
-    (label src expected)
-    (let ((r (forth-run src))) (forth-p5-assert label expected (nth r 2)))))
-
-(define
-  forth-p5-check-top
-  (fn
-    (label src expected)
-    (let
-      ((r (forth-run src)))
-      (let
-        ((stk (nth r 2)))
-        (forth-p5-assert label expected (nth stk (- (len stk) 1)))))))
-
-(define
-  forth-p5-create-tests
-  (fn
-    ()
-    (forth-p5-check-top
-      "CREATE pushes HERE-at-creation"
-      "HERE CREATE FOO FOO ="
-      -1)
-    (forth-p5-check-top
-      "CREATE + ALLOT advances HERE"
-      "HERE 5 ALLOT HERE SWAP -"
-      5)
-    (forth-p5-check-top
-      "CREATE + , stores cell"
-      "CREATE FOO 42 , FOO @"
-      42)
-    (forth-p5-check-stack
-      "CREATE multiple ,"
-      "CREATE TBL 1 , 2 , 3 , TBL @ TBL CELL+ @ TBL CELL+ CELL+ @"
-      (list 1 2 3))
-    (forth-p5-check-top
-      "C, stores byte"
-      "CREATE B 65 C, 66 C, B C@"
-      65)))
-
-(define
-  forth-p5-unsigned-tests
-  (fn
-    ()
-    (forth-p5-check-top "1 2 U<" "1 2 U<" -1)
-    (forth-p5-check-top "2 1 U<" "2 1 U<" 0)
-    (forth-p5-check-top "0 1 U<" "0 1 U<" -1)
-    (forth-p5-check-top "-1 1 U< (since -1 unsigned is huge)" "-1 1 U<" 0)
-    (forth-p5-check-top "1 -1 U<" "1 -1 U<" -1)
-    (forth-p5-check-top "1 2 U>" "1 2 U>" 0)
-    (forth-p5-check-top "-1 1 U>" "-1 1 U>" -1)))
-
-(define
-  forth-p5-2bang-tests
-  (fn
-    ()
-    (forth-p5-check-stack
-      "2! / 2@"
-      "CREATE X 0 , 0 , 11 22 X 2! X 2@"
-      (list 11 22))))
-
-(define
-  forth-p5-mixed-tests
-  (fn
-    ()
-    (forth-p5-check-stack "S>D positive" "5 S>D" (list 5 0))
-    (forth-p5-check-stack "S>D negative" "-5 S>D" (list -5 -1))
-    (forth-p5-check-stack "S>D zero" "0 S>D" (list 0 0))
-    (forth-p5-check-top "D>S keeps low" "5 0 D>S" 5)
-    (forth-p5-check-stack "M* small positive" "3 4 M*" (list 12 0))
-    (forth-p5-check-stack "M* negative" "-3 4 M*" (list -12 -1))
-    (forth-p5-check-stack
-      "M* negative * negative"
-      "-3 -4 M*"
-      (list 12 0))
-    (forth-p5-check-stack "UM* small" "3 4 UM*" (list 12 0))
-    (forth-p5-check-stack
-      "UM/MOD: 100 0 / 5"
-      "100 0 5 UM/MOD"
-      (list 0 20))
-    (forth-p5-check-stack
-      "FM/MOD: -7 / 2 floored"
-      "-7 -1 2 FM/MOD"
-      (list 1 -4))
-    (forth-p5-check-stack
-      "SM/REM: -7 / 2 truncated"
-      "-7 -1 2 SM/REM"
-      (list -1 -3))
-    (forth-p5-check-top "*/ truncated" "7 11 13 */" 5)
-    (forth-p5-check-stack "*/MOD" "7 11 13 */MOD" (list 12 5))))
-
-(define
-  forth-p5-double-tests
-  (fn
-    ()
-    (forth-p5-check-stack "D+ small" "5 0 7 0 D+" (list 12 0))
-    (forth-p5-check-stack "D+ negative" "-5 -1 -3 -1 D+" (list -8 -1))
-    (forth-p5-check-stack "D- small" "10 0 3 0 D-" (list 7 0))
-    (forth-p5-check-stack "DNEGATE positive" "5 0 DNEGATE" (list -5 -1))
-    (forth-p5-check-stack "DNEGATE negative" "-5 -1 DNEGATE" (list 5 0))
-    (forth-p5-check-stack "DABS negative" "-7 -1 DABS" (list 7 0))
-    (forth-p5-check-stack "DABS positive" "7 0 DABS" (list 7 0))
-    (forth-p5-check-top "D= equal" "5 0 5 0 D=" -1)
-    (forth-p5-check-top "D= unequal lo" "5 0 7 0 D=" 0)
-    (forth-p5-check-top "D= unequal hi" "5 0 5 1 D=" 0)
-    (forth-p5-check-top "D< lt" "5 0 7 0 D<" -1)
-    (forth-p5-check-top "D< gt" "7 0 5 0 D<" 0)
-    (forth-p5-check-top "D0= zero" "0 0 D0=" -1)
-    (forth-p5-check-top "D0= nonzero" "5 0 D0=" 0)
-    (forth-p5-check-top "D0< neg" "-5 -1 D0<" -1)
-    (forth-p5-check-top "D0< pos" "5 0 D0<" 0)
-    (forth-p5-check-stack "DMAX" "5 0 7 0 DMAX" (list 7 0))
-    (forth-p5-check-stack "DMIN" "5 0 7 0 DMIN" (list 5 0))))
-
-(define
-  forth-p5-format-tests
-  (fn
-    ()
-    (forth-p4-check-output-passthrough
-      "U. prints with trailing space"
-      "123 U."
-      "123 ")
-    (forth-p4-check-output-passthrough
-      "<# #S #> TYPE — decimal"
-      "123 0 <# #S #> TYPE"
-      "123")
-    (forth-p4-check-output-passthrough
-      "<# #S #> TYPE — hex"
-      "255 HEX 0 <# #S #> TYPE"
-      "FF")
-    (forth-p4-check-output-passthrough
-      "<# # # #> partial"
-      "1234 0 <# # # #> TYPE"
-      "34")
-    (forth-p4-check-output-passthrough
-      "SIGN holds minus"
-      "<# -1 SIGN -1 SIGN 0 0 #> TYPE"
-      "--")
-    (forth-p4-check-output-passthrough
-      ".R right-justifies"
-      "42 5 .R"
-      "   42")
-    (forth-p4-check-output-passthrough
-      ".R negative"
-      "-42 5 .R"
-      "  -42")
-    (forth-p4-check-output-passthrough
-      "U.R"
-      "42 5 U.R"
-      "   42")
-    (forth-p4-check-output-passthrough
-      "HOLD char"
-      "<# 0 0 65 HOLD #> TYPE"
-      "A")))
-
-(define
-  forth-p5-dict-tests
-  (fn
-    ()
-    (forth-p5-check-top
-      "EXECUTE via tick"
-      ": INC 1+ ; 9 ' INC EXECUTE"
-      10)
-    (forth-p5-check-top
-      "['] inside def"
-      ": DUB 2* ; : APPLY ['] DUB EXECUTE ; 5 APPLY"
-      10)
-    (forth-p5-check-top
-      ">BODY of CREATE word"
-      "CREATE C 99 , ' C >BODY @"
-      99)
-    (forth-p5-check-stack
-      "WORD parses next token to counted-string"
-      ": A 5 ; BL WORD A COUNT TYPE"
-      (list))
-    (forth-p5-check-top
-      "FIND on known word -> non-zero"
-      ": A 5 ; BL WORD A FIND SWAP DROP"
-      -1)))
-
-(define
-  forth-p5-state-tests
-  (fn
-    ()
-    (forth-p5-check-top
-      "STATE @ in interpret mode"
-      "STATE @"
-      0)
-    (forth-p5-check-top
-      "STATE @ via IMMEDIATE inside compile"
-      ": GT8 STATE @ ; IMMEDIATE : T GT8 LITERAL ; T"
-      -1)
-    (forth-p5-check-top
-      "[ ] LITERAL captures"
-      ": SEVEN [ 7 ] LITERAL ; SEVEN"
-      7)
-    (forth-p5-check-top
-      "EVALUATE in interpret mode"
-      "S\" 5 7 +\" EVALUATE"
-      12)
-    (forth-p5-check-top
-      "EVALUATE inside def"
-      ": A 100 ; : B S\" A\" EVALUATE ; B"
-      100)))
-
-(define
-  forth-p5-misc-tests
-  (fn
-    ()
-    (forth-p5-check-top "WITHIN inclusive lower" "3 2 10 WITHIN" -1)
-    (forth-p5-check-top "WITHIN exclusive upper" "10 2 10 WITHIN" 0)
-    (forth-p5-check-top "WITHIN below range" "1 2 10 WITHIN" 0)
-    (forth-p5-check-top "WITHIN at lower" "2 2 10 WITHIN" -1)
-    (forth-p5-check-top
-      "EXIT leaves colon-def early"
-      ": F 5 EXIT 99 ; F"
-      5)
-    (forth-p5-check-stack
-      "EXIT in IF branch"
-      ": F 5 0 IF DROP 99 EXIT THEN ; F"
-      (list 5))
-    (forth-p5-check-top
-      "UNLOOP + EXIT in DO"
-      ": SUM 0 10 0 DO I 5 = IF I UNLOOP EXIT THEN LOOP ; SUM"
-      5)))
-
-(define
-  forth-p5-fa-tests
-  (fn
-    ()
-    (forth-p5-check-top
-      "R/O R/W W/O constants"
-      "R/O R/W W/O + +"
-      3)
-    (forth-p5-check-top
-      "CREATE-FILE returns ior=0"
-      "CREATE PAD 50 ALLOT PAD S\" /tmp/test.fxf\" ROT SWAP CMOVE S\" /tmp/test.fxf\" R/W CREATE-FILE SWAP DROP"
-      0)
-    (forth-p5-check-top
-      "WRITE-FILE then CLOSE"
-      "S\" /tmp/t2.fxf\" R/W CREATE-FILE DROP >R S\" HI\" R@ WRITE-FILE R> CLOSE-FILE +"
-      0)
-    (forth-p5-check-top
-      "OPEN-FILE on unknown path returns ior!=0"
-      "S\" /tmp/nope.fxf\" R/O OPEN-FILE SWAP DROP 0 ="
-      0)))
-
-(define
-  forth-p5-string-tests
-  (fn
-    ()
-    (forth-p5-check-top "COMPARE equal" "S\" ABC\" S\" ABC\" COMPARE" 0)
-    (forth-p5-check-top "COMPARE less" "S\" ABC\" S\" ABD\" COMPARE" -1)
-    (forth-p5-check-top "COMPARE greater" "S\" ABD\" S\" ABC\" COMPARE" 1)
-    (forth-p5-check-top
-      "COMPARE prefix less"
-      "S\" AB\" S\" ABC\" COMPARE"
-      -1)
-    (forth-p5-check-top
-      "COMPARE prefix greater"
-      "S\" ABC\" S\" AB\" COMPARE"
-      1)
-    (forth-p5-check-top
-      "SEARCH found flag"
-      "S\" HELLO WORLD\" S\" WORLD\" SEARCH"
-      -1)
-    (forth-p5-check-top
-      "SEARCH not found flag"
-      "S\" HELLO\" S\" XYZ\" SEARCH"
-      0)
-    (forth-p5-check-top
-      "SEARCH empty needle flag"
-      "S\" HELLO\" S\" \" SEARCH"
-      -1)
-    (forth-p5-check-top
-      "SLITERAL via [ S\" ... \" ]"
-      ": A [ S\" HI\" ] SLITERAL ; A SWAP DROP"
-      2)))
-
-(define
-  forth-p4-check-output-passthrough
-  (fn
-    (label src expected)
-    (let ((r (forth-run src))) (forth-p5-assert label expected (nth r 1)))))
-
-(define
-  forth-p5-run-all
-  (fn
-    ()
-    (set! forth-p5-passed 0)
-    (set! forth-p5-failed 0)
-    (set! forth-p5-failures (list))
-    (forth-p5-create-tests)
-    (forth-p5-unsigned-tests)
-    (forth-p5-2bang-tests)
-    (forth-p5-mixed-tests)
-    (forth-p5-double-tests)
-    (forth-p5-format-tests)
-    (forth-p5-dict-tests)
-    (forth-p5-state-tests)
-    (forth-p5-misc-tests)
-    (forth-p5-fa-tests)
-    (forth-p5-string-tests)
-    (dict
-      "passed"
-      forth-p5-passed
-      "failed"
-      forth-p5-failed
-      "failures"
-      forth-p5-failures)))

lib/guest/ast.sx

@@ -0,0 +1,92 @@
+;; 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)))

lib/guest/baseline/apl.json

@@ -0,0 +1,18 @@
+{
+  "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
+    }
+  ]
+}

lib/guest/baseline/common-lisp.json

@@ -0,0 +1,86 @@
+{
+  "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."
+}

lib/guest/baseline/erlang.json

@@ -0,0 +1,67 @@
+{
+  "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"
+}

lib/guest/baseline/forth.json

@@ -0,0 +1,18 @@
+{
+  "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
+    }
+  ]
+}

lib/guest/baseline/haskell.json

@@ -0,0 +1,122 @@
+{
+  "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."
+}

lib/guest/baseline/js.json

@@ -0,0 +1,75 @@
+{
+  "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"
+}

lib/guest/baseline/lua.json

@@ -0,0 +1,18 @@
+{
+  "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
+    }
+  ]
+}

lib/guest/baseline/prolog.json

@@ -0,0 +1,187 @@
+{
+  "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"
+}

lib/guest/baseline/ruby.json

@@ -0,0 +1,18 @@
+{
+  "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
+    }
+  ]
+}