fed-prims: Phase J — http-request + 6 tests

NATIVE-ONLY http-request primitive (bin/sx_server.ml). HTTP/1.1 over
Unix sockets + gethostbyname; inline http:// URL parsing (full
url-parse deferred to Phase K); Connection: close + Host +
Content-Length headers auto-supplied; reads response via
Content-Length or read-to-EOF; chunked transfer-encoding rejected.
Test bin/test_http_client.sh spins a Phase-H echo server and drives
a second sx_server: GET+query, POST+body, 404, custom request
header reflected, non-http scheme rejected, integer status — 6/6.
WASM boot green (prim not in lib); Erlang conformance 530/530.

.claude/scheduled_tasks.lock

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

hosts/ocaml/bin/run_tests.ml

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

hosts/ocaml/bin/sx_server.ml

@@ -708,6 +708,297 @@ let setup_evaluator_bridge env =
     match args with
     | [e; expr] -> Sx_ref.eval_expr expr e
     | _ -> raise (Eval_error "eval-in-env: (env expr)"));
+
+  (* fed-sx Milestone 1 Step 8 transport. NATIVE ONLY — sockets +
+     threads; deliberately absent from the WASM kernel (registered
+     here in bin/, never in lib/sx_primitives.ml). Minimal HTTP/1.1,
+     Connection: close. handler : req-dict -> resp-dict where
+     req = {:method :path :query :headers :body},
+     resp = {:status :headers :body}. Never returns. *)
+  Sx_primitives.register "http-listen" (fun args ->
+    let strip_cr s =
+      let n = String.length s in
+      if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
+    in
+    match args with
+    | [port_v; handler] ->
+      let port = match port_v with
+        | Integer n -> n
+        | Number f -> int_of_float f
+        | _ -> raise (Eval_error "http-listen: (port handler)") in
+      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      Unix.setsockopt sock Unix.SO_REUSEADDR true;
+      Unix.bind sock
+        (Unix.ADDR_INET (Unix.inet_addr_loopback, port));
+      Unix.listen sock 64;
+      (* SX runtime is shared across threads — serialize handler calls. *)
+      let mtx = Mutex.create () in
+      let reason = function
+        | 200 -> "OK" | 201 -> "Created" | 204 -> "No Content"
+        | 301 -> "Moved Permanently" | 302 -> "Found"
+        | 400 -> "Bad Request" | 401 -> "Unauthorized"
+        | 403 -> "Forbidden" | 404 -> "Not Found"
+        | 405 -> "Method Not Allowed" | 500 -> "Internal Server Error"
+        | _ -> "OK" in
+      let handle fd =
+        (try
+          let ic = Unix.in_channel_of_descr fd in
+          let oc = Unix.out_channel_of_descr fd in
+          let reqline = strip_cr (input_line ic) in
+          (match String.split_on_char ' ' reqline with
+           | meth :: target :: _ ->
+             let path, query =
+               match String.index_opt target '?' with
+               | Some i ->
+                 String.sub target 0 i,
+                 String.sub target (i + 1)
+                   (String.length target - i - 1)
+               | None -> target, "" in
+             let headers = Sx_types.make_dict () in
+             let clen = ref 0 in
+             let rec rdh () =
+               let h = strip_cr (input_line ic) in
+               if h = "" then ()
+               else begin
+                 (match String.index_opt h ':' with
+                  | Some i ->
+                    let name =
+                      String.lowercase_ascii
+                        (String.trim (String.sub h 0 i)) in
+                    let value =
+                      String.trim
+                        (String.sub h (i + 1)
+                           (String.length h - i - 1)) in
+                    Hashtbl.replace headers name (String value);
+                    if name = "content-length" then
+                      (try clen := int_of_string value with _ -> ())
+                  | None -> ());
+                 rdh ()
+               end in
+             rdh ();
+             let body =
+               if !clen > 0 then begin
+                 let b = Bytes.create !clen in
+                 really_input ic b 0 !clen;
+                 Bytes.unsafe_to_string b
+               end else "" in
+             let req = Sx_types.make_dict () in
+             Hashtbl.replace req "method" (String meth);
+             Hashtbl.replace req "path" (String path);
+             Hashtbl.replace req "query" (String query);
+             Hashtbl.replace req "headers" (Dict headers);
+             Hashtbl.replace req "body" (String body);
+             Mutex.lock mtx;
+             let resp =
+               (try Sx_runtime.sx_call handler [Dict req]
+                with e -> Mutex.unlock mtx; raise e) in
+             Mutex.unlock mtx;
+             let getk k = match resp with
+               | Dict h -> Hashtbl.find_opt h k | _ -> None in
+             let status = match getk "status" with
+               | Some (Integer n) -> n
+               | Some (Number f) -> int_of_float f
+               | _ -> 200 in
+             let rbody = match getk "body" with
+               | Some (String s) -> s
+               | Some v -> Sx_types.value_to_string v
+               | None -> "" in
+             let rhdrs = match getk "headers" with
+               | Some (Dict h) ->
+                 Hashtbl.fold (fun k v acc ->
+                   (k, (match v with
+                        | String s -> s
+                        | v -> Sx_types.value_to_string v)) :: acc)
+                   h []
+               | _ -> [] in
+             let buf = Buffer.create 256 in
+             Buffer.add_string buf
+               (Printf.sprintf "HTTP/1.1 %d %s\r\n" status
+                  (reason status));
+             List.iter (fun (k, v) ->
+               Buffer.add_string buf
+                 (Printf.sprintf "%s: %s\r\n" k v)) rhdrs;
+             if not (List.exists
+                       (fun (k, _) ->
+                          String.lowercase_ascii k = "content-type")
+                       rhdrs)
+             then Buffer.add_string buf
+                 "Content-Type: text/plain\r\n";
+             Buffer.add_string buf
+               (Printf.sprintf "Content-Length: %d\r\n"
+                  (String.length rbody));
+             Buffer.add_string buf "Connection: close\r\n\r\n";
+             Buffer.add_string buf rbody;
+             output_string oc (Buffer.contents buf);
+             flush oc
+           | _ -> ())
+         with _ -> ());
+        (try Unix.close fd with _ -> ())
+      in
+      while true do
+        let fd, _ = Unix.accept sock in
+        ignore (Thread.create handle fd)
+      done;
+      Nil
+    | _ -> raise (Eval_error "http-listen: (port handler)"));
+
+  (* fed-sx Milestone 1 client direction (Phase J). NATIVE ONLY —
+     Unix sockets + DNS; absent from the WASM kernel. HTTP/1.1
+     request: TCP connect, write request line + headers + body,
+     read status + headers + body, return {:status :headers :body}.
+     URL must be http://...; HTTPS is a later phase (needs TLS).
+     Body read: Content-Length first, else read to EOF (we send
+     Connection: close). Transfer-Encoding: chunked is rejected —
+     fed-sx Phase 8 wires this for inter-server POSTs which will
+     all carry Content-Length. *)
+  Sx_primitives.register "http-request" (fun args ->
+    let strip_cr s =
+      let n = String.length s in
+      if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
+    in
+    match args with
+    | [String meth; String url; headers_v; body_v] ->
+      let body = match body_v with
+        | String s -> s
+        | Nil -> ""
+        | v -> Sx_types.value_to_string v in
+      let prefix = "http://" in
+      let plen = String.length prefix in
+      let ulen = String.length url in
+      if ulen < plen || String.sub url 0 plen <> prefix
+      then raise (Eval_error "http-request: URL must start with http://");
+      let rest = String.sub url plen (ulen - plen) in
+      let host_port, path =
+        match String.index_opt rest '/' with
+        | Some i ->
+          String.sub rest 0 i,
+          String.sub rest i (String.length rest - i)
+        | None -> rest, "/" in
+      if host_port = "" then
+        raise (Eval_error "http-request: missing host");
+      let host, port =
+        match String.index_opt host_port ':' with
+        | Some i ->
+          let h = String.sub host_port 0 i in
+          let ps = String.sub host_port (i + 1)
+                     (String.length host_port - i - 1) in
+          (h,
+           (try int_of_string ps with _ ->
+              raise (Eval_error "http-request: bad port")))
+        | None -> host_port, 80 in
+      let addr =
+        (try (Unix.gethostbyname host).h_addr_list.(0)
+         with Not_found ->
+           raise (Eval_error ("http-request: dns: " ^ host))) in
+      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      let cleanup () = try Unix.close sock with _ -> () in
+      let result =
+        (try
+          (try Unix.connect sock (Unix.ADDR_INET (addr, port))
+           with Unix.Unix_error (e, _, _) ->
+             raise (Eval_error
+                      ("http-request: connect: " ^ Unix.error_message e)));
+          let oc = Unix.out_channel_of_descr sock in
+          let ic = Unix.in_channel_of_descr sock in
+          let buf = Buffer.create 256 in
+          Buffer.add_string buf
+            (Printf.sprintf "%s %s HTTP/1.1\r\n" meth path);
+          let host_hdr_sent = ref false in
+          let clen_sent = ref false in
+          let conn_sent = ref false in
+          (match headers_v with
+           | Dict h ->
+             Hashtbl.iter (fun k v ->
+               let kl = String.lowercase_ascii k in
+               if kl = "host" then host_hdr_sent := true;
+               if kl = "content-length" then clen_sent := true;
+               if kl = "connection" then conn_sent := true;
+               let vs = match v with
+                 | String s -> s
+                 | x -> Sx_types.value_to_string x in
+               Buffer.add_string buf
+                 (Printf.sprintf "%s: %s\r\n" k vs)) h
+           | Nil -> ()
+           | _ -> raise (Eval_error "http-request: headers must be dict"));
+          if not !host_hdr_sent then
+            Buffer.add_string buf
+              (Printf.sprintf "Host: %s\r\n" host_port);
+          if not !clen_sent then
+            Buffer.add_string buf
+              (Printf.sprintf "Content-Length: %d\r\n"
+                 (String.length body));
+          if not !conn_sent then
+            Buffer.add_string buf "Connection: close\r\n";
+          Buffer.add_string buf "\r\n";
+          Buffer.add_string buf body;
+          output_string oc (Buffer.contents buf);
+          flush oc;
+          let sl =
+            (try strip_cr (input_line ic)
+             with End_of_file ->
+               raise (Eval_error
+                        "http-request: connection closed before status")) in
+          let status =
+            match String.split_on_char ' ' sl with
+            | _ver :: code :: _ ->
+              (try int_of_string code with _ ->
+                 raise (Eval_error "http-request: bad status code"))
+            | _ -> raise (Eval_error "http-request: bad status line") in
+          let rhdrs = Sx_types.make_dict () in
+          let clen = ref (-1) in
+          let chunked = ref false in
+          let rec rdh () =
+            let h =
+              (try strip_cr (input_line ic)
+               with End_of_file -> "") in
+            if h = "" then ()
+            else begin
+              (match String.index_opt h ':' with
+               | Some i ->
+                 let name =
+                   String.lowercase_ascii
+                     (String.trim (String.sub h 0 i)) in
+                 let value =
+                   String.trim
+                     (String.sub h (i + 1)
+                        (String.length h - i - 1)) in
+                 Hashtbl.replace rhdrs name (String value);
+                 if name = "content-length" then
+                   (try clen := int_of_string value with _ -> ())
+                 else if name = "transfer-encoding" &&
+                         String.lowercase_ascii value = "chunked"
+                 then chunked := true
+               | None -> ());
+              rdh ()
+            end in
+          rdh ();
+          if !chunked then
+            raise (Eval_error
+                     "http-request: chunked transfer-encoding not supported");
+          let rbody =
+            if !clen >= 0 then begin
+              let b = Bytes.create !clen in
+              really_input ic b 0 !clen;
+              Bytes.unsafe_to_string b
+            end else begin
+              let b = Buffer.create 256 in
+              (try
+                 while true do
+                   Buffer.add_channel b ic 4096
+                 done; assert false
+               with End_of_file -> ());
+              Buffer.contents b
+            end in
+          let resp = Sx_types.make_dict () in
+          Hashtbl.replace resp "status" (Integer status);
+          Hashtbl.replace resp "headers" (Dict rhdrs);
+          Hashtbl.replace resp "body" (String rbody);
+          Dict resp
+        with e -> cleanup (); raise e) in
+      cleanup ();
+      result
+    | _ -> raise (Eval_error "http-request: (method url headers body)"));
+
   bind "trampoline" (fun args ->
     match args with
     | [v] ->

hosts/ocaml/bin/test_http.sh

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

hosts/ocaml/bin/test_http_client.sh

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

hosts/ocaml/browser/sx_browser.ml

@@ -676,7 +676,11 @@ let () =
   let rec deep_equal a b =
     match a, b with
     | Nil, Nil -> true | Bool a, Bool b -> a = b
-    | Number a, Number b -> a = b | String a, String b -> a = b
+    | Integer a, Integer b -> a = b
+    | Number a, Number b -> a = b
+    | Integer a, Number b -> float_of_int a = b
+    | Number a, Integer b -> a = float_of_int b
+    | String a, String b -> a = b
     | Symbol a, Symbol b -> a = b | Keyword a, Keyword b -> a = b
     | (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
       List.length a = List.length b && List.for_all2 deep_equal a b

hosts/ocaml/lib/dune

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

hosts/ocaml/lib/extensions/README.md

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

hosts/ocaml/lib/extensions/test_ext.ml

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

hosts/ocaml/lib/sx_cbor.ml

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

hosts/ocaml/lib/sx_cid.ml

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

hosts/ocaml/lib/sx_ed25519.ml

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

hosts/ocaml/lib/sx_primitives.ml

@@ -759,11 +759,22 @@ let () =
       (List lb | ListRef { contents = lb }) ->
       List.length la = List.length lb &&
       List.for_all2 safe_eq la lb
-    (* Dict: check __host_handle for DOM node identity *)
+    (* Dict: __host_handle identity for DOM-wrapped dicts; otherwise
+       structural equality over keys + values. *)
     | Dict a, Dict b ->
       (match Hashtbl.find_opt a "__host_handle", Hashtbl.find_opt b "__host_handle" with
        | Some (Number ha), Some (Number hb) -> ha = hb
-       | _ -> false)
+       | Some _, _ | _, Some _ -> false
+       | None, None ->
+         Hashtbl.length a = Hashtbl.length b &&
+         (let eq = ref true in
+          Hashtbl.iter (fun k v ->
+            if !eq then
+              match Hashtbl.find_opt b k with
+              | Some v' -> if not (safe_eq v v') then eq := false
+              | None -> eq := false
+          ) a;
+          !eq))
     (* Records: same type + structurally equal fields *)
     | Record a, Record b ->
       a.r_type.rt_uid = b.r_type.rt_uid &&
@@ -3226,6 +3237,21 @@ let () =
       with Sys_error msg -> raise (Eval_error ("file-read: " ^ msg)))
     | _ -> raise (Eval_error "file-read: (path)"));
 
+  (* fed-sx Step 3 segment replay. Sorted names, no "."/".." ;
+     errors prefixed like file-read (msg carries enoent/enotdir). *)
+  register "file-list-dir" (fun args ->
+    match args with
+    | [String path] ->
+      (try
+        let names = Sys.readdir path in
+        let names =
+          Array.to_list names
+          |> List.filter (fun n -> n <> "." && n <> "..") in
+        let names = List.sort compare names in
+        List (List.map (fun n -> String n) names)
+      with Sys_error msg -> raise (Eval_error ("file-list-dir: " ^ msg)))
+    | _ -> raise (Eval_error "file-list-dir: (path)"));
+
   register "file-write" (fun args ->
     match args with
     | [String path; String content] ->
@@ -4117,17 +4143,91 @@ let () =
   register "jit-stats" (fun _args ->
     let d = Hashtbl.create 8 in
     Hashtbl.replace d "threshold"        (Number (float_of_int !Sx_types.jit_threshold));
+    Hashtbl.replace d "budget"           (Number (float_of_int !Sx_types.jit_budget));
+    Hashtbl.replace d "cache-size"       (Number (float_of_int (Sx_types.jit_cache_size ())));
     Hashtbl.replace d "compiled"         (Number (float_of_int !Sx_types.jit_compiled_count));
     Hashtbl.replace d "compile-failed"   (Number (float_of_int !Sx_types.jit_skipped_count));
     Hashtbl.replace d "below-threshold"  (Number (float_of_int !Sx_types.jit_threshold_skipped_count));
+    Hashtbl.replace d "evicted"          (Number (float_of_int !Sx_types.jit_evicted_count));
     Dict d);
   register "jit-set-threshold!" (fun args ->
     match args with
     | [Number n] -> Sx_types.jit_threshold := int_of_float n; Nil
     | [Integer n] -> Sx_types.jit_threshold := n; Nil
     | _ -> raise (Eval_error "jit-set-threshold!: (n) where n is integer"));
+  register "jit-set-budget!" (fun args ->
+    match args with
+    | [Number n] -> Sx_types.jit_budget := int_of_float n; Nil
+    | [Integer n] -> Sx_types.jit_budget := n; Nil
+    | _ -> raise (Eval_error "jit-set-budget!: (n) where n is integer"));
+  register "jit-reset-cache!" (fun _args ->
+    (* Phase 3 manual cache reset — clear all compiled VmClosures.
+       Hot paths will re-JIT on next call (after re-hitting threshold). *)
+    Queue.iter (fun (_, v) ->
+      match v with Lambda l -> l.l_compiled <- None | _ -> ()
+    ) Sx_types.jit_cache_queue;
+    Queue.clear Sx_types.jit_cache_queue;
+    Nil);
   register "jit-reset-counters!" (fun _args ->
     Sx_types.jit_compiled_count := 0;
     Sx_types.jit_skipped_count := 0;
     Sx_types.jit_threshold_skipped_count := 0;
-    Nil)
+    Sx_types.jit_evicted_count := 0;
+    Nil);
+
+  (* fed-sx host primitives — pure-OCaml crypto (WASM-safe). *)
+  register "crypto-sha256" (fun args ->
+    match args with
+    | [String s] -> String (Sx_sha2.sha256_hex s)
+    | _ -> raise (Eval_error "crypto-sha256: (bytes)"));
+
+  register "crypto-sha512" (fun args ->
+    match args with
+    | [String s] -> String (Sx_sha2.sha512_hex s)
+    | _ -> raise (Eval_error "crypto-sha512: (bytes)"));
+
+  register "crypto-sha3-256" (fun args ->
+    match args with
+    | [String s] -> String (Sx_sha3.sha3_256_hex s)
+    | _ -> raise (Eval_error "crypto-sha3-256: (bytes)"));
+
+  register "cbor-encode" (fun args ->
+    match args with
+    | [v] ->
+      (try String (Sx_cbor.encode v)
+       with Sx_cbor.Cbor_error m -> raise (Eval_error m))
+    | _ -> raise (Eval_error "cbor-encode: (value)"));
+
+  register "cbor-decode" (fun args ->
+    match args with
+    | [String s] ->
+      (try Sx_cbor.decode s
+       with Sx_cbor.Cbor_error m -> raise (Eval_error m))
+    | _ -> raise (Eval_error "cbor-decode: (bytes)"));
+
+  register "cid-from-bytes" (fun args ->
+    match args with
+    | [Integer codec; String mh] ->
+      String (Sx_cid.cidv1 codec mh)
+    | _ -> raise (Eval_error "cid-from-bytes: (codec multihash-bytes)"));
+
+  register "cid-from-sx" (fun args ->
+    match args with
+    | [v] ->
+      (try String (Sx_cid.cid_from_sx v)
+       with Sx_cbor.Cbor_error m -> raise (Eval_error m))
+    | _ -> raise (Eval_error "cid-from-sx: (value)"));
+
+  (* Verify is total: any malformed input -> false, never raises. *)
+  register "ed25519-verify" (fun args ->
+    match args with
+    | [String pk; String msg; String sg] ->
+      Bool (try Sx_ed25519.verify ~pubkey:pk ~msg ~sig_:sg
+            with _ -> false)
+    | _ -> Bool false);
+
+  register "rsa-sha256-verify" (fun args ->
+    match args with
+    | [String spki; String msg; String sg] ->
+      Bool (try Sx_rsa.verify ~spki ~msg ~sig_:sg with _ -> false)
+    | _ -> Bool false)

hosts/ocaml/lib/sx_rsa.ml

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

hosts/ocaml/lib/sx_sha2.ml

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

hosts/ocaml/lib/sx_sha3.ml

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

hosts/ocaml/lib/sx_types.ml

@@ -139,6 +139,7 @@ and lambda = {
   mutable l_name : string option;
   mutable l_compiled : vm_closure option;  (** Lazy JIT cache *)
   mutable l_call_count : int;              (** Tiered-compilation counter — JIT after threshold calls *)
+  l_uid : int;                             (** Unique identity for LRU cache tracking *)
 }
 
 and component = {
@@ -445,12 +446,16 @@ let unwrap_env_val = function
   | Env e -> e
   | _ -> raise (Eval_error "make_lambda: expected env for closure")
 
+(* Lambda UID — minted on construction, used as LRU cache key (Phase 2). *)
+let lambda_uid_counter = ref 0
+let next_lambda_uid () = incr lambda_uid_counter; !lambda_uid_counter
+
 let make_lambda params body closure =
   let ps = match params with
     | List items -> List.map value_to_string items
     | _ -> value_to_string_list params
   in
-  Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0 }
+  Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0; l_uid = next_lambda_uid () }
 
 (** {1 JIT cache control}
 
@@ -465,6 +470,37 @@ let jit_compiled_count = ref 0
 let jit_skipped_count = ref 0
 let jit_threshold_skipped_count = ref 0
 
+(** {2 JIT cache LRU eviction — Phase 2}
+
+    Once a lambda crosses the threshold, its [l_compiled] slot is filled.
+    To bound memory under unbounded compilation pressure, track all live
+    compiled lambdas in FIFO order, and evict from the head when the count
+    exceeds [jit_budget].
+
+    [lambda_uid_counter] mints unique identities on lambda creation; the
+    LRU queue holds these IDs paired with a back-reference to the lambda
+    so we can clear its [l_compiled] slot on eviction.
+
+    Budget of 0 = no cache (disable JIT entirely).
+    Budget of [max_int] = unbounded (legacy behaviour). Default 5000 is
+    a generous ceiling for any realistic page; the test harness compiles
+    ~3000 distinct one-shot lambdas in a full run but tiered compilation
+    (Phase 1) means most never enter the cache, so steady-state count
+    stays small.
+
+    [lambda_uid_counter] and [next_lambda_uid] are defined above
+    [make_lambda] (which uses them on construction). *)
+let jit_budget = ref 5000
+let jit_evicted_count = ref 0
+
+(** Live compiled lambdas in FIFO order — front is oldest, back is newest.
+    Each entry is (uid, lambda); on eviction we clear lambda.l_compiled and
+    drop from the queue. Using a mutable Queue rather than a hand-rolled
+    linked list because eviction is amortised O(1) at the head and inserts
+    are O(1) at the tail. *)
+let jit_cache_queue : (int * value) Queue.t = Queue.create ()
+let jit_cache_size () = Queue.length jit_cache_queue
+
 let make_component name params has_children body closure affinity =
   let n = value_to_string name in
   let ps = value_to_string_list params in

hosts/ocaml/lib/sx_vm.ml

@@ -44,6 +44,11 @@ type vm = {
     ip past OP_PERFORM, stack ready for a result push). *)
 exception VmSuspended of value * vm
 
+(** Raised by the extension dispatch fallthrough when an opcode in the
+    extension range (≥ 200) is encountered with no handler registered.
+    Carries the offending opcode id. See plans/sx-vm-opcode-extension.md. *)
+exception Invalid_opcode of int
+
 (* Register the VM suspension converter so sx_runtime.sx_apply_cek can
    catch VmSuspended and convert it to CekPerformRequest without a
    direct dependency on this module. *)
@@ -57,6 +62,21 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
 let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
   ref (fun _ _ -> None)
 
+(** Forward reference for extension opcode dispatch — Phase B installs the
+    real registry's dispatch function here at module init. Until then, any
+    opcode in the extension range raises [Invalid_opcode]. Same forward-ref
+    pattern as [jit_compile_ref] above; keeps [Sx_vm_extensions] free to
+    depend on [Sx_vm]'s [vm] / [frame] types without a cycle. *)
+let extension_dispatch_ref : (int -> vm -> frame -> unit) ref =
+  ref (fun op _vm _frame -> raise (Invalid_opcode op))
+
+(** Forward reference for extension opcode → name lookup, used by
+    [opcode_name] / [disassemble] for human-readable disassembly.  The
+    registry installs a real lookup at module init; default returns
+    [None] (then [opcode_name] falls back to "UNKNOWN_n"). *)
+let extension_opcode_name_ref : (int -> string option) ref =
+  ref (fun _ -> None)
+
 (* JIT threshold and counters live in Sx_types so primitives can read them
    without creating a sx_primitives → sx_vm dependency cycle. *)
 
@@ -368,12 +388,20 @@ and vm_call vm f args =
        if l.l_name <> None
        then begin
          l.l_call_count <- l.l_call_count + 1;
-         if l.l_call_count >= !Sx_types.jit_threshold then begin
+         if l.l_call_count >= !Sx_types.jit_threshold && !Sx_types.jit_budget > 0 then begin
            l.l_compiled <- Some jit_failed_sentinel;
            match !jit_compile_ref l vm.globals with
            | Some cl ->
              incr Sx_types.jit_compiled_count;
              l.l_compiled <- Some cl;
+             (* Phase 2 LRU: track this compiled lambda; if cache exceeds budget,
+                evict the oldest by clearing its l_compiled slot. *)
+             Queue.add (l.l_uid, Lambda l) Sx_types.jit_cache_queue;
+             while Queue.length Sx_types.jit_cache_queue > !Sx_types.jit_budget do
+               (match Queue.pop Sx_types.jit_cache_queue with
+                | (_, Lambda ev_l) -> ev_l.l_compiled <- None; incr Sx_types.jit_evicted_count
+                | _ -> ())
+             done;
              push_closure_frame vm cl args
            | None ->
              incr Sx_types.jit_skipped_count;
@@ -867,6 +895,15 @@ and run vm =
           let request = pop vm in
           raise (VmSuspended (request, vm))
 
+        (* ---- Extension dispatch fallthrough ----
+           Opcode partition (see plans/sx-vm-opcode-extension.md):
+             0       reserved / NOP
+             1-199   core opcodes (current ceiling 175 = OP_DEC)
+             200-247 extension opcodes (registered via Sx_vm_extensions)
+             248-255 reserved for future expansion / multi-byte
+           Any opcode ≥ 200 routes through the extension registry. *)
+        | op when op >= 200 -> !extension_dispatch_ref op vm frame
+
         | opcode ->
           raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d"
                                opcode (frame.ip - 1)))
@@ -1019,6 +1056,62 @@ let _jit_is_broken_name n =
   || n = "hs-repeat-while" || n = "hs-repeat-until"
   || n = "hs-for-each" || n = "hs-put!"
 
+(** Scan bytecode for any extension opcode (≥ 200, the registry's
+    [Sx_vm_extensions.extension_min]). Walks operand bytes correctly
+    so values that happen to be ≥200 (e.g. a CONST u16 index pointing
+    into a large pool) do not trigger false positives. CLOSURE's
+    dynamic upvalue descriptors are read from the constant pool entry
+    at the same index it pushes.
+
+    Used by [jit_compile_lambda] (Phase E of the opcode-extension
+    plan): a lambda whose compiled body contains any extension opcode
+    is routed through interpretation rather than JIT.  Extensions
+    interpret their opcodes via the registry; the JIT does not
+    currently know how to compile them.
+
+    Operand-size logic mirrors [opcode_operand_size] (which is defined
+    later, in the disassembly section); inlined here so this helper can
+    sit before [jit_compile_lambda] in the file. *)
+let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
+  let core_operand_size = function
+    | 1 | 20 | 21 | 64 | 65 | 128 -> 2  (* u16 *)
+    | 16 | 17 | 18 | 19 | 48 | 49 | 144 -> 1  (* u8 *)
+    | 32 | 33 | 34 | 35 -> 2  (* i16 *)
+    | 52 -> 3  (* CALL_PRIM: u16 + u8 *)
+    | _ -> 0
+  in
+  let len = Array.length bc in
+  let ip = ref 0 in
+  let found = ref false in
+  while not !found && !ip < len do
+    let op = bc.(!ip) in
+    if op >= 200 then found := true
+    else begin
+      ip := !ip + 1;
+      let extra = match op with
+        | 51 (* CLOSURE *) when !ip + 1 < len ->
+          let lo = bc.(!ip) in
+          let hi = bc.(!ip + 1) in
+          let idx = lo lor (hi lsl 8) in
+          let uv_count =
+            if idx < Array.length consts then
+              (match consts.(idx) with
+               | Dict d ->
+                 (match Hashtbl.find_opt d "upvalue-count" with
+                  | Some (Integer n) -> n
+                  | Some (Number n) -> int_of_float n
+                  | _ -> 0)
+               | _ -> 0)
+            else 0
+          in
+          2 + uv_count * 2
+        | _ -> core_operand_size op
+      in
+      ip := !ip + extra
+    end
+  done;
+  !found
+
 let jit_compile_lambda (l : lambda) globals =
   let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
   if !_jit_compiling then (
@@ -1081,8 +1174,18 @@ let jit_compile_lambda (l : lambda) globals =
         if idx < Array.length outer_code.vc_constants then
           let inner_val = outer_code.vc_constants.(idx) in
           let code = code_from_value inner_val in
-          Some { vm_code = code; vm_upvalues = [||];
-                 vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
+          (* Phase E: if the inner lambda's bytecode contains any
+             extension opcode (≥200), skip JIT and let the lambda run
+             interpreted via CEK. Extension opcodes dispatch correctly
+             through the VM's registry fallthrough, but the JIT has no
+             knowledge of them and shouldn't claim ownership. *)
+          if bytecode_uses_extension_opcodes code.vc_bytecode code.vc_constants then begin
+            Printf.eprintf "[jit] SKIP %s: bytecode uses extension opcodes (interpret-only in v1)\n%!"
+              fn_name;
+            None
+          end else
+            Some { vm_code = code; vm_upvalues = [||];
+                   vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
         else begin
           Printf.eprintf "[jit] FAIL %s: closure index %d out of bounds (pool=%d)\n%!"
             fn_name idx (Array.length outer_code.vc_constants);
@@ -1192,7 +1295,12 @@ let opcode_name = function
   | 164 -> "EQ" | 165 -> "LT" | 166 -> "GT" | 167 -> "NOT"
   | 168 -> "LEN" | 169 -> "FIRST" | 170 -> "REST" | 171 -> "NTH"
   | 172 -> "CONS" | 173 -> "NEG" | 174 -> "INC" | 175 -> "DEC"
-  | n -> Printf.sprintf "UNKNOWN_%d" n
+  | n ->
+    (* Extension opcodes (≥200) get their human-readable name from the
+       registry; defaults to UNKNOWN_n if the extension isn't loaded. *)
+    (match !extension_opcode_name_ref n with
+     | Some name -> name
+     | None -> Printf.sprintf "UNKNOWN_%d" n)
 
 (** Number of extra operand bytes consumed by each opcode.
     Returns (format, total_bytes) where format describes the operand types. *)

hosts/ocaml/lib/sx_vm_extension.ml

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

hosts/ocaml/lib/sx_vm_extensions.ml

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

lib/apl/parser.sx

@@ -416,10 +416,20 @@
                 ((apl-parse-op-glyph? tv)
                   (if
                     (or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
-                    (collect-segments-loop
-                      tokens
-                      (+ i 1)
-                      (append acc {:kind "fn" :node (list :fn-glyph tv)}))
+                    (let
+                      ((next-i (+ i 1)))
+                      (let
+                        ((next-tok (if (< next-i n) (nth tokens next-i) nil)))
+                        (let
+                          ((mod (if (and next-tok (= (tok-type next-tok) :glyph) (or (= (get next-tok :value) "⍨") (= (get next-tok :value) "¨"))) (get next-tok :value) nil))
+                            (base-fn-node (list :fn-glyph tv)))
+                          (let
+                            ((node (if mod (list :derived-fn mod base-fn-node) base-fn-node))
+                              (advance (if mod 2 1)))
+                            (collect-segments-loop
+                              tokens
+                              (+ i advance)
+                              (append acc {:kind "fn" :node node}))))))
                     (collect-segments-loop tokens (+ i 1) acc)))
                 (true (collect-segments-loop tokens (+ i 1) acc))))
             (true (collect-segments-loop tokens (+ i 1) acc))))))))

lib/apl/runtime.sx

@@ -65,10 +65,30 @@
             (get a :shape)
             (map (fn (x) (f x sv)) (get a :ravel)))))
       (else
-        (if
-          (equal? (get a :shape) (get b :shape))
-          (make-array (get a :shape) (map f (get a :ravel) (get b :ravel)))
-          (error "length error: shape mismatch"))))))
+        (let
+          ((a-shape (get a :shape)) (b-shape (get b :shape)))
+          (cond
+            ((equal? a-shape b-shape)
+              (make-array a-shape (map f (get a :ravel) (get b :ravel))))
+            ((and (= (len a-shape) 1) (> (len b-shape) 1))
+              (make-array
+                (append a-shape b-shape)
+                (flatten
+                  (map
+                    (fn
+                      (x)
+                      (get (broadcast-dyadic f (apl-scalar x) b) :ravel))
+                    (get a :ravel)))))
+            ((and (= (len b-shape) 1) (> (len a-shape) 1))
+              (make-array
+                (append a-shape b-shape)
+                (flatten
+                  (map
+                    (fn
+                      (acell)
+                      (get (broadcast-dyadic f (apl-scalar acell) b) :ravel))
+                    (get a :ravel)))))
+            (else (error "length error: shape mismatch"))))))))
 
 ; ============================================================
 ; Arithmetic primitives
@@ -827,6 +847,106 @@
               ((new-ravel (reduce (fn (acc r) (append acc (map (fn (j) (nth ravel (+ (* r cols) j))) (range 0 cols)))) (list) kept-rows)))
               (make-array (cons (len kept-rows) (rest shape)) new-ravel))))))))
 
+(define
+  apl-where
+  (fn
+    (arr)
+    (let
+      ((ravel (get arr :ravel)) (io (disclose (apl-quad-io))))
+      (let
+        ((indices (filter (fn (i) (not (= (nth ravel i) 0))) (range 0 (len ravel)))))
+        (apl-vector (map (fn (i) (+ i io)) indices))))))
+
+(define
+  apl-interval-index
+  (fn
+    (breaks vals)
+    (let
+      ((b-ravel (get breaks :ravel))
+        (v-ravel
+          (if (scalar? vals) (list (disclose vals)) (get vals :ravel))))
+      (let
+        ((result (map (fn (y) (len (filter (fn (b) (<= b y)) b-ravel))) v-ravel)))
+        (if
+          (scalar? vals)
+          (apl-scalar (first result))
+          (make-array (get vals :shape) result))))))
+
+(define
+  apl-unique
+  (fn
+    (arr)
+    (let
+      ((ravel (if (scalar? arr) (list (disclose arr)) (get arr :ravel))))
+      (let
+        ((dedup (reduce (fn (acc x) (if (index-of acc x) acc (append acc (list x)))) (list) ravel)))
+        (apl-vector dedup)))))
+
+(define
+  apl-union
+  (fn
+    (a b)
+    (let
+      ((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel)))
+        (b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel))))
+      (let
+        ((a-dedup (reduce (fn (acc x) (if (index-of acc x) acc (append acc (list x)))) (list) a-ravel)))
+        (let
+          ((b-extra (filter (fn (x) (not (index-of a-dedup x))) b-ravel)))
+          (let
+            ((b-extra-dedup (reduce (fn (acc x) (if (index-of acc x) acc (append acc (list x)))) (list) b-extra)))
+            (apl-vector (append a-dedup b-extra-dedup))))))))
+
+(define
+  apl-intersect
+  (fn
+    (a b)
+    (let
+      ((a-ravel (if (scalar? a) (list (disclose a)) (get a :ravel)))
+        (b-ravel (if (scalar? b) (list (disclose b)) (get b :ravel))))
+      (apl-vector (filter (fn (x) (index-of b-ravel x)) a-ravel)))))
+
+(define
+  apl-decode
+  (fn
+    (base digits)
+    (let
+      ((d-ravel (if (scalar? digits) (list (disclose digits)) (get digits :ravel))))
+      (let
+        ((d-len (len d-ravel)))
+        (let
+          ((b-ravel (if (scalar? base) (let ((b (disclose base))) (map (fn (i) b) (range 0 d-len))) (get base :ravel))))
+          (let
+            ((result (reduce (fn (acc i) (if (= i 0) (nth d-ravel 0) (+ (* acc (nth b-ravel i)) (nth d-ravel i)))) 0 (range 0 d-len))))
+            (apl-scalar result)))))))
+
+(define
+  apl-encode
+  (fn
+    (base val)
+    (let
+      ((b-ravel (if (scalar? base) (list (disclose base)) (get base :ravel)))
+        (n (if (scalar? val) (disclose val) (first (get val :ravel)))))
+      (let
+        ((b-len (len b-ravel)))
+        (let
+          ((result (reduce (fn (acc-and-n i) (let ((acc (first acc-and-n)) (rem (nth acc-and-n 1))) (let ((b (nth b-ravel (- (- b-len 1) i)))) (if (= b 0) (list (cons rem acc) 0) (list (cons (modulo rem b) acc) (floor (/ rem b))))))) (list (list) n) (range 0 b-len))))
+          (apl-vector (first result)))))))
+
+(define
+  apl-partition
+  (fn
+    (mask val)
+    (let
+      ((m-ravel (if (scalar? mask) (list (disclose mask)) (get mask :ravel)))
+        (v-ravel
+          (if (scalar? val) (list (disclose val)) (get val :ravel))))
+      (let
+        ((n (len m-ravel)))
+        (let
+          ((built (reduce (fn (acc-and-prev i) (let ((acc (first acc-and-prev)) (prev (nth acc-and-prev 1))) (let ((mi (nth m-ravel i)) (vi (nth v-ravel i))) (cond ((= mi 0) (list acc 0)) ((> mi prev) (list (append acc (list (list vi))) mi)) (else (let ((idx (- (len acc) 1))) (list (append (slice acc 0 idx) (list (append (nth acc idx) (list vi)))) mi))))))) (list (list) 0) (range 0 n))))
+          (apl-vector (map (fn (part) (apl-vector part)) (first built))))))))
+
 (define
   apl-primes
   (fn
@@ -1074,11 +1194,9 @@
             (if
               (= n 0)
               (apl-scalar 0)
-              (apl-scalar
-                (reduce
-                  (fn (a b) (disclose (f (apl-scalar a) (apl-scalar b))))
-                  (first ravel)
-                  (rest ravel)))))
+              (let
+                ((rr (reduce (fn (a b) (let ((wa (if (= (type-of a) "dict") a (apl-scalar a))) (wb (if (= (type-of b) "dict") b (apl-scalar b)))) (let ((r (f wa wb))) (if (scalar? r) (disclose r) r)))) (first ravel) (rest ravel))))
+                (if (= (type-of rr) "dict") rr (apl-scalar rr)))))
           (let
             ((last-dim (last shape))
               (pre-shape (take shape (- (len shape) 1)))
@@ -1100,7 +1218,13 @@
                       (reduce
                         (fn
                           (a b)
-                          (disclose (f (apl-scalar a) (apl-scalar b))))
+                          (let
+                            ((wa (if (= (type-of a) "dict") a (apl-scalar a)))
+                              (wb
+                                (if (= (type-of b) "dict") b (apl-scalar b))))
+                            (let
+                              ((r (f wa wb)))
+                              (if (scalar? r) (disclose r) r))))
                         (first elems)
                         (rest elems)))))
                 (range 0 pre-size)))))))))
@@ -1241,13 +1365,29 @@
     (cond
       ((and (scalar? a) (scalar? b)) (apl-scalar (disclose (f a b))))
       ((scalar? a)
-        (make-array
-          (get b :shape)
-          (map (fn (x) (disclose (f a (apl-scalar x)))) (get b :ravel))))
+        (let
+          ((a-eff (let ((d (disclose a))) (if (= (type-of d) "dict") d a))))
+          (make-array
+            (get b :shape)
+            (map
+              (fn
+                (x)
+                (let
+                  ((r (f a-eff (apl-scalar x))))
+                  (if (scalar? r) (disclose r) r)))
+              (get b :ravel)))))
       ((scalar? b)
-        (make-array
-          (get a :shape)
-          (map (fn (x) (disclose (f (apl-scalar x) b))) (get a :ravel))))
+        (let
+          ((b-eff (let ((d (disclose b))) (if (= (type-of d) "dict") d b))))
+          (make-array
+            (get a :shape)
+            (map
+              (fn
+                (x)
+                (let
+                  ((r (f (apl-scalar x) b-eff)))
+                  (if (scalar? r) (disclose r) r)))
+              (get a :ravel)))))
       (else
         (if
           (equal? (get a :shape) (get b :shape))
@@ -1268,16 +1408,22 @@
         (b-shape (get b :shape))
         (a-ravel (get a :ravel))
         (b-ravel (get b :ravel)))
-      (make-array
-        (append a-shape b-shape)
-        (flatten
-          (map
-            (fn
-              (x)
-              (map
-                (fn (y) (disclose (f (apl-scalar x) (apl-scalar y))))
-                b-ravel))
-            a-ravel))))))
+      (let
+        ((wrap (fn (x) (if (= (type-of x) "dict") x (apl-scalar x)))))
+        (make-array
+          (append a-shape b-shape)
+          (flatten
+            (map
+              (fn
+                (x)
+                (map
+                  (fn
+                    (y)
+                    (let
+                      ((r (f (wrap x) (wrap y))))
+                      (if (scalar? r) (disclose r) r)))
+                  b-ravel))
+              a-ravel)))))))
 
 (define
   apl-inner
@@ -1301,25 +1447,12 @@
               ((a-pre-size (reduce * 1 a-pre))
                 (b-post-size (reduce * 1 b-post))
                 (new-shape (append a-pre b-post)))
-              (make-array
-                new-shape
-                (flatten
-                  (map
-                    (fn
-                      (i)
-                      (map
-                        (fn
-                          (j)
-                          (let
-                            ((pairs (map (fn (k) (disclose (g (apl-scalar (nth a-ravel (+ (* i inner-dim) k))) (apl-scalar (nth b-ravel (+ (* k b-post-size) j)))))) (range 0 inner-dim))))
-                            (reduce
-                              (fn
-                                (x y)
-                                (disclose (f (apl-scalar x) (apl-scalar y))))
-                              (first pairs)
-                              (rest pairs))))
-                        (range 0 b-post-size)))
-                    (range 0 a-pre-size)))))))))))
+              (let
+                ((result (make-array new-shape (flatten (map (fn (i) (map (fn (j) (let ((pairs (map (fn (k) (let ((a-elem (nth a-ravel (+ (* i inner-dim) k))) (b-elem (nth b-ravel (+ (* k b-post-size) j)))) (let ((a-cell (if (= (type-of a-elem) "dict") (nth (get a-elem :ravel) j) a-elem)) (b-cell (if (= (type-of b-elem) "dict") (nth (get b-elem :ravel) 0) b-elem))) (disclose (g (apl-scalar a-cell) (apl-scalar b-cell)))))) (range 0 inner-dim)))) (reduce (fn (x y) (let ((wx (if (= (type-of x) "dict") x (apl-scalar x))) (wy (if (= (type-of y) "dict") y (apl-scalar y)))) (let ((r (f wx wy))) (if (scalar? r) (disclose r) r)))) (first pairs) (rest pairs)))) (range 0 b-post-size))) (range 0 a-pre-size))))))
+                (if
+                  (some (fn (x) (= (type-of x) "dict")) a-ravel)
+                  (enclose result)
+                  result)))))))))
 
 (define apl-commute (fn (f x) (f x x)))
 

lib/apl/tests/pipeline.sx

@@ -455,3 +455,233 @@
   (list 1 2 3))
 
 (apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")
+
+(begin
+  (apl-test
+    "⍸ where: indices of truthy cells"
+    (mkrv (apl-run "⍸ 0 1 0 1 1"))
+    (list 2 4 5))
+  (apl-test
+    "⍸ where: leading truthy"
+    (mkrv (apl-run "⍸ 1 0 0 1 1"))
+    (list 1 4 5))
+  (apl-test
+    "⍸ where: all-zero → empty"
+    (mkrv (apl-run "⍸ 0 0 0"))
+    (list))
+  (apl-test
+    "⍸ where: all-truthy"
+    (mkrv (apl-run "⍸ 1 1 1"))
+    (list 1 2 3))
+  (apl-test
+    "⍸ where: ⎕IO=1 (1-based)"
+    (mkrv (apl-run "⍸ (⍳5)=3"))
+    (list 3))
+  (apl-test
+    "⍸ interval-index: 2 4 6 ⍸ 5 → 2"
+    (mkrv (apl-run "2 4 6 ⍸ 5"))
+    (list 2))
+  (apl-test
+    "⍸ interval-index: 2 4 6 ⍸ 1 3 5 6 7 → 0 1 2 3 3"
+    (mkrv (apl-run "2 4 6 ⍸ 1 3 5 6 7"))
+    (list 0 1 2 3 3))
+  (apl-test
+    "⍸ interval-index: ⍳5 ⍸ 3 → 3"
+    (mkrv (apl-run "(⍳5) ⍸ 3"))
+    (list 3))
+  (apl-test
+    "⍸ interval-index: y below all → 0"
+    (mkrv (apl-run "10 20 30 ⍸ 5"))
+    (list 0))
+  (apl-test
+    "⍸ interval-index: y above all → len breaks"
+    (mkrv (apl-run "10 20 30 ⍸ 100"))
+    (list 3)))
+
+(begin
+  (apl-test
+    "∪ unique: dedup keeps first-occurrence order"
+    (mkrv (apl-run "∪ 1 2 1 3 2 1 4"))
+    (list 1 2 3 4))
+  (apl-test
+    "∪ unique: already-unique unchanged"
+    (mkrv (apl-run "∪ 5 4 3 2 1"))
+    (list 5 4 3 2 1))
+  (apl-test "∪ unique: scalar" (mkrv (apl-run "∪ 7")) (list 7))
+  (apl-test
+    "∪ unique: string mississippi → misp"
+    (mkrv (apl-run "∪ 'mississippi'"))
+    (list "m" "i" "s" "p"))
+  (apl-test
+    "∪ union: 1 2 3 ∪ 3 4 5 → 1 2 3 4 5"
+    (mkrv (apl-run "1 2 3 ∪ 3 4 5"))
+    (list 1 2 3 4 5))
+  (apl-test
+    "∪ union: dedups left side too"
+    (mkrv (apl-run "1 2 1 ∪ 1 3 2"))
+    (list 1 2 3))
+  (apl-test
+    "∪ union: disjoint → catenated"
+    (mkrv (apl-run "1 2 ∪ 3 4"))
+    (list 1 2 3 4))
+  (apl-test
+    "∩ intersection: 1 2 3 4 ∩ 2 4 6 → 2 4"
+    (mkrv (apl-run "1 2 3 4 ∩ 2 4 6"))
+    (list 2 4))
+  (apl-test
+    "∩ intersection: disjoint → empty"
+    (mkrv (apl-run "1 2 3 ∩ 4 5 6"))
+    (list))
+  (apl-test
+    "∩ intersection: preserves left order"
+    (mkrv (apl-run "(⍳5) ∩ 5 3 1"))
+    (list 1 3 5))
+  (apl-test
+    "∩ intersection: identical"
+    (mkrv (apl-run "1 2 3 ∩ 1 2 3"))
+    (list 1 2 3))
+  (apl-test
+    "∪/∩ identity: A ∪ A = ∪A"
+    (mkrv (apl-run "1 2 1 ∪ 1 2 1"))
+    (list 1 2)))
+
+(begin
+  (apl-test
+    "⊥ decode: 2 2 2 ⊥ 1 0 1 → 5"
+    (mkrv (apl-run "2 2 2 ⊥ 1 0 1"))
+    (list 5))
+  (apl-test
+    "⊥ decode: 10 10 10 ⊥ 1 2 3 → 123"
+    (mkrv (apl-run "10 10 10 ⊥ 1 2 3"))
+    (list 123))
+  (apl-test
+    "⊥ decode: 24 60 60 ⊥ 2 3 4 → 7384 (mixed-radix HMS)"
+    (mkrv (apl-run "24 60 60 ⊥ 2 3 4"))
+    (list 7384))
+  (apl-test
+    "⊥ decode: scalar base 2 ⊥ 1 0 1 0 → 10"
+    (mkrv (apl-run "2 ⊥ 1 0 1 0"))
+    (list 10))
+  (apl-test
+    "⊥ decode: 16 16 ⊥ 15 15 → 255"
+    (mkrv (apl-run "16 16 ⊥ 15 15"))
+    (list 255))
+  (apl-test
+    "⊤ encode: 2 2 2 ⊤ 5 → 1 0 1"
+    (mkrv (apl-run "2 2 2 ⊤ 5"))
+    (list 1 0 1))
+  (apl-test
+    "⊤ encode: 24 60 60 ⊤ 7384 → 2 3 4 (HMS)"
+    (mkrv (apl-run "24 60 60 ⊤ 7384"))
+    (list 2 3 4))
+  (apl-test
+    "⊤ encode: 2 2 2 2 ⊤ 13 → 1 1 0 1"
+    (mkrv (apl-run "2 2 2 2 ⊤ 13"))
+    (list 1 1 0 1))
+  (apl-test
+    "⊤ encode: 10 10 ⊤ 42 → 4 2"
+    (mkrv (apl-run "10 10 ⊤ 42"))
+    (list 4 2))
+  (apl-test
+    "⊤ encode: round-trip B⊥(B⊤N) = N"
+    (mkrv (apl-run "24 60 60 ⊥ 24 60 60 ⊤ 7384"))
+    (list 7384))
+  (apl-test
+    "⊥ decode: round-trip B⊤(B⊥V) = V"
+    (mkrv (apl-run "2 2 2 ⊤ 2 2 2 ⊥ 1 0 1"))
+    (list 1 0 1)))
+
+(begin
+  (define
+    mk-parts
+    (fn (s) (map (fn (p) (get p :ravel)) (get (apl-run s) :ravel))))
+  (apl-test
+    "⊆ partition: 1 1 0 1 1 ⊆ 'abcde' → ('ab' 'de')"
+    (mk-parts "1 1 0 1 1 ⊆ 'abcde'")
+    (list (list "a" "b") (list "d" "e")))
+  (apl-test
+    "⊆ partition: 1 0 0 1 1 ⊆ ⍳5 → ((1) (4 5))"
+    (mk-parts "1 0 0 1 1 ⊆ ⍳5")
+    (list (list 1) (list 4 5)))
+  (apl-test
+    "⊆ partition: all-zero mask → empty"
+    (len (get (apl-run "0 0 0 ⊆ 1 2 3") :ravel))
+    0)
+  (apl-test
+    "⊆ partition: all-one mask → single partition"
+    (mk-parts "1 1 1 ⊆ 7 8 9")
+    (list (list 7 8 9)))
+  (apl-test
+    "⊆ partition: strict increase 1 2 starts new"
+    (mk-parts "1 2 ⊆ 10 20")
+    (list (list 10) (list 20)))
+  (apl-test
+    "⊆ partition: same level continues 2 2 → one partition"
+    (mk-parts "2 2 ⊆ 10 20")
+    (list (list 10 20)))
+  (apl-test
+    "⊆ partition: 0 separates"
+    (mk-parts "1 1 0 0 1 ⊆ 1 2 3 4 5")
+    (list (list 1 2) (list 5)))
+  (apl-test
+    "⊆ partition: outer length matches partition count"
+    (len (get (apl-run "1 0 1 0 1 ⊆ ⍳5") :ravel))
+    3))
+
+(begin
+  (apl-test
+    "⍎ execute: ⍎ '1 + 2' → 3"
+    (mkrv (apl-run "⍎ '1 + 2'"))
+    (list 3))
+  (apl-test
+    "⍎ execute: ⍎ '+/⍳10' → 55"
+    (mkrv (apl-run "⍎ '+/⍳10'"))
+    (list 55))
+  (apl-test
+    "⍎ execute: ⍎ '⌈/ 1 3 9 5 7' → 9"
+    (mkrv (apl-run "⍎ '⌈/ 1 3 9 5 7'"))
+    (list 9))
+  (apl-test
+    "⍎ execute: ⍎ '⍳5' → 1..5"
+    (mkrv (apl-run "⍎ '⍳5'"))
+    (list 1 2 3 4 5))
+  (apl-test
+    "⍎ execute: ⍎ '×/⍳5' → 120"
+    (mkrv (apl-run "⍎ '×/⍳5'"))
+    (list 120))
+  (apl-test
+    "⍎ execute: round-trip ⍎ ⎕FMT 42 → 42"
+    (mkrv (apl-run "⍎ ⎕FMT 42"))
+    (list 42))
+  (apl-test
+    "⍎ execute: nested ⍎ ⍎"
+    (mkrv (apl-run "⍎ '⍎ ''2 × 3'''"))
+    (list 6))
+  (apl-test
+    "⍎ execute: with assignment side-effect"
+    (mkrv (apl-run "⍎ 'q ← 99 ⋄ q + 1'"))
+    (list 100)))
+
+(begin
+  (apl-test
+    "het-inner: 1 ⍵ ∨.∧ X — result is enclosed (5 5)"
+    (let
+      ((r (apl-run "B ← 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 ⋄ X ← 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂B ⋄ 1 B ∨.∧ X")))
+      (list
+        (len (get r :shape))
+        (= (type-of (first (get r :ravel))) "dict")))
+    (list 0 true))
+  (apl-test
+    "het-inner: ⊃ unwraps to (5 5) board"
+    (mksh
+      (apl-run
+        "B ← 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 ⋄ X ← 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂B ⋄ ⊃ 1 B ∨.∧ X"))
+    (list 5 5))
+  (apl-test
+    "het-inner: homogeneous inner product unaffected"
+    (mkrv (apl-run "1 2 3 +.× 4 5 6"))
+    (list 32))
+  (apl-test
+    "het-inner: matrix inner product unaffected"
+    (mkrv (apl-run "(2 2 ⍴ 1 2 3 4) +.× 2 2 ⍴ 5 6 7 8"))
+    (list 19 22 43 50)))

lib/apl/tests/programs-e2e.sx

@@ -94,3 +94,96 @@
   "e2e: sqrt-via-newton 1 step from 1 → 2.5"
   (mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1"))
   (list 2.5))
+
+(begin
+  (apl-test
+    "life.apl: blinker 5×5 → vertical blinker"
+    (mkrv
+      (apl-run
+        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0"))
+    (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))
+  (apl-test
+    "life.apl: blinker oscillates (period 2)"
+    (mkrv
+      (apl-run
+        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life life 5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0"))
+    (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
+  (apl-test
+    "life.apl: 2×2 block stable"
+    (mkrv
+      (apl-run
+        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 4 4 ⍴ 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 0"))
+    (list 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 0))
+  (apl-test
+    "life.apl: empty grid stays empty"
+    (mkrv
+      (apl-run
+        "life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵} ⋄ life 5 5 ⍴ 0"))
+    (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+  (apl-test
+    "life.apl: source-file as-written runs"
+    (let
+      ((dfn (apl-run-file "lib/apl/tests/programs/life.apl"))
+        (board
+          (apl-run "5 5 ⍴ 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0")))
+      (get (apl-call-dfn-m dfn board) :ravel))
+    (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0)))
+
+(begin
+  (apl-test
+    "quicksort.apl: 11-element with duplicates"
+    (begin
+      (apl-rng-seed! 42)
+      (mkrv
+        (apl-run
+          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 3 1 4 1 5 9 2 6 5 3 5")))
+    (list 1 1 2 3 3 4 5 5 5 6 9))
+  (apl-test
+    "quicksort.apl: already sorted"
+    (begin
+      (apl-rng-seed! 42)
+      (mkrv
+        (apl-run
+          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 1 2 3 4 5")))
+    (list 1 2 3 4 5))
+  (apl-test
+    "quicksort.apl: reverse sorted"
+    (begin
+      (apl-rng-seed! 42)
+      (mkrv
+        (apl-run
+          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 5 4 3 2 1")))
+    (list 1 2 3 4 5))
+  (apl-test
+    "quicksort.apl: all equal"
+    (begin
+      (apl-rng-seed! 42)
+      (mkrv
+        (apl-run
+          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort 7 7 7 7")))
+    (list 7 7 7 7))
+  (apl-test
+    "quicksort.apl: single element"
+    (begin
+      (apl-rng-seed! 42)
+      (mkrv
+        (apl-run
+          "quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort ,42")))
+    (list 42))
+  (apl-test
+    "quicksort.apl: matches grade-up"
+    (begin
+      (apl-rng-seed! 42)
+      (mkrv
+        (apl-run
+          "V ← 8 3 1 9 2 7 5 6 4 ⋄ quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p} ⋄ quicksort V")))
+    (list 1 2 3 4 5 6 7 8 9))
+  (apl-test
+    "quicksort.apl: source-file as-written runs"
+    (begin
+      (apl-rng-seed! 42)
+      (let
+        ((dfn (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
+          (vec (apl-run "5 2 8 1 9 3 7 4 6")))
+        (get (apl-call-dfn-m dfn vec) :ravel)))
+    (list 1 2 3 4 5 6 7 8 9)))

lib/apl/tests/programs/life.apl

@@ -8,9 +8,9 @@
 ⍝   ¯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
+⍝   3 4 = …           : leading-axis-extended boolean — count is 3 (born) or 4 (survive)
 ⍝   1 ⍵ ∨.∧ …         : "alive next" iff (count=3) or (alive AND count=4)
-⍝   ⊃ …               : disclose back to a 2D board
+⍝   ⊃ …               : disclose the enclosed result back to a 2D board
 ⍝
 ⍝ Rules in plain language:
 ⍝   - dead cell + 3 live neighbors → born

lib/apl/tokenizer.sx

@@ -19,162 +19,180 @@
              (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)
+(define
+  apl-tokenize
+  (fn
+    (source)
+    (let
+      ((pos 0) (src-len (len source)) (tokens (list)))
+      (define tok-push! (fn (type value) (append! tokens {:value value :type type})))
+      (define
+        cur-sw?
+        (fn
+          (ch)
           (and (< pos src-len) (starts-with? (slice source pos) ch))))
-
-      (define cur-byte
-        (fn ()
-          (if (< pos src-len) (nth source pos) nil)))
-
-      (define advance!
-        (fn ()
-          (set! pos (+ pos 1))))
-
-      (define consume!
-        (fn (ch)
-          (set! pos (+ pos (len ch)))))
-
-      (define find-glyph
-        (fn ()
-          (let ((rem (slice source pos)))
-            (let ((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set)))
+      (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))))
+      (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)
+      (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)))
+              (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)))
+              (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!)))
+                  (begin (advance!) (scan!)))
                 ((= ch "\n")
-                 (begin (advance!) (tok-push! :newline nil) (scan!)))
-                ((cur-sw? "⍝")
-                 (begin (skip-line!) (scan!)))
+                  (begin (advance!) (tok-push! :newline nil) (scan!)))
+                ((cur-sw? "⍝") (begin (skip-line!) (scan!)))
                 ((cur-sw? "⋄")
-                 (begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
+                  (begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
                 ((= ch "(")
-                 (begin (advance!) (tok-push! :lparen nil) (scan!)))
+                  (begin (advance!) (tok-push! :lparen nil) (scan!)))
                 ((= ch ")")
-                 (begin (advance!) (tok-push! :rparen nil) (scan!)))
+                  (begin (advance!) (tok-push! :rparen nil) (scan!)))
                 ((= ch "[")
-                 (begin (advance!) (tok-push! :lbracket nil) (scan!)))
+                  (begin (advance!) (tok-push! :lbracket nil) (scan!)))
                 ((= ch "]")
-                 (begin (advance!) (tok-push! :rbracket nil) (scan!)))
+                  (begin (advance!) (tok-push! :rbracket nil) (scan!)))
                 ((= ch "{")
-                 (begin (advance!) (tok-push! :lbrace nil) (scan!)))
+                  (begin (advance!) (tok-push! :lbrace nil) (scan!)))
                 ((= ch "}")
-                 (begin (advance!) (tok-push! :rbrace nil) (scan!)))
+                  (begin (advance!) (tok-push! :rbrace nil) (scan!)))
                 ((= ch ";")
-                 (begin (advance!) (tok-push! :semi nil) (scan!)))
+                  (begin (advance!) (tok-push! :semi nil) (scan!)))
                 ((cur-sw? "←")
-                 (begin (consume! "←") (tok-push! :assign nil) (scan!)))
+                  (begin (consume! "←") (tok-push! :assign nil) (scan!)))
                 ((= ch ":")
-                 (let ((start pos))
-                   (begin
-                     (advance!)
-                     (if (and (< pos src-len) (apl-alpha? (cur-byte)))
-                       (begin
-                         (read-ident-cont!)
-                         (tok-push! :keyword (slice source start pos)))
-                       (tok-push! :colon nil))
-                     (scan!))))
-                ((and (cur-sw? "¯")
-                      (< (+ pos (len "¯")) src-len)
-                      (apl-digit? (nth source (+ pos (len "¯")))))
-                 (begin
-                   (consume! "¯")
-                   (let ((digits (read-digits! "")))
-                     (if (and (< pos src-len) (= (cur-byte) ".")
-                              (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
-                       (begin (advance!)
-                              (let ((frac (read-digits! "")))
-                                (tok-push! :num (- 0 (string->number (str digits "." frac))))))
-                       (tok-push! :num (- 0 (parse-int digits 0)))))
-                   (scan!)))
+                  (let
+                    ((start pos))
+                    (begin
+                      (advance!)
+                      (if
+                        (and (< pos src-len) (apl-alpha? (cur-byte)))
+                        (begin
+                          (read-ident-cont!)
+                          (tok-push! :keyword (slice source start pos)))
+                        (tok-push! :colon nil))
+                      (scan!))))
+                ((and (cur-sw? "¯") (< (+ pos (len "¯")) src-len) (apl-digit? (nth source (+ pos (len "¯")))))
+                  (begin
+                    (consume! "¯")
+                    (let
+                      ((digits (read-digits! "")))
+                      (if
+                        (and
+                          (< pos src-len)
+                          (= (cur-byte) ".")
+                          (< (+ pos 1) src-len)
+                          (apl-digit? (nth source (+ pos 1))))
+                        (begin
+                          (advance!)
+                          (let
+                            ((frac (read-digits! "")))
+                            (tok-push!
+                              :num (- 0 (string->number (str digits "." frac))))))
+                        (tok-push! :num (- 0 (parse-int digits 0)))))
+                    (scan!)))
                 ((apl-digit? ch)
-                 (begin
-                   (let ((digits (read-digits! "")))
-                     (if (and (< pos src-len) (= (cur-byte) ".")
-                              (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
-                       (begin (advance!)
-                              (let ((frac (read-digits! "")))
-                                (tok-push! :num (string->number (str digits "." frac)))))
-                       (tok-push! :num (parse-int digits 0))))
-                   (scan!)))
+                  (begin
+                    (let
+                      ((digits (read-digits! "")))
+                      (if
+                        (and
+                          (< pos src-len)
+                          (= (cur-byte) ".")
+                          (< (+ pos 1) src-len)
+                          (apl-digit? (nth source (+ pos 1))))
+                        (begin
+                          (advance!)
+                          (let
+                            ((frac (read-digits! "")))
+                            (tok-push!
+                              :num (string->number (str digits "." frac)))))
+                        (tok-push! :num (parse-int digits 0))))
+                    (scan!)))
                 ((= ch "'")
-                 (begin
-                   (advance!)
-                   (let ((s (read-string! "")))
-                     (tok-push! :str s))
-                   (scan!)))
+                  (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!))
-                     (if (and (< pos src-len) (cur-sw? "←"))
-                       (consume! "←")
-                       (read-ident-cont!))
-                     (tok-push! :name (slice source start pos))
-                     (scan!))))
+                  (let
+                    ((start pos))
+                    (begin
+                      (if
+                        (cur-sw? "⎕")
+                        (begin
+                          (consume! "⎕")
+                          (if
+                            (and (< pos src-len) (cur-sw? "←"))
+                            (consume! "←")
+                            (read-ident-cont!)))
+                        (begin (advance!) (read-ident-cont!)))
+                      (tok-push! :name (slice source start pos))
+                      (scan!))))
                 (true
-                 (let ((g (find-glyph)))
-                   (if g
-                     (begin (consume! g) (tok-push! :glyph g) (scan!))
-                     (begin (advance!) (scan!))))))))))
-
+                  (let
+                    ((g (find-glyph)))
+                    (if
+                      g
+                      (begin (consume! g) (tok-push! :glyph g) (scan!))
+                      (begin (advance!) (scan!))))))))))
       (scan!)
       tokens)))

lib/apl/transpile.sx

@@ -46,6 +46,9 @@
       ((= g "⍕") apl-quad-fmt)
       ((= g "⎕FMT") apl-quad-fmt)
       ((= g "⎕←") apl-quad-print)
+      ((= g "⍸") apl-where)
+      ((= g "∪") apl-unique)
+      ((= g "⍎") apl-execute)
       (else (error "no monadic fn for glyph")))))
 
 (define
@@ -90,6 +93,12 @@
       ((= g "⍉") apl-transpose-dyadic)
       ((= g "⊢") (fn (a b) b))
       ((= g "⊣") (fn (a b) a))
+      ((= g "⍸") apl-interval-index)
+      ((= g "∪") apl-union)
+      ((= g "∩") apl-intersect)
+      ((= g "⊥") apl-decode)
+      ((= g "⊤") apl-encode)
+      ((= g "⊆") apl-partition)
       (else (error "no dyadic fn for glyph")))))
 
 (define
@@ -124,7 +133,14 @@
               ((vals (map (fn (n) (apl-eval-ast n env)) items)))
               (make-array
                 (list (len vals))
-                (map (fn (v) (first (get v :ravel))) vals)))))
+                (map
+                  (fn
+                    (v)
+                    (if
+                      (= (len (get v :shape)) 0)
+                      (first (get v :ravel))
+                      v))
+                  vals)))))
         ((= tag :name)
           (let
             ((nm (nth node 1)))
@@ -566,3 +582,11 @@
 (define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
 
 (define apl-run-file (fn (path) (apl-run (file-read path))))
+
+(define
+  apl-execute
+  (fn
+    (arr)
+    (let
+      ((src (cond ((string? arr) arr) ((scalar? arr) (disclose arr)) (else (reduce str "" (get arr :ravel))))))
+      (apl-run src))))

lib/common-lisp/clos.sx

@@ -330,37 +330,22 @@
                     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))))
+;; CLOS-side adapter for lib/guest/reflective/class-chain.sx. Classes
+;; live in clos-class-registry; :parents is a list of parent class
+;; names (CLOS supports multiple inheritance).
+(define clos-class-cfg
+  {:parents-of (fn (cn)
+                 (let ((rec (clos-find-class cn)))
+                   (cond ((nil? rec) (list))
+                         (:else (or (get rec "parents") (list))))))
+   :class?     (fn (n) (not (nil? (clos-find-class n))))})
+
+;; Precedence distance: how far class-name is from spec-name up the
+;; hierarchy. Delegates to refl-class-chain-depth-with which handles
+;; the multi-parent DFS with min-depth selection.
+(define clos-specificity
+  (fn (class-name spec-name)
+    (refl-class-chain-depth-with clos-class-cfg class-name spec-name)))
 
 (define
   clos-method-more-specific?

lib/common-lisp/test.sh

@@ -368,7 +368,7 @@ run_program_suite \
 
 # ── Phase 4: CLOS unit tests ─────────────────────────────────────────────────
 CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT
-printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
+printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
 CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null)
 rm -f "$CLOS_FILE"
 CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
@@ -389,7 +389,7 @@ fi
 run_clos_suite() {
   local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
   local PROG_FILE=$(mktemp)
-  printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
+  printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/guest/reflective/class-chain.sx")\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
     "$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
   local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
   rm -f "$PROG_FILE"

lib/datalog/aggregates.sx

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

lib/datalog/api.sx

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

lib/datalog/builtins.sx

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

lib/datalog/conformance.conf

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

lib/datalog/conformance.sh

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

lib/datalog/datalog.sx

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

lib/datalog/db.sx

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

lib/datalog/demo.sx

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

lib/datalog/eval.sx

@@ -0,0 +1,512 @@
+;; lib/datalog/eval.sx — fixpoint evaluator (naive + semi-naive).
+;;
+;; Two saturators are exposed:
+;;   `dl-saturate-naive!` — re-joins each rule against the full DB every
+;;     iteration. Reference implementation; useful for differential tests.
+;;   `dl-saturate!`       — semi-naive default. Tracks per-relation delta
+;;     sets and substitutes one positive body literal per rule with the
+;;     delta of its relation, joining the rest against the previous-
+;;     iteration DB. Same fixpoint, dramatically less work on recursive
+;;     rules.
+;;
+;; Body literal kinds:
+;;   positive (rel arg ... arg)  → match against EDB+IDB tuples
+;;   built-in (< X Y), (is X e)  → constraint via dl-eval-builtin
+;;   negation {:neg lit}         → Phase 7
+
+(define
+  dl-match-positive
+  (fn
+    (lit db subst)
+    (let
+      ((rel (dl-rel-name lit)) (results (list)))
+      (cond
+        ((nil? rel) (error (str "dl-match-positive: bad literal " lit)))
+        (else
+          (let
+            ;; If the first argument walks to a non-variable (constant
+            ;; or already-bound var), use the first-arg index for
+            ;; this relation. Otherwise scan the full tuple list.
+            ((tuples
+               (cond
+                 ((>= (len lit) 2)
+                   (let ((walked (dl-walk (nth lit 1) subst)))
+                     (cond
+                       ((dl-var? walked) (dl-rel-tuples db rel))
+                       (else (dl-index-lookup db rel walked)))))
+                 (else (dl-rel-tuples db rel)))))
+            (do
+              (for-each
+                (fn
+                  (tuple)
+                  (let
+                    ((s (dl-unify lit tuple subst)))
+                    (when (not (nil? s)) (append! results s))))
+                tuples)
+              results)))))))
+
+;; Match a positive literal against the delta set for its relation only.
+(define
+  dl-match-positive-delta
+  (fn
+    (lit delta subst)
+    (let
+      ((rel (dl-rel-name lit)) (results (list)))
+      (let
+        ((tuples (if (has-key? delta rel) (get delta rel) (list))))
+        (do
+          (for-each
+            (fn
+              (tuple)
+              (let
+                ((s (dl-unify lit tuple subst)))
+                (when (not (nil? s)) (append! results s))))
+            tuples)
+          results)))))
+
+;; Naive matcher (for dl-saturate-naive! and dl-query post-saturation).
+(define
+  dl-match-negation
+  (fn
+    (inner db subst)
+    (let
+      ((walked (dl-apply-subst inner subst))
+        (matches (dl-match-positive inner db subst)))
+      (cond
+        ((= (len matches) 0) (list subst))
+        (else (list))))))
+
+(define
+  dl-match-lit
+  (fn
+    (lit db subst)
+    (cond
+      ((and (dict? lit) (has-key? lit :neg))
+        (dl-match-negation (get lit :neg) db subst))
+      ((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
+      ((dl-builtin? lit)
+        (let
+          ((s (dl-eval-builtin lit subst)))
+          (if (nil? s) (list) (list s))))
+      ((and (list? lit) (> (len lit) 0))
+        (dl-match-positive lit db subst))
+      (else (error (str "datalog: unknown body-literal shape: " lit))))))
+
+(define
+  dl-find-bindings
+  (fn (lits db subst) (dl-fb-aux lits db subst 0 (len lits))))
+
+(define
+  dl-fb-aux
+  (fn
+    (lits db subst i n)
+    (cond
+      ((nil? subst) (list))
+      ((>= i n) (list subst))
+      (else
+        (let
+          ((options (dl-match-lit (nth lits i) db subst))
+            (results (list)))
+          (do
+            (for-each
+              (fn
+                (s)
+                (for-each
+                  (fn (s2) (append! results s2))
+                  (dl-fb-aux lits db s (+ i 1) n)))
+              options)
+            results))))))
+
+;; Naive: apply each rule against full DB until no new tuples.
+(define
+  dl-apply-rule!
+  (fn
+    (db rule)
+    (let
+      ((head (get rule :head)) (body (get rule :body)) (new? false))
+      (do
+        (for-each
+          (fn
+            (s)
+            (let
+              ((derived (dl-apply-subst head s)))
+              (when (dl-add-derived! db derived) (set! new? true))))
+          (dl-find-bindings body db (dl-empty-subst)))
+        new?))))
+
+;; Returns true iff one more saturation step would derive no new
+;; tuples (i.e. the db is at fixpoint). Useful in tests that want
+;; to assert "no work left" after a saturation call. Works under
+;; either saturator since both compute the same fixpoint.
+(define
+  dl-saturated?
+  (fn
+    (db)
+    (let ((any-new false))
+      (do
+        (for-each
+          (fn
+            (rule)
+            (when (not any-new)
+              (for-each
+                (fn
+                  (s)
+                  (let ((derived (dl-apply-subst (get rule :head) s)))
+                    (when
+                      (and (not any-new)
+                           (not (dl-tuple-member?
+                                  derived
+                                  (dl-rel-tuples
+                                    db (dl-rel-name derived)))))
+                      (set! any-new true))))
+                (dl-find-bindings (get rule :body) db (dl-empty-subst)))))
+          (dl-rules db))
+        (not any-new)))))
+
+(define
+  dl-saturate-naive!
+  (fn
+    (db)
+    (let
+      ((changed true))
+      (do
+        (define
+          dl-snloop
+          (fn
+            ()
+            (when
+              changed
+              (do
+                (set! changed false)
+                (for-each
+                  (fn (r) (when (dl-apply-rule! db r) (set! changed true)))
+                  (dl-rules db))
+                (dl-snloop)))))
+        (dl-snloop)
+        db))))
+
+;; ── Semi-naive ───────────────────────────────────────────────────
+
+;; Take a snapshot dict {rel -> tuples} of every relation currently in
+;; the DB. Used as initial delta for the first iteration.
+(define
+  dl-snapshot-facts
+  (fn
+    (db)
+    (let
+      ((facts (get db :facts)) (out {}))
+      (do
+        (for-each
+          (fn (k) (dict-set! out k (dl-copy-list (get facts k))))
+          (keys facts))
+        out))))
+
+(define
+  dl-copy-list
+  (fn
+    (xs)
+    (let
+      ((out (list)))
+      (do (for-each (fn (x) (append! out x)) xs) out))))
+
+;; Does any relation in `delta` have ≥1 tuple?
+(define
+  dl-delta-empty?
+  (fn
+    (delta)
+    (let
+      ((ks (keys delta)) (any-non-empty false))
+      (do
+        (for-each
+          (fn
+            (k)
+            (when
+              (> (len (get delta k)) 0)
+              (set! any-non-empty true)))
+          ks)
+        (not any-non-empty)))))
+
+;; Find substitutions such that `lits` are all satisfied AND `delta-idx`
+;; is matched against the per-relation delta only. The other positive
+;; literals match against the snapshot DB (db.facts read at iteration
+;; start). Built-ins and negations behave as in `dl-match-lit`.
+(define
+  dl-find-bindings-semi
+  (fn
+    (lits db delta delta-idx subst)
+    (dl-fbs-aux lits db delta delta-idx 0 subst)))
+
+(define
+  dl-fbs-aux
+  (fn
+    (lits db delta delta-idx i subst)
+    (cond
+      ((nil? subst) (list))
+      ((>= i (len lits)) (list subst))
+      (else
+        (let
+          ((lit (nth lits i))
+            (options
+              (cond
+                ((and (dict? lit) (has-key? lit :neg))
+                  (dl-match-negation (get lit :neg) db subst))
+                ((dl-aggregate? lit) (dl-eval-aggregate lit db subst))
+                ((dl-builtin? lit)
+                  (let
+                    ((s (dl-eval-builtin lit subst)))
+                    (if (nil? s) (list) (list s))))
+                ((and (list? lit) (> (len lit) 0))
+                  (if
+                    (= i delta-idx)
+                    (dl-match-positive-delta lit delta subst)
+                    (dl-match-positive lit db subst)))
+                (else (error (str "datalog: unknown body-lit: " lit)))))
+            (results (list)))
+          (do
+            (for-each
+              (fn
+                (s)
+                (for-each
+                  (fn (s2) (append! results s2))
+                  (dl-fbs-aux lits db delta delta-idx (+ i 1) s)))
+              options)
+            results))))))
+
+;; Collect candidate head tuples from a rule using delta. Walks every
+;; positive body position and unions the resulting heads. For rules
+;; with no positive body literal, falls back to a naive single-pass
+;; (so static facts like `(p X) :- (= X 5).` derive on iteration 1).
+(define
+  dl-collect-rule-candidates
+  (fn
+    (rule db delta)
+    (let
+      ((head (get rule :head))
+        (body (get rule :body))
+        (out (list))
+        (saw-pos false))
+      (do
+        (define
+          dl-cri
+          (fn
+            (i)
+            (when
+              (< i (len body))
+              (do
+                (let
+                  ((lit (nth body i)))
+                  (when
+                    (dl-positive-lit? lit)
+                    (do
+                      (set! saw-pos true)
+                      (for-each
+                        (fn (s) (append! out (dl-apply-subst head s)))
+                        (dl-find-bindings-semi
+                          body
+                          db
+                          delta
+                          i
+                          (dl-empty-subst))))))
+                (dl-cri (+ i 1))))))
+        (dl-cri 0)
+        (when
+          (not saw-pos)
+          (for-each
+            (fn (s) (append! out (dl-apply-subst head s)))
+            (dl-find-bindings body db (dl-empty-subst))))
+        out))))
+
+;; Add a list of candidate tuples to db; collect newly-added ones into
+;; the new-delta dict (keyed by relation name).
+(define
+  dl-commit-candidates!
+  (fn
+    (db candidates new-delta)
+    (for-each
+      (fn
+        (lit)
+        (when
+          (dl-add-derived! db lit)
+          (let
+            ((rel (dl-rel-name lit)))
+            (do
+              (when
+                (not (has-key? new-delta rel))
+                (dict-set! new-delta rel (list)))
+              (append! (get new-delta rel) lit)))))
+      candidates)))
+
+(define
+  dl-saturate-rules!
+  (fn
+    (db rules)
+    (let
+      ((delta (dl-snapshot-facts db)))
+      (do
+        (define
+          dl-sr-step
+          (fn
+            ()
+            (let
+              ((pending (list)) (new-delta {}))
+              (do
+                (for-each
+                  (fn
+                    (rule)
+                    (for-each
+                      (fn (cand) (append! pending cand))
+                      (dl-collect-rule-candidates rule db delta)))
+                  rules)
+                (dl-commit-candidates! db pending new-delta)
+                (cond
+                  ((dl-delta-empty? new-delta) nil)
+                  (else (do (set! delta new-delta) (dl-sr-step))))))))
+        (dl-sr-step)
+        db))))
+
+;; Stratified driver: rejects non-stratifiable programs at saturation
+;; time, then iterates strata in increasing order, running semi-naive on
+;; the rules whose head sits in that stratum.
+(define
+  dl-saturate!
+  (fn
+    (db)
+    (let
+      ((err (dl-check-stratifiable db)))
+      (cond
+        ((not (nil? err)) (error (str "dl-saturate!: " err)))
+        (else
+          (let
+            ((strata (dl-compute-strata db)))
+            (let
+              ((grouped (dl-group-rules-by-stratum db strata)))
+              (let
+                ((groups (get grouped :groups))
+                  (max-s (get grouped :max)))
+                (do
+                  (define
+                    dl-strat-loop
+                    (fn
+                      (s)
+                      (when
+                        (<= s max-s)
+                        (let
+                          ((sk (str s)))
+                          (do
+                            (when
+                              (has-key? groups sk)
+                              (dl-saturate-rules! db (get groups sk)))
+                            (dl-strat-loop (+ s 1)))))))
+                  (dl-strat-loop 0)
+                  db)))))))))
+
+;; ── Querying ─────────────────────────────────────────────────────
+
+;; Coerce a query argument to a list of body literals. A single literal
+;; like `(p X)` (positive — head is a symbol) or `{:neg ...}` becomes
+;; `((p X))`. A list of literals like `((p X) (q X))` is returned as-is.
+(define
+  dl-query-coerce
+  (fn
+    (goal)
+    (cond
+      ((and (dict? goal) (has-key? goal :neg)) (list goal))
+      ((and (list? goal) (> (len goal) 0) (symbol? (first goal)))
+        (list goal))
+      ((list? goal) goal)
+      (else (error (str "dl-query: unrecognised goal shape: " goal))))))
+
+(define
+  dl-query
+  (fn
+    (db goal)
+    (do
+      (dl-saturate! db)
+      ;; Rename anonymous '_' vars in each goal literal so multiple
+      ;; occurrences do not unify together. Keep the user-facing var
+      ;; list (taken before renaming) so projected results retain user
+      ;; names.
+      (let
+        ((goals (dl-query-coerce goal))
+          ;; Start the renamer past any `_anon<N>` symbols the user
+          ;; may have written in the query — avoids collision.
+          (renamer
+            (dl-make-anon-renamer (dl-max-anon-num-list goal 0 0))))
+        (let
+          ((user-vars (dl-query-user-vars goals))
+            (renamed (map (fn (g) (dl-rename-anon-lit g renamer)) goals)))
+          (let
+            ((substs (dl-find-bindings renamed db (dl-empty-subst)))
+              (results (list)))
+            (do
+              (for-each
+                (fn
+                  (s)
+                  (let
+                    ((proj (dl-project-subst s user-vars)))
+                    (when
+                      (not (dl-tuple-member? proj results))
+                      (append! results proj))))
+                substs)
+              results)))))))
+
+(define
+  dl-query-user-vars
+  (fn
+    (goals)
+    (let ((seen (list)))
+      (do
+        (for-each
+          (fn
+            (g)
+            (cond
+              ((and (dict? g) (has-key? g :neg))
+                (for-each
+                  (fn
+                    (v)
+                    (when
+                      (and (not (= v "_")) (not (dl-member-string? v seen)))
+                      (append! seen v)))
+                  (dl-vars-of (get g :neg))))
+              ((dl-aggregate? g)
+                ;; Only the result var (first arg of the aggregate
+                ;; literal) is user-facing. The aggregated var and
+                ;; any vars in the inner goal are internal.
+                (let ((r (nth g 1)))
+                  (when
+                    (dl-var? r)
+                    (let ((rn (symbol->string r)))
+                      (when
+                        (and (not (= rn "_"))
+                             (not (dl-member-string? rn seen)))
+                        (append! seen rn))))))
+              (else
+                (for-each
+                  (fn
+                    (v)
+                    (when
+                      (and (not (= v "_")) (not (dl-member-string? v seen)))
+                      (append! seen v)))
+                  (dl-vars-of g)))))
+          goals)
+        seen))))
+
+(define
+  dl-project-subst
+  (fn
+    (subst names)
+    (let
+      ((out {}))
+      (do
+        (for-each
+          (fn
+            (n)
+            (let
+              ((sym (string->symbol n)))
+              (let
+                ((v (dl-walk sym subst)))
+                (dict-set! out n (dl-apply-subst v subst)))))
+          names)
+        out))))
+
+(define dl-relation (fn (db name) (dl-rel-tuples db name)))

lib/datalog/magic.sx

@@ -0,0 +1,464 @@
+;; lib/datalog/magic.sx — adornment analysis + sideways info passing.
+;;
+;; First step of the magic-sets transformation (Phase 6). Right now
+;; the saturator does not consume these — they are introspection
+;; helpers that future magic-set rewriting will build on top of.
+;;
+;; Definitions:
+;;   - An *adornment* of an n-ary literal is an n-character string
+;;     of "b" (bound — value already known at the call site) and
+;;     "f" (free — to be derived).
+;;   - SIPS (Sideways Information Passing Strategy) walks the body
+;;     of an adorned rule left-to-right tracking which variables
+;;     have been bound so far, computing each body literal's
+;;     adornment in turn.
+;;
+;; Usage:
+;;
+;;   (dl-adorn-goal '(ancestor tom X))
+;;     => "bf"
+;;
+;;   (dl-rule-sips
+;;     {:head (ancestor X Z)
+;;      :body ((parent X Y) (ancestor Y Z))}
+;;     "bf")
+;;   => ({:lit (parent X Y) :adornment "bf"}
+;;       {:lit (ancestor Y Z) :adornment "bf"})
+
+;; Per-arg adornment under the current bound-var name set.
+(define
+  dl-adorn-arg
+  (fn
+    (arg bound)
+    (cond
+      ((dl-var? arg)
+        (if (dl-member-string? (symbol->string arg) bound) "b" "f"))
+      (else "b"))))
+
+;; Adornment for the args of a literal (after the relation name).
+(define
+  dl-adorn-args
+  (fn
+    (args bound)
+    (cond
+      ((= (len args) 0) "")
+      (else
+        (str
+          (dl-adorn-arg (first args) bound)
+          (dl-adorn-args (rest args) bound))))))
+
+;; Adornment of a top-level goal under the empty bound-var set.
+(define
+  dl-adorn-goal
+  (fn (goal) (dl-adorn-args (rest goal) (list))))
+
+;; Adornment of a literal under an explicit bound set.
+(define
+  dl-adorn-lit
+  (fn (lit bound) (dl-adorn-args (rest lit) bound)))
+
+;; The set of variable names made bound by walking a positive
+;; literal whose adornment is known. Free positions add their
+;; vars to the bound set.
+(define
+  dl-vars-bound-by-lit
+  (fn
+    (lit bound)
+    (let ((args (rest lit)) (out (list)))
+      (do
+        (for-each
+          (fn (a)
+            (when
+              (and (dl-var? a)
+                   (not (dl-member-string? (symbol->string a) bound))
+                   (not (dl-member-string? (symbol->string a) out)))
+              (append! out (symbol->string a))))
+          args)
+        out))))
+
+;; Walk the rule body left-to-right tracking bound vars seeded by the
+;; head adornment. Returns a list of {:lit :adornment} entries.
+;;
+;; Negation, comparison, and built-ins are passed through with their
+;; adornment computed from the current bound set; they don't add new
+;; bindings (except `is`, which binds its left arg if a var). Aggregates
+;; are treated like is — the result var becomes bound.
+(define
+  dl-init-head-bound
+  (fn
+    (head adornment)
+    (let ((args (rest head)) (out (list)))
+      (do
+        (define
+          dl-ihb-loop
+          (fn
+            (i)
+            (when
+              (< i (len args))
+              (do
+                (let
+                  ((c (slice adornment i (+ i 1)))
+                    (a (nth args i)))
+                  (when
+                    (and (= c "b") (dl-var? a))
+                    (let ((n (symbol->string a)))
+                      (when
+                        (not (dl-member-string? n out))
+                        (append! out n)))))
+                (dl-ihb-loop (+ i 1))))))
+        (dl-ihb-loop 0)
+        out))))
+
+(define
+  dl-rule-sips
+  (fn
+    (rule head-adornment)
+    (let
+      ((bound (dl-init-head-bound (get rule :head) head-adornment))
+        (out (list)))
+      (do
+        (for-each
+          (fn
+            (lit)
+            (cond
+              ((and (dict? lit) (has-key? lit :neg))
+                (let ((target (get lit :neg)))
+                  (append!
+                    out
+                    {:lit lit :adornment (dl-adorn-lit target bound)})))
+              ((dl-builtin? lit)
+                (let ((adn (dl-adorn-lit lit bound)))
+                  (do
+                    (append! out {:lit lit :adornment adn})
+                    ;; `is` binds its left arg (if var) once RHS is ground.
+                    (when
+                      (and (= (dl-rel-name lit) "is") (dl-var? (nth lit 1)))
+                      (let ((n (symbol->string (nth lit 1))))
+                        (when
+                          (not (dl-member-string? n bound))
+                          (append! bound n)))))))
+              ((and (list? lit) (dl-aggregate? lit))
+                (let ((adn (dl-adorn-lit lit bound)))
+                  (do
+                    (append! out {:lit lit :adornment adn})
+                    ;; Result var (first arg) becomes bound.
+                    (when (dl-var? (nth lit 1))
+                      (let ((n (symbol->string (nth lit 1))))
+                        (when
+                          (not (dl-member-string? n bound))
+                          (append! bound n)))))))
+              ((and (list? lit) (> (len lit) 0))
+                (let ((adn (dl-adorn-lit lit bound)))
+                  (do
+                    (append! out {:lit lit :adornment adn})
+                    (for-each
+                      (fn (n)
+                        (when (not (dl-member-string? n bound))
+                          (append! bound n)))
+                      (dl-vars-bound-by-lit lit bound)))))))
+          (get rule :body))
+        out))))
+
+;; ── Magic predicate naming + bound-args extraction ─────────────
+;; These are building blocks for the magic-sets *transformation*
+;; itself. The transformation (which generates rewritten rules
+;; with magic_<rel>^<adornment> filters) is future work — for now
+;; these helpers can be used to inspect what such a transformation
+;; would produce.
+
+;; "magic_p^bf" given relation "p" and adornment "bf".
+(define
+  dl-magic-rel-name
+  (fn (rel adornment) (str "magic_" rel "^" adornment)))
+
+;; A magic predicate literal:
+;;   (magic_<rel>^<adornment> arg1 arg2 ...)
+(define
+  dl-magic-lit
+  (fn
+    (rel adornment bound-args)
+    (cons (string->symbol (dl-magic-rel-name rel adornment)) bound-args)))
+
+;; Extract bound args (those at "b" positions in `adornment`) from a
+;; literal `(rel arg1 arg2 ... argN)`. Returns the list of arg values.
+(define
+  dl-bound-args
+  (fn
+    (lit adornment)
+    (let ((args (rest lit)) (out (list)))
+      (do
+        (define
+          dl-ba-loop
+          (fn
+            (i)
+            (when
+              (< i (len args))
+              (do
+                (when
+                  (= (slice adornment i (+ i 1)) "b")
+                  (append! out (nth args i)))
+                (dl-ba-loop (+ i 1))))))
+        (dl-ba-loop 0)
+        out))))
+
+;; ── Magic-sets rewriter ─────────────────────────────────────────
+;;
+;; Given the original rule list and a query (rel, adornment) pair,
+;; generates the magic-rewritten program: a list of rules that
+;; (a) gate each original rule with a `magic_<rel>^<adn>` filter and
+;; (b) propagate the magic relation through SIPS so that only
+;; query-relevant tuples are derived. Seed facts are returned
+;; separately and must be added to the db at evaluation time.
+;;
+;; Output: {:rules <rewritten-rules> :seed <magic-seed-literal>}
+;;
+;; The rewriter only rewrites IDB rules; EDB facts pass through.
+;; Built-in predicates and negation in body literals are kept in
+;; place but do not generate propagation rules of their own.
+
+(define
+  dl-magic-pair-key
+  (fn (rel adornment) (str rel "^" adornment)))
+
+(define
+  dl-magic-rewrite
+  (fn
+    (rules query-rel query-adornment query-args)
+    (let
+      ((seen (list))
+        (queue (list))
+        (out (list)))
+      (do
+        (define
+          dl-mq-mark!
+          (fn
+            (rel adornment)
+            (let ((k (dl-magic-pair-key rel adornment)))
+              (when
+                (not (dl-member-string? k seen))
+                (do
+                  (append! seen k)
+                  (append! queue {:rel rel :adn adornment}))))))
+
+        (define
+          dl-mq-rewrite-rule!
+          (fn
+            (rule adn)
+            (let
+              ((head (get rule :head))
+                (body (get rule :body))
+                (sips (dl-rule-sips rule adn)))
+              (let
+                ((magic-filter
+                   (dl-magic-lit
+                     (dl-rel-name head)
+                     adn
+                     (dl-bound-args head adn))))
+                (do
+                  ;; Adorned rule: head :- magic-filter, body...
+                  (let ((new-body (list)))
+                    (do
+                      (append! new-body magic-filter)
+                      (for-each
+                        (fn (lit) (append! new-body lit))
+                        body)
+                      (append! out {:head head :body new-body})))
+                  ;; Propagation rules for each positive non-builtin
+                  ;; body literal at position i.
+                  (define
+                    dl-mq-prop-loop
+                    (fn
+                      (i)
+                      (when
+                        (< i (len body))
+                        (do
+                          (let
+                            ((lit (nth body i))
+                              (sip-entry (nth sips i)))
+                            (when
+                              (and (list? lit)
+                                   (> (len lit) 0)
+                                   (not (and (dict? lit) (has-key? lit :neg)))
+                                   (not (dl-builtin? lit))
+                                   (not (dl-aggregate? lit)))
+                              (let
+                                ((lit-adn (get sip-entry :adornment))
+                                  (lit-rel (dl-rel-name lit)))
+                                (let
+                                  ((prop-head
+                                     (dl-magic-lit
+                                       lit-rel
+                                       lit-adn
+                                       (dl-bound-args lit lit-adn))))
+                                  (let ((prop-body (list)))
+                                    (do
+                                      (append! prop-body magic-filter)
+                                      (define
+                                        dl-mq-prefix-loop
+                                        (fn
+                                          (j)
+                                          (when
+                                            (< j i)
+                                            (do
+                                              (append!
+                                                prop-body
+                                                (nth body j))
+                                              (dl-mq-prefix-loop (+ j 1))))))
+                                      (dl-mq-prefix-loop 0)
+                                      (append!
+                                        out
+                                        {:head prop-head :body prop-body})
+                                      (dl-mq-mark! lit-rel lit-adn)))))))
+                          (dl-mq-prop-loop (+ i 1))))))
+                  (dl-mq-prop-loop 0))))))
+
+        (dl-mq-mark! query-rel query-adornment)
+
+        (let ((idx 0))
+          (define
+            dl-mq-process
+            (fn
+              ()
+              (when
+                (< idx (len queue))
+                (let ((item (nth queue idx)))
+                  (do
+                    (set! idx (+ idx 1))
+                    (let
+                      ((rel (get item :rel)) (adn (get item :adn)))
+                      (for-each
+                        (fn
+                          (rule)
+                          (when
+                            (= (dl-rel-name (get rule :head)) rel)
+                            (dl-mq-rewrite-rule! rule adn)))
+                        rules))
+                    (dl-mq-process))))))
+          (dl-mq-process))
+
+        {:rules out
+         :seed
+         (dl-magic-lit
+           query-rel
+           query-adornment
+           query-args)}))))
+
+;; ── Top-level magic-sets driver ─────────────────────────────────
+;;
+;; (dl-magic-query db query-goal) — run `query-goal` under magic-sets
+;; evaluation. Builds a fresh internal db with:
+;;   - the caller's EDB facts (relations not headed by any rule),
+;;   - the magic seed fact, and
+;;   - the rewritten rules.
+;; Saturates and queries, returning the substitution list. The
+;; caller's db is untouched.
+;;
+;; Useful primarily as a perf alternative for queries that only
+;; need a small slice of a recursive relation. Equivalent to
+;; dl-query for any single fully-stratifiable program.
+
+(define
+  dl-magic-rule-heads
+  (fn
+    (rules)
+    (let ((seen (list)))
+      (do
+        (for-each
+          (fn
+            (r)
+            (let ((h (dl-rel-name (get r :head))))
+              (when
+                (and (not (nil? h)) (not (dl-member-string? h seen)))
+                (append! seen h))))
+          rules)
+        seen))))
+
+;; True iff any rule's body contains a literal kind that the magic
+;; rewriter doesn't propagate magic to — i.e. an aggregate or a
+;; negation. Used by dl-magic-query to decide whether to pre-saturate
+;; the source db (for correctness on stratified programs) or skip
+;; that step (preserving full magic-sets efficiency for pure
+;; positive programs).
+(define
+  dl-rule-has-nonprop-lit?
+  (fn
+    (body i n)
+    (cond
+      ((>= i n) false)
+      ((let ((lit (nth body i)))
+         (or (and (dict? lit) (has-key? lit :neg))
+             (dl-aggregate? lit)))
+        true)
+      (else (dl-rule-has-nonprop-lit? body (+ i 1) n)))))
+
+(define
+  dl-rules-need-presaturation?
+  (fn
+    (rules)
+    (cond
+      ((= (len rules) 0) false)
+      ((let ((body (get (first rules) :body)))
+         (dl-rule-has-nonprop-lit? body 0 (len body)))
+        true)
+      (else (dl-rules-need-presaturation? (rest rules))))))
+
+(define
+  dl-magic-query
+  (fn
+    (db query-goal)
+    ;; Magic-sets only applies to positive non-builtin / non-aggregate
+    ;; literals against rule-defined relations. For other goal shapes
+    ;; (built-ins, aggregates, EDB-only relations) the seed is either
+    ;; non-ground or unused; fall back to dl-query.
+    (cond
+      ((not (and (list? query-goal)
+                 (> (len query-goal) 0)
+                 (symbol? (first query-goal))))
+        (error (str "dl-magic-query: goal must be a positive literal "
+                    "(non-empty list with a symbol head), got " query-goal)))
+      ((or (dl-builtin? query-goal)
+           (dl-aggregate? query-goal)
+           (and (dict? query-goal) (has-key? query-goal :neg)))
+        (dl-query db query-goal))
+      (else
+        (do
+          ;; If the rule set has aggregates or negation, pre-saturate
+          ;; the source db before copying facts. The magic rewriter
+          ;; passes aggregate body lits and negated lits through
+          ;; unchanged (no magic propagation generated for them) — so
+          ;; if their inner-goal relation is IDB, it would be empty in
+          ;; the magic db. Pre-saturating ensures equivalence with
+          ;; `dl-query` for every stratified program. Pure positive
+          ;; programs skip this and keep the full magic-sets perf win
+          ;; from goal-directed re-derivation.
+          (when
+            (dl-rules-need-presaturation? (dl-rules db))
+            (dl-saturate! db))
+          (let
+            ((query-rel (dl-rel-name query-goal))
+              (query-adn (dl-adorn-goal query-goal)))
+            (let
+              ((query-args (dl-bound-args query-goal query-adn))
+                (rules (dl-rules db)))
+              (let
+                ((rewritten (dl-magic-rewrite rules query-rel query-adn query-args))
+                  (mdb (dl-make-db))
+                  (rule-heads (dl-magic-rule-heads rules)))
+            (do
+              ;; Copy ALL existing facts. EDB-only relations bring their
+              ;; tuples; mixed EDB+IDB relations bring both their EDB
+              ;; portion and any pre-saturated IDB tuples (which the
+              ;; rewritten rules would re-derive anyway). Skipping facts
+              ;; for rule-headed relations would leave the magic run
+              ;; without the EDB portion of mixed relations.
+              (for-each
+                (fn
+                  (rel)
+                  (for-each
+                    (fn (t) (dl-add-fact! mdb t))
+                    (dl-rel-tuples db rel)))
+                (keys (get db :facts)))
+              ;; Seed + rewritten rules.
+              (dl-add-fact! mdb (get rewritten :seed))
+              (for-each (fn (r) (dl-add-rule! mdb r)) (get rewritten :rules))
+              (dl-query mdb query-goal))))))))))

lib/datalog/parser.sx

@@ -0,0 +1,252 @@
+;; lib/datalog/parser.sx — Datalog tokens → AST
+;;
+;; Output shapes:
+;;   Literal (positive)  := (relname arg ... arg)        — SX list
+;;   Literal (negative)  := {:neg (relname arg ... arg)} — dict
+;;   Argument            := var-symbol | atom-symbol | number | string
+;;                        | (op-name arg ... arg)        — arithmetic compound
+;;   Fact                := {:head literal :body ()}
+;;   Rule                := {:head literal :body (lit ... lit)}
+;;   Query               := {:query (lit ... lit)}
+;;   Program             := list of facts / rules / queries
+;;
+;; Variables and constants are both SX symbols; the evaluator dispatches
+;; on first-char case ('A'..'Z' or '_' = variable, otherwise constant).
+;;
+;; The parser permits nested compounds in arg position to support
+;; arithmetic (e.g. (is Z (+ X Y))). Safety analysis at rule-load time
+;; rejects compounds whose head is not an arithmetic operator.
+
+(define
+  dl-pp-peek
+  (fn
+    (st)
+    (let
+      ((i (get st :idx)) (tokens (get st :tokens)))
+      (if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
+
+(define
+  dl-pp-peek2
+  (fn
+    (st)
+    (let
+      ((i (+ (get st :idx) 1)) (tokens (get st :tokens)))
+      (if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
+
+(define
+  dl-pp-advance!
+  (fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
+
+(define
+  dl-pp-at?
+  (fn
+    (st type value)
+    (let
+      ((t (dl-pp-peek st)))
+      (and
+        (= (get t :type) type)
+        (or (= value nil) (= (get t :value) value))))))
+
+(define
+  dl-pp-error
+  (fn
+    (st msg)
+    (let
+      ((t (dl-pp-peek st)))
+      (error
+        (str
+          "Parse error at pos "
+          (get t :pos)
+          ": "
+          msg
+          " (got "
+          (get t :type)
+          " '"
+          (if (= (get t :value) nil) "" (get t :value))
+          "')")))))
+
+(define
+  dl-pp-expect!
+  (fn
+    (st type value)
+    (let
+      ((t (dl-pp-peek st)))
+      (if
+        (dl-pp-at? st type value)
+        (do (dl-pp-advance! st) t)
+        (dl-pp-error
+          st
+          (str "expected " type (if (= value nil) "" (str " '" value "'"))))))))
+
+;; Argument: variable, atom, number, string, or compound (relname/op + parens).
+(define
+  dl-pp-parse-arg
+  (fn
+    (st)
+    (let
+      ((t (dl-pp-peek st)))
+      (let
+        ((ty (get t :type)) (vv (get t :value)))
+        (cond
+          ((= ty "number") (do (dl-pp-advance! st) vv))
+          ((= ty "string") (do (dl-pp-advance! st) vv))
+          ((= ty "var") (do (dl-pp-advance! st) (string->symbol vv)))
+          ;; Negative numeric literal: `-` op directly followed by a
+          ;; number (no `(`) is parsed as a single negative number.
+          ;; This keeps `(-X Y)` (compound) and `-N` (literal) distinct.
+          ((and (= ty "op") (= vv "-")
+                (= (get (dl-pp-peek2 st) :type) "number"))
+            (do
+              (dl-pp-advance! st)
+              (let
+                ((n (get (dl-pp-peek st) :value)))
+                (do (dl-pp-advance! st) (- 0 n)))))
+          ((or (= ty "atom") (= ty "op"))
+            (do
+              (dl-pp-advance! st)
+              (if
+                (dl-pp-at? st "punct" "(")
+                (do
+                  (dl-pp-advance! st)
+                  (let
+                    ((args (dl-pp-parse-arg-list st)))
+                    (do
+                      (dl-pp-expect! st "punct" ")")
+                      (cons (string->symbol vv) args))))
+                (string->symbol vv))))
+          (else (dl-pp-error st "expected term")))))))
+
+;; Comma-separated args inside parens.
+(define
+  dl-pp-parse-arg-list
+  (fn
+    (st)
+    (let
+      ((args (list)))
+      (do
+        (append! args (dl-pp-parse-arg st))
+        (define
+          dl-pp-arg-loop
+          (fn
+            ()
+            (when
+              (dl-pp-at? st "punct" ",")
+              (do
+                (dl-pp-advance! st)
+                (append! args (dl-pp-parse-arg st))
+                (dl-pp-arg-loop)))))
+        (dl-pp-arg-loop)
+        args))))
+
+;; A positive literal: relname (atom or op) followed by optional (args).
+(define
+  dl-pp-parse-positive
+  (fn
+    (st)
+    (let
+      ((t (dl-pp-peek st)))
+      (let
+        ((ty (get t :type)) (vv (get t :value)))
+        (if
+          (or (= ty "atom") (= ty "op"))
+          (do
+            (dl-pp-advance! st)
+            (if
+              (dl-pp-at? st "punct" "(")
+              (do
+                (dl-pp-advance! st)
+                (let
+                  ((args (dl-pp-parse-arg-list st)))
+                  (do
+                    (dl-pp-expect! st "punct" ")")
+                    (cons (string->symbol vv) args))))
+              (list (string->symbol vv))))
+          (dl-pp-error st "expected literal head"))))))
+
+;; A body literal: positive, or not(positive).
+(define
+  dl-pp-parse-body-lit
+  (fn
+    (st)
+    (let
+      ((t1 (dl-pp-peek st)) (t2 (dl-pp-peek2 st)))
+      (if
+        (and
+          (= (get t1 :type) "atom")
+          (= (get t1 :value) "not")
+          (= (get t2 :type) "punct")
+          (= (get t2 :value) "("))
+        (do
+          (dl-pp-advance! st)
+          (dl-pp-advance! st)
+          (let
+            ((inner (dl-pp-parse-positive st)))
+            (do (dl-pp-expect! st "punct" ")") {:neg inner})))
+        (dl-pp-parse-positive st)))))
+
+;; Comma-separated body literals.
+(define
+  dl-pp-parse-body
+  (fn
+    (st)
+    (let
+      ((lits (list)))
+      (do
+        (append! lits (dl-pp-parse-body-lit st))
+        (define
+          dl-pp-body-loop
+          (fn
+            ()
+            (when
+              (dl-pp-at? st "punct" ",")
+              (do
+                (dl-pp-advance! st)
+                (append! lits (dl-pp-parse-body-lit st))
+                (dl-pp-body-loop)))))
+        (dl-pp-body-loop)
+        lits))))
+
+;; Single clause: fact, rule, or query. Consumes trailing dot.
+(define
+  dl-pp-parse-clause
+  (fn
+    (st)
+    (cond
+      ((dl-pp-at? st "op" "?-")
+        (do
+          (dl-pp-advance! st)
+          (let
+            ((body (dl-pp-parse-body st)))
+            (do (dl-pp-expect! st "punct" ".") {:query body}))))
+      (else
+        (let
+          ((head (dl-pp-parse-positive st)))
+          (cond
+            ((dl-pp-at? st "op" ":-")
+              (do
+                (dl-pp-advance! st)
+                (let
+                  ((body (dl-pp-parse-body st)))
+                  (do (dl-pp-expect! st "punct" ".") {:body body :head head}))))
+            (else (do (dl-pp-expect! st "punct" ".") {:body (list) :head head}))))))))
+
+(define
+  dl-parse-program
+  (fn
+    (tokens)
+    (let
+      ((st {:tokens tokens :idx 0}) (clauses (list)))
+      (do
+        (define
+          dl-pp-prog-loop
+          (fn
+            ()
+            (when
+              (not (dl-pp-at? st "eof" nil))
+              (do
+                (append! clauses (dl-pp-parse-clause st))
+                (dl-pp-prog-loop)))))
+        (dl-pp-prog-loop)
+        clauses))))
+
+(define dl-parse (fn (src) (dl-parse-program (dl-tokenize src))))

lib/datalog/scoreboard.json

@@ -0,0 +1,20 @@
+{
+  "lang": "datalog",
+  "total_passed": 276,
+  "total_failed": 0,
+  "total": 276,
+  "suites": [
+    {"name":"tokenize","passed":31,"failed":0,"total":31},
+    {"name":"parse","passed":23,"failed":0,"total":23},
+    {"name":"unify","passed":29,"failed":0,"total":29},
+    {"name":"eval","passed":44,"failed":0,"total":44},
+    {"name":"builtins","passed":26,"failed":0,"total":26},
+    {"name":"semi_naive","passed":8,"failed":0,"total":8},
+    {"name":"negation","passed":12,"failed":0,"total":12},
+    {"name":"aggregates","passed":23,"failed":0,"total":23},
+    {"name":"api","passed":22,"failed":0,"total":22},
+    {"name":"magic","passed":37,"failed":0,"total":37},
+    {"name":"demo","passed":21,"failed":0,"total":21}
+  ],
+  "generated": "2026-05-14T20:30:05+00:00"
+}

lib/datalog/scoreboard.md

@@ -0,0 +1,17 @@
+# datalog scoreboard
+
+**276 / 276 passing** (0 failure(s)).
+
+| Suite | Passed | Total | Status |
+|-------|--------|-------|--------|
+| tokenize | 31 | 31 | ok |
+| parse | 23 | 23 | ok |
+| unify | 29 | 29 | ok |
+| eval | 44 | 44 | ok |
+| builtins | 26 | 26 | ok |
+| semi_naive | 8 | 8 | ok |
+| negation | 12 | 12 | ok |
+| aggregates | 23 | 23 | ok |
+| api | 22 | 22 | ok |
+| magic | 37 | 37 | ok |
+| demo | 21 | 21 | ok |

lib/datalog/strata.sx

@@ -0,0 +1,323 @@
+;; lib/datalog/strata.sx — dependency graph, SCC analysis, stratum assignment.
+;;
+;; A program is stratifiable iff no cycle in its dependency graph passes
+;; through a negative edge. The stratum of relation R is the depth at which
+;; R can first be evaluated:
+;;
+;;   stratum(R) = max over edges (R → S) of:
+;;       stratum(S)         if the edge is positive
+;;       stratum(S) + 1     if the edge is negative
+;;
+;; All relations in the same SCC share a stratum (and the SCC must have only
+;; positive internal edges, else the program is non-stratifiable).
+
+;; Build dep graph: dict {head-rel-name -> ({:rel str :neg bool} ...)}.
+(define
+  dl-build-dep-graph
+  (fn
+    (db)
+    (let ((g {}))
+      (do
+        (for-each
+          (fn
+            (rule)
+            (let
+              ((head-rel (dl-rel-name (get rule :head))))
+              (when
+                (not (nil? head-rel))
+                (do
+                  (when
+                    (not (has-key? g head-rel))
+                    (dict-set! g head-rel (list)))
+                  (let ((existing (get g head-rel)))
+                    (for-each
+                      (fn
+                        (lit)
+                        (cond
+                          ((dl-aggregate? lit)
+                            (let
+                              ((edge (dl-aggregate-dep-edge lit)))
+                              (when
+                                (not (nil? edge))
+                                (append! existing edge))))
+                          (else
+                            (let
+                              ((target
+                                 (cond
+                                   ((and (dict? lit) (has-key? lit :neg))
+                                     (dl-rel-name (get lit :neg)))
+                                   ((dl-builtin? lit) nil)
+                                   ((and (list? lit) (> (len lit) 0))
+                                     (dl-rel-name lit))
+                                   (else nil)))
+                                (neg?
+                                  (and (dict? lit) (has-key? lit :neg))))
+                              (when
+                                (not (nil? target))
+                                (append!
+                                  existing
+                                  {:rel target :neg neg?}))))))
+                      (get rule :body)))))))
+          (dl-rules db))
+        g))))
+
+;; All relations referenced — heads of rules + EDB names + body relations.
+(define
+  dl-all-relations
+  (fn
+    (db)
+    (let ((seen (list)))
+      (do
+        (for-each
+          (fn
+            (k)
+            (when (not (dl-member-string? k seen)) (append! seen k)))
+          (keys (get db :facts)))
+        (for-each
+          (fn
+            (rule)
+            (do
+              (let ((h (dl-rel-name (get rule :head))))
+                (when
+                  (and (not (nil? h)) (not (dl-member-string? h seen)))
+                  (append! seen h)))
+              (for-each
+                (fn
+                  (lit)
+                  (let
+                    ((t
+                       (cond
+                         ((dl-aggregate? lit)
+                           (let ((edge (dl-aggregate-dep-edge lit)))
+                             (if (nil? edge) nil (get edge :rel))))
+                         ((and (dict? lit) (has-key? lit :neg))
+                           (dl-rel-name (get lit :neg)))
+                         ((dl-builtin? lit) nil)
+                         ((and (list? lit) (> (len lit) 0))
+                           (dl-rel-name lit))
+                         (else nil))))
+                    (when
+                      (and (not (nil? t)) (not (dl-member-string? t seen)))
+                      (append! seen t))))
+                (get rule :body))))
+          (dl-rules db))
+        seen))))
+
+;; reach: dict {from: dict {to: edge-info}} where edge-info is
+;;   {:any bool :neg bool}
+;; meaning "any path from `from` to `to`" and "exists a negative-passing
+;; path from `from` to `to`".
+;;
+;; Floyd-Warshall over the dep graph. The 'neg' flag propagates through
+;; concatenation: if any edge along the path is negative, the path's
+;; flag is true.
+(define
+  dl-build-reach
+  (fn
+    (graph nodes)
+    (let ((reach {}))
+      (do
+        (for-each
+          (fn (n) (dict-set! reach n {}))
+          nodes)
+        (for-each
+          (fn
+            (head)
+            (when
+              (has-key? graph head)
+              (for-each
+                (fn
+                  (edge)
+                  (let
+                    ((target (get edge :rel)) (n (get edge :neg)))
+                    (let ((row (get reach head)))
+                      (cond
+                        ((has-key? row target)
+                          (let ((cur (get row target)))
+                            (dict-set!
+                              row
+                              target
+                              {:any true :neg (or n (get cur :neg))})))
+                        (else
+                          (dict-set! row target {:any true :neg n}))))))
+                (get graph head))))
+          nodes)
+        (for-each
+          (fn
+            (k)
+            (for-each
+              (fn
+                (i)
+                (let ((row-i (get reach i)))
+                  (when
+                    (has-key? row-i k)
+                    (let ((ik (get row-i k)) (row-k (get reach k)))
+                      (for-each
+                        (fn
+                          (j)
+                          (when
+                            (has-key? row-k j)
+                            (let ((kj (get row-k j)))
+                              (let
+                                ((combined-neg (or (get ik :neg) (get kj :neg))))
+                                (cond
+                                  ((has-key? row-i j)
+                                    (let ((cur (get row-i j)))
+                                      (dict-set!
+                                        row-i
+                                        j
+                                        {:any true
+                                         :neg (or combined-neg (get cur :neg))})))
+                                  (else
+                                    (dict-set!
+                                      row-i
+                                      j
+                                      {:any true :neg combined-neg})))))))
+                        nodes)))))
+              nodes))
+          nodes)
+        reach))))
+
+;; Returns nil on success, or error message string on failure.
+(define
+  dl-check-stratifiable
+  (fn
+    (db)
+    (let
+      ((graph (dl-build-dep-graph db))
+        (nodes (dl-all-relations db)))
+      (let ((reach (dl-build-reach graph nodes)) (err nil))
+        (do
+          (for-each
+            (fn
+              (rule)
+              (when
+                (nil? err)
+                (let ((head-rel (dl-rel-name (get rule :head))))
+                  (for-each
+                    (fn
+                      (lit)
+                      (cond
+                        ((and (dict? lit) (has-key? lit :neg))
+                          (let ((tgt (dl-rel-name (get lit :neg))))
+                            (when
+                              (and (not (nil? tgt))
+                                   (dl-reach-cycle? reach head-rel tgt))
+                              (set!
+                                err
+                                (str "non-stratifiable: relation " head-rel
+                                     " transitively depends through negation on "
+                                     tgt
+                                     " which depends back on " head-rel)))))
+                        ((dl-aggregate? lit)
+                          (let ((edge (dl-aggregate-dep-edge lit)))
+                            (when
+                              (not (nil? edge))
+                              (let ((tgt (get edge :rel)))
+                                (when
+                                  (and (not (nil? tgt))
+                                       (dl-reach-cycle? reach head-rel tgt))
+                                  (set!
+                                    err
+                                    (str "non-stratifiable: relation "
+                                         head-rel
+                                         " aggregates over " tgt
+                                         " which depends back on "
+                                         head-rel))))))))) 
+                    (get rule :body)))))
+            (dl-rules db))
+          err)))))
+
+(define
+  dl-reach-cycle?
+  (fn
+    (reach a b)
+    (and
+      (dl-reach-row-has? reach b a)
+      (dl-reach-row-has? reach a b))))
+
+(define
+  dl-reach-row-has?
+  (fn
+    (reach from to)
+    (let ((row (get reach from)))
+      (and (not (nil? row)) (has-key? row to)))))
+
+;; Compute stratum per relation. Iteratively propagate from EDB roots.
+;; Uses the per-relation max-stratum-of-deps formula. Stops when stable.
+(define
+  dl-compute-strata
+  (fn
+    (db)
+    (let
+      ((graph (dl-build-dep-graph db))
+        (nodes (dl-all-relations db))
+        (strata {}))
+      (do
+        (for-each (fn (n) (dict-set! strata n 0)) nodes)
+        (let ((changed true))
+          (do
+            (define
+              dl-cs-loop
+              (fn
+                ()
+                (when
+                  changed
+                  (do
+                    (set! changed false)
+                    (for-each
+                      (fn
+                        (head)
+                        (when
+                          (has-key? graph head)
+                          (for-each
+                            (fn
+                              (edge)
+                              (let
+                                ((tgt (get edge :rel))
+                                  (n (get edge :neg)))
+                                (let
+                                  ((tgt-strat
+                                     (if (has-key? strata tgt)
+                                       (get strata tgt) 0))
+                                    (cur (get strata head)))
+                                  (let
+                                    ((needed
+                                       (if n (+ tgt-strat 1) tgt-strat)))
+                                    (when
+                                      (> needed cur)
+                                      (do
+                                        (dict-set! strata head needed)
+                                        (set! changed true)))))))
+                            (get graph head))))
+                      nodes)
+                    (dl-cs-loop)))))
+            (dl-cs-loop)))
+        strata))))
+
+;; Group rules by their head's stratum. Returns dict {stratum-int -> rules}.
+(define
+  dl-group-rules-by-stratum
+  (fn
+    (db strata)
+    (let ((groups {}) (max-s 0))
+      (do
+        (for-each
+          (fn
+            (rule)
+            (let
+              ((head-rel (dl-rel-name (get rule :head))))
+              (let
+                ((s (if (has-key? strata head-rel)
+                       (get strata head-rel) 0)))
+                (do
+                  (when (> s max-s) (set! max-s s))
+                  (let
+                    ((sk (str s)))
+                    (do
+                      (when
+                        (not (has-key? groups sk))
+                        (dict-set! groups sk (list)))
+                      (append! (get groups sk) rule)))))))
+          (dl-rules db))
+        {:groups groups :max max-s}))))

lib/datalog/tests/aggregates.sx

@@ -0,0 +1,357 @@
+;; lib/datalog/tests/aggregates.sx — count / sum / min / max.
+
+(define dl-at-pass 0)
+(define dl-at-fail 0)
+(define dl-at-failures (list))
+
+(define
+  dl-at-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-at-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-at-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-at-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-at-deep=? (nth a i) (nth b i))) false)
+      (else (dl-at-deq-l? a b (+ i 1))))))
+
+(define
+  dl-at-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i)))
+         (not (dl-at-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-at-deq-d? a b ka (+ i 1))))))
+
+(define
+  dl-at-set=?
+  (fn
+    (a b)
+    (and
+      (= (len a) (len b))
+      (dl-at-subset? a b)
+      (dl-at-subset? b a))))
+
+(define
+  dl-at-subset?
+  (fn
+    (xs ys)
+    (cond
+      ((= (len xs) 0) true)
+      ((not (dl-at-contains? ys (first xs))) false)
+      (else (dl-at-subset? (rest xs) ys)))))
+
+(define
+  dl-at-contains?
+  (fn
+    (xs target)
+    (cond
+      ((= (len xs) 0) false)
+      ((dl-at-deep=? (first xs) target) true)
+      (else (dl-at-contains? (rest xs) target)))))
+
+(define
+  dl-at-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-at-deep=? got expected)
+      (set! dl-at-pass (+ dl-at-pass 1))
+      (do
+        (set! dl-at-fail (+ dl-at-fail 1))
+        (append!
+          dl-at-failures
+          (str
+            name
+            "\n    expected: " expected
+            "\n    got:      " got))))))
+
+(define
+  dl-at-test-set!
+  (fn
+    (name got expected)
+    (if
+      (dl-at-set=? got expected)
+      (set! dl-at-pass (+ dl-at-pass 1))
+      (do
+        (set! dl-at-fail (+ dl-at-fail 1))
+        (append!
+          dl-at-failures
+          (str
+            name
+            "\n    expected (set): " expected
+            "\n    got:            " got))))))
+
+(define
+  dl-at-throws?
+  (fn
+    (thunk)
+    (let
+      ((threw false))
+      (do
+        (guard
+          (e (#t (set! threw true)))
+          (thunk))
+        threw))))
+
+(define
+  dl-at-run-all!
+  (fn
+    ()
+    (do
+      ;; count
+      (dl-at-test-set! "count siblings"
+        (dl-query
+          (dl-program
+            "parent(p, bob). parent(p, alice). parent(p, charlie).
+             sibling(X, Y) :- parent(P, X), parent(P, Y), !=(X, Y).
+             sib_count(N) :- count(N, S, sibling(bob, S)).")
+          (list (quote sib_count) (quote N)))
+        (list {:N 2}))
+
+      ;; sum
+      (dl-at-test-set! "sum prices"
+        (dl-query
+          (dl-program
+            "price(apple, 5). price(pear, 7). price(plum, 3).
+             total(T) :- sum(T, X, price(F, X)).")
+          (list (quote total) (quote T)))
+        (list {:T 15}))
+
+      ;; min
+      (dl-at-test-set! "min score"
+        (dl-query
+          (dl-program
+            "score(alice, 80). score(bob, 65). score(carol, 92).
+             lo(M) :- min(M, S, score(P, S)).")
+          (list (quote lo) (quote M)))
+        (list {:M 65}))
+
+      ;; max
+      (dl-at-test-set! "max score"
+        (dl-query
+          (dl-program
+            "score(alice, 80). score(bob, 65). score(carol, 92).
+             hi(M) :- max(M, S, score(P, S)).")
+          (list (quote hi) (quote M)))
+        (list {:M 92}))
+
+      ;; count over derived relation (stratification needed).
+      (dl-at-test-set! "count over derived"
+        (dl-query
+          (dl-program
+            "parent(a, b). parent(a, c). parent(b, d). parent(c, e).
+             ancestor(X, Y) :- parent(X, Y).
+             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
+             num_ancestors(N) :- count(N, X, ancestor(a, X)).")
+          (list (quote num_ancestors) (quote N)))
+        (list {:N 4}))
+
+      ;; count with no matches → 0.
+      (dl-at-test-set! "count empty"
+        (dl-query
+          (dl-program
+            "p(1). p(2).
+             zero(N) :- count(N, X, q(X)).")
+          (list (quote zero) (quote N)))
+        (list {:N 0}))
+
+      ;; sum with no matches → 0.
+      (dl-at-test-set! "sum empty"
+        (dl-query
+          (dl-program
+            "p(1). p(2).
+             total(T) :- sum(T, X, q(X)).")
+          (list (quote total) (quote T)))
+        (list {:T 0}))
+
+      ;; min with no matches → rule does not fire.
+      (dl-at-test-set! "min empty"
+        (dl-query
+          (dl-program
+            "p(1). p(2).
+             lo(M) :- min(M, X, q(X)).")
+          (list (quote lo) (quote M)))
+        (list))
+
+      ;; Aggregate with comparison filter on result.
+      (dl-at-test-set! "popularity threshold"
+        (dl-query
+          (dl-program
+            "post(p1). post(p2).
+             liked(u1, p1). liked(u2, p1). liked(u3, p1).
+             liked(u1, p2). liked(u2, p2).
+             popular(P) :- post(P), count(N, U, liked(U, P)), >=(N, 3).")
+          (list (quote popular) (quote P)))
+        (list {:P (quote p1)}))
+
+      ;; findall: collect distinct values into a list.
+      (dl-at-test-set! "findall over EDB"
+        (dl-query
+          (dl-program
+            "p(a). p(b). p(c).
+             all_p(L) :- findall(L, X, p(X)).")
+          (list (quote all_p) (quote L)))
+        (list {:L (list (quote a) (quote b) (quote c))}))
+
+      (dl-at-test-set! "findall over derived"
+        (dl-query
+          (dl-program
+            "parent(a, b). parent(b, c). parent(c, d).
+             ancestor(X, Y) :- parent(X, Y).
+             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).
+             desc(L) :- findall(L, X, ancestor(a, X)).")
+          (list (quote desc) (quote L)))
+        (list {:L (list (quote b) (quote c) (quote d))}))
+
+      (dl-at-test-set! "findall empty"
+        (dl-query
+          (dl-program
+            "p(1).
+             all_q(L) :- findall(L, X, q(X)).")
+          (list (quote all_q) (quote L)))
+        (list {:L (list)}))
+
+      ;; Aggregate vs single distinct.
+      ;; Group-by via aggregate-in-rule-body. Per-user friend count
+      ;; over a friends relation. The U var is bound by the prior
+      ;; positive lit u(U) so the aggregate counts only U-rooted
+      ;; friends per group.
+      (dl-at-test-set! "group-by per-user friend count"
+        (dl-query
+          (dl-program
+            "u(alice). u(bob). u(carol).
+             f(alice, x). f(alice, y). f(bob, x).
+             counts(U, N) :- u(U), count(N, X, f(U, X)).")
+          (list (quote counts) (quote U) (quote N)))
+        (list
+          {:U (quote alice) :N 2}
+          {:U (quote bob) :N 1}
+          {:U (quote carol) :N 0}))
+
+      ;; Stratification: recursion through aggregation is rejected.
+      ;; Aggregate validates that second arg is a variable.
+      (dl-at-test! "agg second arg must be var"
+        (dl-at-throws?
+          (fn () (dl-eval "p(1). q(N) :- count(N, 5, p(X))." "?- q(N).")))
+        true)
+
+      ;; Aggregate validates that third arg is a positive literal.
+      (dl-at-test! "agg third arg must be a literal"
+        (dl-at-throws?
+          (fn () (dl-eval "p(1). q(N) :- count(N, X, 42)." "?- q(N).")))
+        true)
+
+      ;; Aggregate validates that the agg-var (2nd arg) appears in the
+      ;; goal. Without it every match contributes the same unbound
+      ;; symbol — count silently returns 1, sum raises a confusing
+      ;; "expected number" error, etc. Catch the mistake at safety
+      ;; check time instead.
+      (dl-at-test! "agg-var must appear in goal"
+        (dl-at-throws?
+          (fn ()
+            (dl-eval
+              "p(1). p(2). c(N) :- count(N, Y, p(X))."
+              "?- c(N).")))
+        true)
+
+      ;; Indirect recursion through aggregation also rejected.
+      ;; q -> r (via positive lit), r -> q (via aggregate body).
+      ;; The aggregate edge counts as negation for stratification.
+      (dl-at-test! "indirect agg cycle rejected"
+        (dl-at-throws?
+          (fn ()
+            (let ((db (dl-make-db)))
+              (do
+                (dl-add-rule! db
+                  {:head (list (quote q) (quote N))
+                   :body (list (list (quote r) (quote N)))})
+                (dl-add-rule! db
+                  {:head (list (quote r) (quote N))
+                   :body (list (list (quote count) (quote N) (quote X)
+                                     (list (quote q) (quote X))))})
+                (dl-saturate! db)))))
+        true)
+
+      (dl-at-test! "agg recursion rejected"
+        (dl-at-throws?
+          (fn ()
+            (let ((db (dl-make-db)))
+              (do
+                (dl-add-rule! db
+                  {:head (list (quote q) (quote N))
+                   :body (list (list (quote count) (quote N) (quote X)
+                                     (list (quote q) (quote X))))})
+                (dl-saturate! db)))))
+        true)
+
+      ;; Negation + aggregation in the same body — different strata.
+      (dl-at-test-set! "neg + agg coexist"
+        (dl-query
+          (dl-program
+            "u(a). u(b). u(c). banned(b).
+             active(X) :- u(X), not(banned(X)).
+             cnt(N) :- count(N, X, active(X)).")
+          (list (quote cnt) (quote N)))
+        (list {:N 2}))
+
+      ;; Min over a derived empty relation: no result.
+      (dl-at-test-set! "min over empty derived"
+        (dl-query
+          (dl-program
+            "s(50). s(60).
+             score(N) :- s(N), >(N, 100).
+             low(M) :- min(M, X, score(X)).")
+          (list (quote low) (quote M)))
+        (list))
+
+      ;; Aggregates as the top-level query goal (regression for
+      ;; dl-match-lit aggregate dispatch and projection cleanup).
+      (dl-at-test-set! "count as query goal"
+        (dl-query
+          (dl-program "p(1). p(2). p(3). p(4).")
+          (list (quote count) (quote N) (quote X) (list (quote p) (quote X))))
+        (list {:N 4}))
+
+      (dl-at-test-set! "findall as query goal"
+        (dl-query
+          (dl-program "p(1). p(2). p(3).")
+          (list (quote findall) (quote L) (quote X)
+                (list (quote p) (quote X))))
+        (list {:L (list 1 2 3)}))
+
+      (dl-at-test-set! "distinct counted once"
+        (dl-query
+          (dl-program
+            "rated(alice, x). rated(alice, y). rated(bob, x).
+             rater_count(N) :- count(N, U, rated(U, F)).")
+          (list (quote rater_count) (quote N)))
+        (list {:N 2})))))
+
+(define
+  dl-aggregates-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-at-pass 0)
+      (set! dl-at-fail 0)
+      (set! dl-at-failures (list))
+      (dl-at-run-all!)
+      {:passed dl-at-pass
+       :failed dl-at-fail
+       :total (+ dl-at-pass dl-at-fail)
+       :failures dl-at-failures})))

lib/datalog/tests/api.sx

@@ -0,0 +1,350 @@
+;; lib/datalog/tests/api.sx — SX-data embedding API.
+
+(define dl-api-pass 0)
+(define dl-api-fail 0)
+(define dl-api-failures (list))
+
+(define
+  dl-api-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-api-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-api-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-api-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-api-deep=? (nth a i) (nth b i))) false)
+      (else (dl-api-deq-l? a b (+ i 1))))))
+
+(define
+  dl-api-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i)))
+         (not (dl-api-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-api-deq-d? a b ka (+ i 1))))))
+
+(define
+  dl-api-set=?
+  (fn
+    (a b)
+    (and
+      (= (len a) (len b))
+      (dl-api-subset? a b)
+      (dl-api-subset? b a))))
+
+(define
+  dl-api-subset?
+  (fn
+    (xs ys)
+    (cond
+      ((= (len xs) 0) true)
+      ((not (dl-api-contains? ys (first xs))) false)
+      (else (dl-api-subset? (rest xs) ys)))))
+
+(define
+  dl-api-contains?
+  (fn
+    (xs target)
+    (cond
+      ((= (len xs) 0) false)
+      ((dl-api-deep=? (first xs) target) true)
+      (else (dl-api-contains? (rest xs) target)))))
+
+(define
+  dl-api-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-api-deep=? got expected)
+      (set! dl-api-pass (+ dl-api-pass 1))
+      (do
+        (set! dl-api-fail (+ dl-api-fail 1))
+        (append!
+          dl-api-failures
+          (str
+            name
+            "\n    expected: " expected
+            "\n    got:      " got))))))
+
+(define
+  dl-api-test-set!
+  (fn
+    (name got expected)
+    (if
+      (dl-api-set=? got expected)
+      (set! dl-api-pass (+ dl-api-pass 1))
+      (do
+        (set! dl-api-fail (+ dl-api-fail 1))
+        (append!
+          dl-api-failures
+          (str
+            name
+            "\n    expected (set): " expected
+            "\n    got:            " got))))))
+
+(define
+  dl-api-run-all!
+  (fn
+    ()
+    (do
+      ;; dl-program-data with arrow form.
+      (dl-api-test-set! "data API ancestor closure"
+        (dl-query
+          (dl-program-data
+            (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
+            (quote
+              ((ancestor X Y <- (parent X Y))
+               (ancestor X Z <- (parent X Y) (ancestor Y Z)))))
+          (quote (ancestor tom X)))
+        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
+
+      ;; dl-program-data with dict rules.
+      (dl-api-test-set! "data API with dict rules"
+        (dl-query
+          (dl-program-data
+            (quote ((p a) (p b) (p c)))
+            (list
+              {:head (quote (q X)) :body (quote ((p X)))}))
+          (quote (q X)))
+        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
+
+      ;; dl-rule helper.
+      (dl-api-test-set! "dl-rule constructor"
+        (dl-query
+          (dl-program-data
+            (quote ((p 1) (p 2)))
+            (list (dl-rule (quote (q X)) (quote ((p X))))))
+          (quote (q X)))
+        (list {:X 1} {:X 2}))
+
+      ;; dl-assert! adds and re-derives.
+      (dl-api-test-set! "dl-assert! incremental"
+        (let
+          ((db (dl-program-data
+                 (quote ((parent tom bob) (parent bob ann)))
+                 (quote
+                   ((ancestor X Y <- (parent X Y))
+                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
+          (do
+            (dl-saturate! db)
+            (dl-assert! db (quote (parent ann pat)))
+            (dl-query db (quote (ancestor tom X)))))
+        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
+
+      ;; dl-retract! removes a fact and recomputes IDB.
+      (dl-api-test-set! "dl-retract! removes derived"
+        (let
+          ((db (dl-program-data
+                 (quote ((parent tom bob) (parent bob ann) (parent ann pat)))
+                 (quote
+                   ((ancestor X Y <- (parent X Y))
+                    (ancestor X Z <- (parent X Y) (ancestor Y Z)))))))
+          (do
+            (dl-saturate! db)
+            (dl-retract! db (quote (parent bob ann)))
+            (dl-query db (quote (ancestor tom X)))))
+        (list {:X (quote bob)}))
+
+      ;; dl-retract! on a relation with BOTH explicit facts AND a rule
+      ;; (a "mixed" relation) used to wipe the EDB portion when the IDB
+      ;; was re-derived, even when the retract didn't match anything.
+      ;; :edb-keys provenance now preserves user-asserted facts.
+      (dl-api-test-set! "dl-retract! preserves EDB in mixed relation"
+        (let
+          ((db (dl-program-data
+                 (quote ((p a) (p b) (q c)))
+                 (quote ((p X <- (q X)))))))
+          (do
+            (dl-saturate! db)
+            ;; Retract a non-existent tuple — should be a no-op.
+            (dl-retract! db (quote (p z)))
+            (dl-query db (quote (p X)))))
+        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
+
+      ;; And retracting an actual EDB fact in a mixed relation drops
+      ;; only that fact; the derived portion stays.
+      (dl-api-test-set! "dl-retract! mixed: drop EDB, keep IDB"
+        (let
+          ((db (dl-program-data
+                 (quote ((p a) (p b) (q c)))
+                 (quote ((p X <- (q X)))))))
+          (do
+            (dl-saturate! db)
+            (dl-retract! db (quote (p a)))
+            (dl-query db (quote (p X)))))
+        (list {:X (quote b)} {:X (quote c)}))
+
+      ;; dl-program-data + dl-query with constants in head.
+      (dl-api-test-set! "constant-in-head data"
+        (dl-query
+          (dl-program-data
+            (quote ((edge a b) (edge b c) (edge c a)))
+            (quote
+              ((reach X Y <- (edge X Y))
+               (reach X Z <- (edge X Y) (reach Y Z)))))
+          (quote (reach a X)))
+        (list {:X (quote a)} {:X (quote b)} {:X (quote c)}))
+
+      ;; Assert into empty db.
+      (dl-api-test-set! "assert into empty"
+        (let
+          ((db (dl-program-data (list) (list))))
+          (do
+            (dl-assert! db (quote (p 1)))
+            (dl-assert! db (quote (p 2)))
+            (dl-query db (quote (p X)))))
+        (list {:X 1} {:X 2}))
+
+      ;; Multi-goal query: pass list of literals.
+      (dl-api-test-set! "multi-goal query"
+        (dl-query
+          (dl-program-data
+            (quote ((p 1) (p 2) (p 3) (q 2) (q 3)))
+            (list))
+          (list (quote (p X)) (quote (q X))))
+        (list {:X 2} {:X 3}))
+
+      ;; Multi-goal with comparison.
+      (dl-api-test-set! "multi-goal with comparison"
+        (dl-query
+          (dl-program-data
+            (quote ((n 1) (n 2) (n 3) (n 4) (n 5)))
+            (list))
+          (list (quote (n X)) (list (string->symbol ">") (quote X) 2)))
+        (list {:X 3} {:X 4} {:X 5}))
+
+      ;; dl-eval: single-call source + query.
+      (dl-api-test-set! "dl-eval ancestor"
+        (dl-eval
+          "parent(a, b). parent(b, c).
+           ancestor(X, Y) :- parent(X, Y).
+           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
+          "?- ancestor(a, X).")
+        (list {:X (quote b)} {:X (quote c)}))
+
+      (dl-api-test-set! "dl-eval multi-goal"
+        (dl-eval
+          "p(1). p(2). p(3). q(2). q(3)."
+          "?- p(X), q(X).")
+        (list {:X 2} {:X 3}))
+
+      ;; dl-rules-of: rules with head matching a relation name.
+      (dl-api-test! "dl-rules-of count"
+        (let
+          ((db (dl-program
+                 "p(1). q(X) :- p(X). r(X) :- p(X). q(2).")))
+          (len (dl-rules-of db "q")))
+        1)
+
+      (dl-api-test! "dl-rules-of empty"
+        (let
+          ((db (dl-program "p(1). p(2).")))
+          (len (dl-rules-of db "q")))
+        0)
+
+      ;; dl-clear-idb!: wipe rule-headed relations.
+      (dl-api-test! "dl-clear-idb! wipes IDB"
+        (let
+          ((db (dl-program
+                 "parent(a, b). parent(b, c).
+                  ancestor(X, Y) :- parent(X, Y).
+                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (do
+            (dl-saturate! db)
+            (dl-clear-idb! db)
+            (len (dl-relation db "ancestor"))))
+        0)
+
+      (dl-api-test! "dl-clear-idb! preserves EDB"
+        (let
+          ((db (dl-program
+                 "parent(a, b). parent(b, c).
+                  ancestor(X, Y) :- parent(X, Y).")))
+          (do
+            (dl-saturate! db)
+            (dl-clear-idb! db)
+            (len (dl-relation db "parent"))))
+        2)
+
+      ;; dl-eval-magic — routes single-goal queries through
+      ;; magic-sets evaluation.
+      (dl-api-test-set! "dl-eval-magic ancestor"
+        (dl-eval-magic
+          "parent(a, b). parent(b, c).
+           ancestor(X, Y) :- parent(X, Y).
+           ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."
+          "?- ancestor(a, X).")
+        (list {:X (quote b)} {:X (quote c)}))
+
+      ;; Equivalence: dl-eval and dl-eval-magic produce the same
+      ;; answers for any well-formed query (magic-sets is a perf
+      ;; alternative, not a semantic change).
+      (dl-api-test! "dl-eval ≡ dl-eval-magic on ancestor"
+        (let
+          ((source "parent(a, b). parent(b, c). parent(c, d).
+                    ancestor(X, Y) :- parent(X, Y).
+                    ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
+          (let
+            ((semi (dl-eval source "?- ancestor(a, X)."))
+              (magic (dl-eval-magic source "?- ancestor(a, X).")))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; Comprehensive integration: recursion + stratified negation
+      ;; + aggregation + comparison composed in a single program.
+      ;; (Uses _Anything as a regular var instead of `_` so the
+      ;;  outer rule binds via the reach lit.)
+      (dl-api-test-set! "integration"
+        (dl-eval
+          (str
+            "edge(a, b). edge(b, c). edge(c, d). edge(a, d). "
+            "banned(c). "
+            "reach(X, Y) :- edge(X, Y). "
+            "reach(X, Z) :- edge(X, Y), reach(Y, Z). "
+            "safe(X, Y) :- reach(X, Y), not(banned(Y)). "
+            "reach_count(X, N) :- reach(X, Z), count(N, Y, safe(X, Y)). "
+            "popular(X) :- reach_count(X, N), >=(N, 2).")
+          "?- popular(X).")
+        (list {:X (quote a)}))
+
+      ;; dl-rule-from-list with no arrow → fact-style.
+      (dl-api-test-set! "no arrow → fact-like rule"
+        (let
+          ((rule (dl-rule-from-list (quote (foo X Y)))))
+          (list rule))
+        (list {:head (quote (foo X Y)) :body (list)}))
+
+      ;; dl-coerce-rule on dict passes through.
+      (dl-api-test-set! "coerce dict rule"
+        (let
+          ((d {:head (quote (h X)) :body (quote ((b X)))}))
+          (list (dl-coerce-rule d)))
+        (list {:head (quote (h X)) :body (quote ((b X)))})))))
+
+(define
+  dl-api-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-api-pass 0)
+      (set! dl-api-fail 0)
+      (set! dl-api-failures (list))
+      (dl-api-run-all!)
+      {:passed dl-api-pass
+       :failed dl-api-fail
+       :total (+ dl-api-pass dl-api-fail)
+       :failures dl-api-failures})))

lib/datalog/tests/builtins.sx

@@ -0,0 +1,285 @@
+;; lib/datalog/tests/builtins.sx — comparison + arithmetic body literals.
+
+(define dl-bt-pass 0)
+(define dl-bt-fail 0)
+(define dl-bt-failures (list))
+
+(define
+  dl-bt-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-bt-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let
+          ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-bt-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-bt-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-bt-deep=? (nth a i) (nth b i))) false)
+      (else (dl-bt-deq-l? a b (+ i 1))))))
+
+(define
+  dl-bt-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i))) (not (dl-bt-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-bt-deq-d? a b ka (+ i 1))))))
+
+(define
+  dl-bt-set=?
+  (fn
+    (a b)
+    (and (= (len a) (len b)) (dl-bt-subset? a b) (dl-bt-subset? b a))))
+
+(define
+  dl-bt-subset?
+  (fn
+    (xs ys)
+    (cond
+      ((= (len xs) 0) true)
+      ((not (dl-bt-contains? ys (first xs))) false)
+      (else (dl-bt-subset? (rest xs) ys)))))
+
+(define
+  dl-bt-contains?
+  (fn
+    (xs target)
+    (cond
+      ((= (len xs) 0) false)
+      ((dl-bt-deep=? (first xs) target) true)
+      (else (dl-bt-contains? (rest xs) target)))))
+
+(define
+  dl-bt-test-set!
+  (fn
+    (name got expected)
+    (if
+      (dl-bt-set=? got expected)
+      (set! dl-bt-pass (+ dl-bt-pass 1))
+      (do
+        (set! dl-bt-fail (+ dl-bt-fail 1))
+        (append!
+          dl-bt-failures
+          (str
+            name
+            "\n    expected (set): "
+            expected
+            "\n    got:            "
+            got))))))
+
+(define
+  dl-bt-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-bt-deep=? got expected)
+      (set! dl-bt-pass (+ dl-bt-pass 1))
+      (do
+        (set! dl-bt-fail (+ dl-bt-fail 1))
+        (append!
+          dl-bt-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define
+  dl-bt-throws?
+  (fn
+    (thunk)
+    (let
+      ((threw false))
+      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
+
+(define
+  dl-bt-run-all!
+  (fn
+    ()
+    (do
+      (dl-bt-test-set!
+        "less than filter"
+        (dl-query
+          (dl-program
+            "age(alice, 30). age(bob, 17). age(carol, 22).\n             adult(X) :- age(X, A), >=(A, 18).")
+          (list (quote adult) (quote X)))
+        (list {:X (quote alice)} {:X (quote carol)}))
+      (dl-bt-test-set!
+        "less-equal filter"
+        (dl-query
+          (dl-program
+            "n(1). n(2). n(3). n(4). n(5).\n             small(X) :- n(X), <=(X, 3).")
+          (list (quote small) (quote X)))
+        (list {:X 1} {:X 2} {:X 3}))
+      (dl-bt-test-set!
+        "not-equal filter"
+        (dl-query
+          (dl-program
+            "p(1, 2). p(2, 2). p(3, 4).\n             diff(X, Y) :- p(X, Y), !=(X, Y).")
+          (list (quote diff) (quote X) (quote Y)))
+        (list {:X 1 :Y 2} {:X 3 :Y 4}))
+      (dl-bt-test-set!
+        "is plus"
+        (dl-query
+          (dl-program
+            "n(1). n(2). n(3).\n             succ(X, Y) :- n(X), is(Y, +(X, 1)).")
+          (list (quote succ) (quote X) (quote Y)))
+        (list {:X 1 :Y 2} {:X 2 :Y 3} {:X 3 :Y 4}))
+      (dl-bt-test-set!
+        "is multiply"
+        (dl-query
+          (dl-program
+            "n(2). n(3). n(4).\n             square(X, Y) :- n(X), is(Y, *(X, X)).")
+          (list (quote square) (quote X) (quote Y)))
+        (list {:X 2 :Y 4} {:X 3 :Y 9} {:X 4 :Y 16}))
+      (dl-bt-test-set!
+        "is nested expr"
+        (dl-query
+          (dl-program
+            "n(1). n(2). n(3).\n             f(X, Y) :- n(X), is(Y, *(+(X, 1), 2)).")
+          (list (quote f) (quote X) (quote Y)))
+        (list {:X 1 :Y 4} {:X 2 :Y 6} {:X 3 :Y 8}))
+      (dl-bt-test-set!
+        "is bound LHS — equality"
+        (dl-query
+          (dl-program
+            "n(1, 2). n(2, 5). n(3, 4).\n             succ(X, Y) :- n(X, Y), is(Y, +(X, 1)).")
+          (list (quote succ) (quote X) (quote Y)))
+        (list {:X 1 :Y 2} {:X 3 :Y 4}))
+      (dl-bt-test-set!
+        "triple via is"
+        (dl-query
+          (dl-program
+            "n(1). n(2). n(3).\n             triple(X, Y) :- n(X), is(Y, *(X, 3)).")
+          (list (quote triple) (quote X) (quote Y)))
+        (list {:X 1 :Y 3} {:X 2 :Y 6} {:X 3 :Y 9}))
+      (dl-bt-test-set!
+        "= unifies var with constant"
+        (dl-query
+          (dl-program "p(a). p(b).\n             qual(X) :- p(X), =(X, a).")
+          (list (quote qual) (quote X)))
+        (list {:X (quote a)}))
+      (dl-bt-test-set!
+        "= unifies two vars (one bound)"
+        (dl-query
+          (dl-program "p(a). p(b).\n             twin(X, Y) :- p(X), =(Y, X).")
+          (list (quote twin) (quote X) (quote Y)))
+        (list {:X (quote a) :Y (quote a)} {:X (quote b) :Y (quote b)}))
+      (dl-bt-test!
+        "big count"
+        (let
+          ((db (dl-program "n(0). n(1). n(2). n(3). n(4). n(5). n(6). n(7). n(8). n(9).\n                  big(X) :- n(X), >=(X, 5).")))
+          (do (dl-saturate! db) (len (dl-relation db "big"))))
+        5)
+      ;; Built-in / arithmetic literals work as standalone query goals
+      ;; (without needing a wrapper rule).
+      (dl-bt-test-set! "comparison-only goal true"
+        (dl-eval "" "?- <(1, 2).")
+        (list {}))
+
+      (dl-bt-test-set! "comparison-only goal false"
+        (dl-eval "" "?- <(2, 1).")
+        (list))
+
+      (dl-bt-test-set! "is goal binds"
+        (dl-eval "" "?- is(N, +(2, 3)).")
+        (list {:N 5}))
+
+      ;; Bounded successor: a recursive rule with a comparison
+      ;; guard terminates because the Herbrand base is effectively
+      ;; bounded.
+      (dl-bt-test-set! "bounded successor"
+        (dl-query
+          (dl-program
+            "nat(0).
+             nat(Y) :- nat(X), is(Y, +(X, 1)), <(Y, 5).")
+          (list (quote nat) (quote X)))
+        (list {:X 0} {:X 1} {:X 2} {:X 3} {:X 4}))
+
+      (dl-bt-test!
+        "unsafe — comparison without binder"
+        (dl-bt-throws? (fn () (dl-program "p(X) :- <(X, 5).")))
+        true)
+      (dl-bt-test!
+        "unsafe — comparison both unbound"
+        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- <(X, Y), q(X).")))
+        true)
+      (dl-bt-test!
+        "unsafe — is uses unbound RHS var"
+        (dl-bt-throws?
+          (fn () (dl-program "p(X, Y) :- q(X), is(Y, +(X, Z)).")))
+        true)
+      (dl-bt-test!
+        "unsafe — is on its own"
+        (dl-bt-throws? (fn () (dl-program "p(Y) :- is(Y, +(X, 1)).")))
+        true)
+      (dl-bt-test!
+        "unsafe — = between two unbound"
+        (dl-bt-throws? (fn () (dl-program "p(X, Y) :- =(X, Y).")))
+        true)
+      (dl-bt-test!
+        "safe — is binds head var"
+        (dl-bt-throws?
+          (fn () (dl-program "n(1). p(Y) :- n(X), is(Y, +(X, 1)).")))
+        false)
+      (dl-bt-test!
+        "safe — comparison after binder"
+        (dl-bt-throws?
+          (fn () (dl-program "n(1). big(X) :- n(X), >=(X, 0).")))
+        false)
+      (dl-bt-test!
+        "safe — = binds head var"
+        (dl-bt-throws?
+          (fn () (dl-program "p(a). p(b). x(Y) :- p(X), =(Y, X).")))
+        false)
+
+      ;; Division by zero raises with a clear error. Without this guard
+      ;; SX's `/` returned IEEE infinity, which then silently flowed
+      ;; through comparisons and aggregations.
+      (dl-bt-test!
+        "is — division by zero raises"
+        (dl-bt-throws?
+          (fn ()
+            (dl-eval "p(10). q(R) :- p(X), is(R, /(X, 0))." "?- q(R).")))
+        true)
+
+      ;; Comparison ops `<`, `<=`, `>`, `>=` require both operands to
+      ;; have the same primitive type. Cross-type comparisons used to
+      ;; silently return false (for some pairs) or raise a confusing
+      ;; host-level error (for others) — now they all raise with a
+      ;; message that names the offending values.
+      (dl-bt-test!
+        "comparison — string vs number raises"
+        (dl-bt-throws?
+          (fn ()
+            (dl-eval "p(\"hello\"). q(X) :- p(X), <(X, 5)." "?- q(X).")))
+        true)
+
+      ;; `!=` is the exception — it's a polymorphic inequality test
+      ;; (uses dl-tuple-equal? underneath) so cross-type pairs are
+      ;; legitimate (and trivially unequal).
+      (dl-bt-test-set! "!= works across types"
+        (dl-query
+          (dl-program
+            "p(1). p(\"1\"). q(X) :- p(X), !=(X, 1).")
+          (quote (q X)))
+        (list {:X "1"})))))
+
+(define
+  dl-builtins-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-bt-pass 0)
+      (set! dl-bt-fail 0)
+      (set! dl-bt-failures (list))
+      (dl-bt-run-all!)
+      {:failures dl-bt-failures :total (+ dl-bt-pass dl-bt-fail) :passed dl-bt-pass :failed dl-bt-fail})))

lib/datalog/tests/demo.sx

@@ -0,0 +1,321 @@
+;; lib/datalog/tests/demo.sx — Phase 10 demo programs.
+
+(define dl-demo-pass 0)
+(define dl-demo-fail 0)
+(define dl-demo-failures (list))
+
+(define
+  dl-demo-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-demo-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-demo-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-demo-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-demo-deep=? (nth a i) (nth b i))) false)
+      (else (dl-demo-deq-l? a b (+ i 1))))))
+
+(define
+  dl-demo-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i)))
+         (not (dl-demo-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-demo-deq-d? a b ka (+ i 1))))))
+
+(define
+  dl-demo-set=?
+  (fn
+    (a b)
+    (and
+      (= (len a) (len b))
+      (dl-demo-subset? a b)
+      (dl-demo-subset? b a))))
+
+(define
+  dl-demo-subset?
+  (fn
+    (xs ys)
+    (cond
+      ((= (len xs) 0) true)
+      ((not (dl-demo-contains? ys (first xs))) false)
+      (else (dl-demo-subset? (rest xs) ys)))))
+
+(define
+  dl-demo-contains?
+  (fn
+    (xs target)
+    (cond
+      ((= (len xs) 0) false)
+      ((dl-demo-deep=? (first xs) target) true)
+      (else (dl-demo-contains? (rest xs) target)))))
+
+(define
+  dl-demo-test-set!
+  (fn
+    (name got expected)
+    (if
+      (dl-demo-set=? got expected)
+      (set! dl-demo-pass (+ dl-demo-pass 1))
+      (do
+        (set! dl-demo-fail (+ dl-demo-fail 1))
+        (append!
+          dl-demo-failures
+          (str
+            name
+            "\n    expected (set): " expected
+            "\n    got:            " got))))))
+
+(define
+  dl-demo-run-all!
+  (fn
+    ()
+    (do
+      ;; ── Federation ──────────────────────────────────────────
+      (dl-demo-test-set! "mutuals"
+        (dl-query
+          (dl-demo-make
+            (quote ((follows alice bob) (follows bob alice)
+                    (follows bob carol) (follows carol dave)))
+            dl-demo-federation-rules)
+          (quote (mutual alice X)))
+        (list {:X (quote bob)}))
+
+      (dl-demo-test-set! "reachable transitive"
+        (dl-query
+          (dl-demo-make
+            (quote ((follows alice bob) (follows bob carol) (follows carol dave)))
+            dl-demo-federation-rules)
+          (quote (reachable alice X)))
+        (list {:X (quote bob)} {:X (quote carol)} {:X (quote dave)}))
+
+      (dl-demo-test-set! "foaf"
+        (dl-query
+          (dl-demo-make
+            (quote ((follows alice bob) (follows bob carol) (follows alice dave)))
+            dl-demo-federation-rules)
+          (quote (foaf alice X)))
+        (list {:X (quote carol)}))
+
+      ;; ── Content ─────────────────────────────────────────────
+      (dl-demo-test-set! "popular posts"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((authored alice p1) (authored bob p2) (authored carol p3)
+               (liked u1 p1) (liked u2 p1) (liked u3 p1)
+               (liked u1 p2)))
+            dl-demo-content-rules)
+          (quote (popular P)))
+        (list {:P (quote p1)}))
+
+      (dl-demo-test-set! "interesting feed"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((follows me alice) (follows me bob)
+               (authored alice p1) (authored bob p2)
+               (liked u1 p1) (liked u2 p1) (liked u3 p1)
+               (liked u4 p2)))
+            dl-demo-content-rules)
+          (quote (interesting me P)))
+        (list {:P (quote p1)}))
+
+      (dl-demo-test-set! "post likes count"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((authored alice p1)
+               (liked u1 p1) (liked u2 p1) (liked u3 p1)))
+            dl-demo-content-rules)
+          (quote (post-likes p1 N)))
+        (list {:N 3}))
+
+      ;; ── Permissions ─────────────────────────────────────────
+      (dl-demo-test-set! "direct group access"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((member alice editors)
+               (allowed editors blog)))
+            dl-demo-perm-rules)
+          (quote (can-access X blog)))
+        (list {:X (quote alice)}))
+
+      (dl-demo-test-set! "subgroup access"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((member bob writers)
+               (subgroup writers editors)
+               (allowed editors blog)))
+            dl-demo-perm-rules)
+          (quote (can-access X blog)))
+        (list {:X (quote bob)}))
+
+      (dl-demo-test-set! "transitive subgroup"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((member carol drafters)
+               (subgroup drafters writers)
+               (subgroup writers editors)
+               (allowed editors blog)))
+            dl-demo-perm-rules)
+          (quote (can-access X blog)))
+        (list {:X (quote carol)}))
+
+      ;; ── Cooking posts (canonical Phase 10 example) ─────────
+      (dl-demo-test-set! "cooking posts by network"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((follows me alice) (follows alice bob) (follows alice carol)
+               (authored alice p1) (authored bob p2)
+               (authored carol p3) (authored carol p4)
+               (tagged p1 travel) (tagged p2 cooking)
+               (tagged p3 cooking) (tagged p4 books)))
+            dl-demo-cooking-rules)
+          (quote (cooking-post-by-network me P)))
+        (list {:P (quote p2)} {:P (quote p3)}))
+
+      (dl-demo-test-set! "cooking — direct follow only"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((follows me bob)
+               (authored bob p1) (authored bob p2)
+               (tagged p1 cooking) (tagged p2 books)))
+            dl-demo-cooking-rules)
+          (quote (cooking-post-by-network me P)))
+        (list {:P (quote p1)}))
+
+      (dl-demo-test-set! "cooking — none in network"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((follows me bob)
+               (authored bob p1) (tagged p1 books)))
+            dl-demo-cooking-rules)
+          (quote (cooking-post-by-network me P)))
+        (list))
+
+      ;; ── Tag co-occurrence ──────────────────────────────────
+      (dl-demo-test-set! "cotagged posts"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((tagged p1 cooking) (tagged p1 vegetarian)
+               (tagged p2 cooking) (tagged p2 quick)
+               (tagged p3 vegetarian)))
+            dl-demo-tag-cooccur-rules)
+          (quote (cotagged P cooking vegetarian)))
+        (list {:P (quote p1)}))
+
+      (dl-demo-test-set! "tag pair count"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((tagged p1 cooking) (tagged p1 vegetarian)
+               (tagged p2 cooking) (tagged p2 quick)
+               (tagged p3 cooking) (tagged p3 vegetarian)))
+            dl-demo-tag-cooccur-rules)
+          (quote (tag-pair-count cooking vegetarian N)))
+        (list {:N 2}))
+
+      ;; ── Shortest path on a weighted DAG ──────────────────
+      (dl-demo-test-set! "shortest a→d via DAG"
+        (dl-query
+          (dl-demo-make
+            (quote ((edge a b 5) (edge b c 3) (edge a c 10) (edge c d 2)))
+            dl-demo-shortest-path-rules)
+          (quote (shortest a d W)))
+        (list {:W 10}))
+
+      (dl-demo-test-set! "shortest a→c picks 2-hop"
+        (dl-query
+          (dl-demo-make
+            (quote ((edge a b 5) (edge b c 3) (edge a c 10)))
+            dl-demo-shortest-path-rules)
+          (quote (shortest a c W)))
+        (list {:W 8}))
+
+      (dl-demo-test-set! "shortest unreachable empty"
+        (dl-query
+          (dl-demo-make
+            (quote ((edge a b 5) (edge b c 3)))
+            dl-demo-shortest-path-rules)
+          (quote (shortest a d W)))
+        (list))
+
+      ;; ── Org chart + headcount ─────────────────────────────
+      (dl-demo-test-set! "ceo subordinate transitive"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((manager ic1 mgr1) (manager ic2 mgr1)
+               (manager mgr1 vp1) (manager ic3 vp1)
+               (manager vp1 ceo)))
+            dl-demo-org-rules)
+          (quote (subordinate ceo X)))
+        (list
+          {:X (quote vp1)} {:X (quote mgr1)} {:X (quote ic1)}
+          {:X (quote ic2)} {:X (quote ic3)}))
+
+      (dl-demo-test-set! "ceo headcount = 5"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((manager ic1 mgr1) (manager ic2 mgr1)
+               (manager mgr1 vp1) (manager ic3 vp1)
+               (manager vp1 ceo)))
+            dl-demo-org-rules)
+          (quote (headcount ceo N)))
+        (list {:N 5}))
+
+      (dl-demo-test-set! "mgr1 headcount = 2"
+        (dl-query
+          (dl-demo-make
+            (quote
+              ((manager ic1 mgr1) (manager ic2 mgr1)
+               (manager mgr1 vp1) (manager ic3 vp1)
+               (manager vp1 ceo)))
+            dl-demo-org-rules)
+          (quote (headcount mgr1 N)))
+        (list {:N 2}))
+
+      (dl-demo-test-set! "no access without grant"
+        (dl-query
+          (dl-demo-make
+            (quote ((member dave outsiders) (allowed editors blog)))
+            dl-demo-perm-rules)
+          (quote (can-access X blog)))
+        (list)))))
+
+(define
+  dl-demo-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-demo-pass 0)
+      (set! dl-demo-fail 0)
+      (set! dl-demo-failures (list))
+      (dl-demo-run-all!)
+      {:passed dl-demo-pass
+       :failed dl-demo-fail
+       :total (+ dl-demo-pass dl-demo-fail)
+       :failures dl-demo-failures})))

lib/datalog/tests/eval.sx

@@ -0,0 +1,463 @@
+;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
+
+(define dl-et-pass 0)
+(define dl-et-fail 0)
+(define dl-et-failures (list))
+
+;; Same deep-equal helper used in other suites.
+(define
+  dl-et-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let
+          ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-et-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-et-deep=? (nth a i) (nth b i))) false)
+      (else (dl-et-deq-l? a b (+ i 1))))))
+
+(define
+  dl-et-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-et-deq-d? a b ka (+ i 1))))))
+
+;; Set-equality on lists (order-independent, uses dl-et-deep=?).
+(define
+  dl-et-set=?
+  (fn
+    (a b)
+    (and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
+
+(define
+  dl-et-subset?
+  (fn
+    (xs ys)
+    (cond
+      ((= (len xs) 0) true)
+      ((not (dl-et-contains? ys (first xs))) false)
+      (else (dl-et-subset? (rest xs) ys)))))
+
+(define
+  dl-et-contains?
+  (fn
+    (xs target)
+    (cond
+      ((= (len xs) 0) false)
+      ((dl-et-deep=? (first xs) target) true)
+      (else (dl-et-contains? (rest xs) target)))))
+
+(define
+  dl-et-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-et-deep=? got expected)
+      (set! dl-et-pass (+ dl-et-pass 1))
+      (do
+        (set! dl-et-fail (+ dl-et-fail 1))
+        (append!
+          dl-et-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define
+  dl-et-test-set!
+  (fn
+    (name got expected)
+    (if
+      (dl-et-set=? got expected)
+      (set! dl-et-pass (+ dl-et-pass 1))
+      (do
+        (set! dl-et-fail (+ dl-et-fail 1))
+        (append!
+          dl-et-failures
+          (str
+            name
+            "\n    expected (set): "
+            expected
+            "\n    got:            "
+            got))))))
+
+(define
+  dl-et-throws?
+  (fn
+    (thunk)
+    (let
+      ((threw false))
+      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
+
+(define
+  dl-et-run-all!
+  (fn
+    ()
+    (do
+      (dl-et-test-set!
+        "fact lookup any"
+        (dl-query
+          (dl-program "parent(tom, bob). parent(bob, ann).")
+          (list (quote parent) (quote X) (quote Y)))
+        (list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
+      (dl-et-test-set!
+        "fact lookup constant arg"
+        (dl-query
+          (dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
+          (list (quote parent) (quote tom) (quote Y)))
+        (list {:Y (quote bob)} {:Y (quote liz)}))
+      (dl-et-test-set!
+        "no match"
+        (dl-query
+          (dl-program "parent(tom, bob).")
+          (list (quote parent) (quote nobody) (quote X)))
+        (list))
+      (dl-et-test-set!
+        "ancestor closure"
+        (dl-query
+          (dl-program
+            "parent(tom, bob). parent(bob, ann). parent(ann, pat).\n             ancestor(X, Y) :- parent(X, Y).\n             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
+          (list (quote ancestor) (quote tom) (quote X)))
+        (list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
+      (dl-et-test-set!
+        "sibling"
+        (dl-query
+          (dl-program
+            "parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n             sibling(X, Y) :- parent(P, X), parent(P, Y).")
+          (list (quote sibling) (quote bob) (quote Y)))
+        (list {:Y (quote bob)} {:Y (quote liz)}))
+      (dl-et-test-set!
+        "same-generation"
+        (dl-query
+          (dl-program
+            "parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n             person(tom). person(bob). person(liz). person(ann). person(joe).\n             sg(X, X) :- person(X).\n             sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
+          (list (quote sg) (quote ann) (quote X)))
+        (list {:X (quote ann)} {:X (quote joe)}))
+      (dl-et-test!
+        "ancestor count"
+        (let
+          ((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n                  ancestor(X, Y) :- parent(X, Y).\n                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (do (dl-saturate! db) (len (dl-relation db "ancestor"))))
+        6)
+      (dl-et-test-set!
+        "grandparent"
+        (dl-query
+          (dl-program
+            "parent(a, b). parent(b, c). parent(c, d).\n             grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
+          (list (quote grandparent) (quote X) (quote Y)))
+        (list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
+      (dl-et-test!
+        "no recursion infinite loop"
+        (let
+          ((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n                  reach(X, Y) :- edge(X, Y).\n                  reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
+          (do (dl-saturate! db) (len (dl-relation db "reach"))))
+        9)
+      ;; Rule-shape sanity: empty-list head and non-list body raise
+      ;; clear errors rather than crashing inside the saturator.
+      (dl-et-test! "empty head rejected"
+        (dl-et-throws?
+          (fn ()
+            (dl-add-rule! (dl-make-db)
+              {:head (list) :body (list)})))
+        true)
+
+      (dl-et-test! "non-list body rejected"
+        (dl-et-throws?
+          (fn ()
+            (dl-add-rule! (dl-make-db)
+              {:head (list (quote p) (quote X)) :body 42})))
+        true)
+
+      ;; Reserved relation names rejected as rule/fact heads.
+      (dl-et-test!
+        "reserved name `not` as head rejected"
+        (dl-et-throws? (fn () (dl-program "not(X) :- p(X).")))
+        true)
+
+      (dl-et-test!
+        "reserved name `count` as head rejected"
+        (dl-et-throws?
+          (fn () (dl-program "count(N, X, p(X)) :- p(X).")))
+        true)
+
+      (dl-et-test!
+        "reserved name `<` as head rejected"
+        (dl-et-throws? (fn () (dl-program "<(X, 5) :- p(X).")))
+        true)
+
+      (dl-et-test!
+        "reserved name `is` as head rejected"
+        (dl-et-throws? (fn () (dl-program "is(N, +(1, 2)) :- p(N).")))
+        true)
+
+      ;; Body literal with a reserved-name positive head is rejected.
+      ;; The parser only treats outer-level `not(P)` as negation; nested
+      ;; `not(not(P))` would otherwise silently parse as a positive call
+      ;; to a relation named `not` and succeed vacuously. The safety
+      ;; checker now flags this so the user gets a clear error.
+      ;; Body literal with a reserved-name positive head is rejected.
+      ;; The parser only treats outer-level `not(P)` as negation; nested
+      ;; `not(not(P))` would otherwise silently parse as a positive call
+      ;; to a relation named `not` and succeed vacuously — so the safety
+      ;; checker now flags this to give the user a clear error.
+      (dl-et-test!
+        "nested not(not(...)) rejected"
+        (dl-et-throws?
+          (fn ()
+            (dl-program
+              "banned(a). u(a). vip(X) :- u(X), not(not(banned(X))).")))
+        true)
+
+      ;; A dict body literal that isn't `{:neg ...}` is almost always a
+      ;; typo — it would otherwise silently fall through to a confusing
+      ;; head-var-unbound safety error. Now caught with a clear message.
+      (dl-et-test!
+        "dict body lit without :neg rejected"
+        (dl-et-throws?
+          (fn ()
+            (let ((db (dl-make-db)))
+              (dl-add-rule! db
+                {:head (list (quote p) (quote X))
+                 :body (list {:weird "stuff"})}))))
+        true)
+
+      ;; Facts may only have simple-term args (number / string / symbol).
+      ;; A compound arg like `+(1, 2)` would otherwise be silently
+      ;; stored as the unreduced expression `(+ 1 2)` because dl-ground?
+      ;; sees no free variables.
+      (dl-et-test!
+        "compound arg in fact rejected"
+        (dl-et-throws? (fn () (dl-program "p(+(1, 2)).")))
+        true)
+
+      ;; Rule heads may only have variable or constant args — no
+      ;; compounds. Compound heads would be saturated as unreduced
+      ;; tuples rather than the arithmetic result the user expected.
+      (dl-et-test!
+        "compound arg in rule head rejected"
+        (dl-et-throws?
+          (fn () (dl-program "n(3). double(*(X, 2)) :- n(X).")))
+        true)
+
+      ;; The anonymous-variable renamer used to start at `_anon1`
+      ;; unconditionally; a rule that wrote `q(_anon1) :- p(_anon1, _)`
+      ;; (the user picking the same name the renamer would generate)
+      ;; would see the `_` renamed to `_anon1` too, collapsing the
+      ;; two positions in `p(_anon1, _)` to a single var. Now the
+      ;; renamer scans the rule for the max `_anon<N>` and starts past
+      ;; it, so user-written names of that form are preserved.
+      (dl-et-test-set! "anonymous-rename avoids user `_anon` collision"
+        (dl-query
+          (dl-program
+            "p(a, b). p(c, d). q(_anon1) :- p(_anon1, _).")
+          (quote (q X)))
+        (list {:X (quote a)} {:X (quote c)}))
+
+      (dl-et-test!
+        "unsafe head var"
+        (dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
+        true)
+      (dl-et-test!
+        "unsafe — empty body"
+        (dl-et-throws? (fn () (dl-program "p(X) :- .")))
+        true)
+      ;; Underscore in head is unsafe — it's a fresh existential per
+      ;; occurrence after Phase 5d's anonymous-var renaming, and there's
+      ;; nothing in the body to bind it. (Old behavior accepted this by
+      ;; treating '_' as a literal name to skip; the renaming made it an
+      ;; ordinary unbound variable.)
+      (dl-et-test!
+        "underscore in head — unsafe"
+        (dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
+        true)
+      (dl-et-test!
+        "underscore in body only — safe"
+        (dl-et-throws? (fn () (dl-program "p(X) :- q(X, _).")))
+        false)
+      (dl-et-test!
+        "var only in head — unsafe"
+        (dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
+        true)
+      (dl-et-test!
+        "head var bound by body"
+        (dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
+        false)
+      (dl-et-test!
+        "head subset of body"
+        (dl-et-throws?
+          (fn
+            ()
+            (dl-program
+              "edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
+        false)
+
+      ;; Anonymous variables: each occurrence must be independent.
+      (dl-et-test-set! "anon vars in rule are independent"
+        (dl-query
+          (dl-program
+            "p(a, b). p(c, d). q(X) :- p(X, _), p(_, Y).")
+          (list (quote q) (quote X)))
+        (list {:X (quote a)} {:X (quote c)}))
+
+      (dl-et-test-set! "anon vars in goal are independent"
+        (dl-query
+          (dl-program "p(1, 2, 3). p(4, 5, 6).")
+          (list (quote p) (quote _) (quote X) (quote _)))
+        (list {:X 2} {:X 5}))
+
+      ;; dl-summary: relation -> tuple-count for inspection.
+      (dl-et-test! "dl-summary basic"
+        (dl-summary
+          (let
+            ((db (dl-program "p(1). p(2). q(3).")))
+            (do (dl-saturate! db) db)))
+        {:p 2 :q 1})
+
+      (dl-et-test! "dl-summary empty IDB shown"
+        (dl-summary
+          (let
+            ((db (dl-program "r(X) :- s(X).")))
+            (do (dl-saturate! db) db)))
+        {:r 0})
+
+      (dl-et-test! "dl-summary mixed EDB and IDB"
+        (dl-summary
+          (let
+            ((db (dl-program
+                   "parent(a, b).
+                    ancestor(X, Y) :- parent(X, Y).
+                    ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+            (do (dl-saturate! db) db)))
+        {:parent 1 :ancestor 1})
+
+      (dl-et-test! "dl-summary empty db"
+        (dl-summary (dl-make-db))
+        {})
+
+      ;; Strategy hook: default semi-naive; :magic accepted but
+      ;; falls back to semi-naive (the transformation itself is
+      ;; deferred — Phase 6 in plan).
+      (dl-et-test! "default strategy"
+        (dl-get-strategy (dl-make-db))
+        :semi-naive)
+
+      (dl-et-test! "set strategy"
+        (let ((db (dl-make-db)))
+          (do (dl-set-strategy! db :magic) (dl-get-strategy db)))
+        :magic)
+
+      ;; Unknown strategy values are rejected so typos don't silently
+      ;; fall back to the default.
+      (dl-et-test!
+        "unknown strategy rejected"
+        (dl-et-throws?
+          (fn ()
+            (let ((db (dl-make-db)))
+              (dl-set-strategy! db :semi_naive))))
+        true)
+
+      ;; dl-saturated?: no-work-left predicate.
+      (dl-et-test! "saturated? after saturation"
+        (let ((db (dl-program
+                    "parent(a, b).
+                     ancestor(X, Y) :- parent(X, Y).")))
+          (do (dl-saturate! db) (dl-saturated? db)))
+        true)
+
+      (dl-et-test! "saturated? before saturation"
+        (let ((db (dl-program
+                    "parent(a, b).
+                     ancestor(X, Y) :- parent(X, Y).")))
+          (dl-saturated? db))
+        false)
+
+      ;; Disjunction via multiple rules — Datalog has no `;` in
+      ;; body, so disjunction is expressed as separate rules with
+      ;; the same head. Here plant_based(X) is satisfied by either
+      ;; vegan(X) or vegetarian(X).
+      (dl-et-test-set! "disjunction via multiple rules"
+        (dl-query
+          (dl-program
+            "vegan(alice). vegetarian(bob). meat_eater(carol).
+             plant_based(X) :- vegan(X).
+             plant_based(X) :- vegetarian(X).")
+          (list (quote plant_based) (quote X)))
+        (list {:X (quote alice)} {:X (quote bob)}))
+
+      ;; Bipartite-style join: pair-of-friends who share a hobby.
+      ;; Three-relation join exercising the planner's join order.
+      (dl-et-test-set! "bipartite friends-with-hobby"
+        (dl-query
+          (dl-program
+            "hobby(alice, climb). hobby(bob, paint).
+             hobby(carol, climb).
+             friend(alice, carol). friend(bob, alice).
+             match(A, B, H) :- friend(A, B), hobby(A, H), hobby(B, H).")
+          (list (quote match) (quote A) (quote B) (quote H)))
+        (list {:A (quote alice) :B (quote carol) :H (quote climb)}))
+
+      ;; Repeated variable (diagonal): p(X, X) only matches tuples
+      ;; whose two args are equal. The unifier handles this via the
+      ;; subst chain — first occurrence binds X, second occurrence
+      ;; checks against the binding.
+      (dl-et-test-set! "diagonal query"
+        (dl-query
+          (dl-program "p(1, 1). p(2, 3). p(4, 4). p(5, 5).")
+          (list (quote p) (quote X) (quote X)))
+        (list {:X 1} {:X 4} {:X 5}))
+
+      ;; A relation can be both EDB-seeded and rule-derived;
+      ;; saturate combines facts + derivations.
+      (dl-et-test-set! "mixed EDB + IDB same relation"
+        (dl-query
+          (dl-program
+            "link(a, b). link(c, d). link(e, c).
+             via(a, e).
+             link(X, Y) :- via(X, M), link(M, Y).")
+          (list (quote link) (quote a) (quote X)))
+        (list {:X (quote b)} {:X (quote c)}))
+
+      (dl-et-test! "saturated? after assert"
+        (let ((db (dl-program
+                    "parent(a, b).
+                     ancestor(X, Y) :- parent(X, Y).")))
+          (do
+            (dl-saturate! db)
+            (dl-add-fact! db (list (quote parent) (quote b) (quote c)))
+            (dl-saturated? db)))
+        false)
+
+      (dl-et-test-set! "magic-set still derives correctly"
+        (let
+          ((db (dl-program
+                 "parent(a, b). parent(b, c).
+                  ancestor(X, Y) :- parent(X, Y).
+                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (do
+            (dl-set-strategy! db :magic)
+            (dl-query db (list (quote ancestor) (quote a) (quote X)))))
+        (list {:X (quote b)} {:X (quote c)})))))
+
+(define
+  dl-eval-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-et-pass 0)
+      (set! dl-et-fail 0)
+      (set! dl-et-failures (list))
+      (dl-et-run-all!)
+      {:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))

lib/datalog/tests/magic.sx

@@ -0,0 +1,528 @@
+;; lib/datalog/tests/magic.sx — adornment + SIPS analysis tests.
+
+(define dl-mt-pass 0)
+(define dl-mt-fail 0)
+(define dl-mt-failures (list))
+
+(define
+  dl-mt-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-mt-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-mt-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-mt-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-mt-deep=? (nth a i) (nth b i))) false)
+      (else (dl-mt-deq-l? a b (+ i 1))))))
+
+(define
+  dl-mt-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i)))
+         (not (dl-mt-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-mt-deq-d? a b ka (+ i 1))))))
+
+(define
+  dl-mt-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-mt-deep=? got expected)
+      (set! dl-mt-pass (+ dl-mt-pass 1))
+      (do
+        (set! dl-mt-fail (+ dl-mt-fail 1))
+        (append!
+          dl-mt-failures
+          (str
+            name
+            "\n    expected: " expected
+            "\n    got:      " got))))))
+
+(define
+  dl-mt-run-all!
+  (fn
+    ()
+    (do
+      ;; Goal adornment.
+      (dl-mt-test! "adorn 0-ary"
+        (dl-adorn-goal (list (quote ready)))
+        "")
+      (dl-mt-test! "adorn all bound"
+        (dl-adorn-goal (list (quote p) 1 2 3))
+        "bbb")
+      (dl-mt-test! "adorn all free"
+        (dl-adorn-goal (list (quote p) (quote X) (quote Y)))
+        "ff")
+      (dl-mt-test! "adorn mixed"
+        (dl-adorn-goal (list (quote ancestor) (quote tom) (quote X)))
+        "bf")
+      (dl-mt-test! "adorn const var const"
+        (dl-adorn-goal (list (quote p) (quote a) (quote X) (quote b)))
+        "bfb")
+
+      ;; dl-adorn-lit with explicit bound set.
+      (dl-mt-test! "adorn lit with bound"
+        (dl-adorn-lit (list (quote p) (quote X) (quote Y)) (list "X"))
+        "bf")
+
+      ;; Rule SIPS — chain ancestor.
+      (dl-mt-test! "sips chain ancestor bf"
+        (dl-rule-sips
+          {:head (list (quote ancestor) (quote X) (quote Z))
+           :body (list (list (quote parent) (quote X) (quote Y))
+                       (list (quote ancestor) (quote Y) (quote Z)))}
+          "bf")
+        (list
+          {:lit (list (quote parent) (quote X) (quote Y)) :adornment "bf"}
+          {:lit (list (quote ancestor) (quote Y) (quote Z)) :adornment "bf"}))
+
+      ;; SIPS — head fully bound.
+      (dl-mt-test! "sips head bb"
+        (dl-rule-sips
+          {:head (list (quote q) (quote X) (quote Y))
+           :body (list (list (quote p) (quote X) (quote Z))
+                       (list (quote r) (quote Z) (quote Y)))}
+          "bb")
+        (list
+          {:lit (list (quote p) (quote X) (quote Z)) :adornment "bf"}
+          {:lit (list (quote r) (quote Z) (quote Y)) :adornment "bb"}))
+
+      ;; SIPS — comparison; vars must be bound by prior body lit.
+      (dl-mt-test! "sips with comparison"
+        (dl-rule-sips
+          {:head (list (quote q) (quote X))
+           :body (list (list (quote p) (quote X))
+                       (list (string->symbol "<") (quote X) 5))}
+          "f")
+        (list
+          {:lit (list (quote p) (quote X)) :adornment "f"}
+          {:lit (list (string->symbol "<") (quote X) 5) :adornment "bb"}))
+
+      ;; SIPS — `is` binds its left arg.
+      (dl-mt-test! "sips with is"
+        (dl-rule-sips
+          {:head (list (quote q) (quote X) (quote Y))
+           :body (list (list (quote p) (quote X))
+                       (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1)))}
+          "ff")
+        (list
+          {:lit (list (quote p) (quote X)) :adornment "f"}
+          {:lit (list (quote is) (quote Y)
+                      (list (string->symbol "+") (quote X) 1))
+           :adornment "fb"}))
+
+      ;; Magic predicate naming.
+      (dl-mt-test! "magic-rel-name"
+        (dl-magic-rel-name "ancestor" "bf")
+        "magic_ancestor^bf")
+
+      ;; Bound-args extraction.
+      (dl-mt-test! "bound-args bf"
+        (dl-bound-args (list (quote ancestor) (quote tom) (quote X)) "bf")
+        (list (quote tom)))
+
+      (dl-mt-test! "bound-args mixed"
+        (dl-bound-args (list (quote p) 1 (quote Y) 3) "bfb")
+        (list 1 3))
+
+      (dl-mt-test! "bound-args all-free"
+        (dl-bound-args (list (quote p) (quote X) (quote Y)) "ff")
+        (list))
+
+      ;; Magic literal construction.
+      (dl-mt-test! "magic-lit"
+        (dl-magic-lit "ancestor" "bf" (list (quote tom)))
+        (list (string->symbol "magic_ancestor^bf") (quote tom)))
+
+      ;; Magic-sets rewriter: structural sanity.
+      (dl-mt-test! "rewrite ancestor produces seed"
+        (let
+          ((rules
+             (list
+               {:head (list (quote ancestor) (quote X) (quote Y))
+                :body (list (list (quote parent) (quote X) (quote Y)))}
+               {:head (list (quote ancestor) (quote X) (quote Z))
+                :body
+                (list (list (quote parent) (quote X) (quote Y))
+                      (list (quote ancestor) (quote Y) (quote Z)))})))
+          (get
+            (dl-magic-rewrite rules "ancestor" "bf" (list (quote a)))
+            :seed))
+        (list (string->symbol "magic_ancestor^bf") (quote a)))
+
+      ;; Equivalence: rewritten program derives same ancestor tuples.
+      ;; In a chain a→b→c→d, magic-rewritten run still derives all
+      ;; ancestor pairs reachable from any node a/b/c/d propagated via
+      ;; magic_ancestor^bf — i.e. the full closure (6 tuples). Magic
+      ;; saves work only when the EDB has irrelevant nodes outside
+      ;; the seed's transitive cone.
+      (dl-mt-test! "magic-rewritten ancestor count"
+        (let
+          ((rules
+             (list
+               {:head (list (quote ancestor) (quote X) (quote Y))
+                :body (list (list (quote parent) (quote X) (quote Y)))}
+               {:head (list (quote ancestor) (quote X) (quote Z))
+                :body
+                (list (list (quote parent) (quote X) (quote Y))
+                      (list (quote ancestor) (quote Y) (quote Z)))}))
+            (edb (list
+                   (list (quote parent) (quote a) (quote b))
+                   (list (quote parent) (quote b) (quote c))
+                   (list (quote parent) (quote c) (quote d)))))
+          (let
+            ((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
+              (db (dl-make-db)))
+            (do
+              (for-each (fn (f) (dl-add-fact! db f)) edb)
+              (dl-add-fact! db (get rewritten :seed))
+              (for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
+              (dl-saturate! db)
+              (len (dl-relation db "ancestor")))))
+        6)
+
+      ;; dl-magic-query: end-to-end driver, doesn't mutate caller's db.
+      ;; Magic over a rule with negated body literal — propagation
+      ;; rules generated only for positive lits; negated lits pass
+      ;; through unchanged.
+      (dl-mt-test! "magic over rule with negation"
+        (let
+          ((db (dl-program
+                 "u(a). u(b). u(c). banned(b).
+                  active(X) :- u(X), not(banned(X)).")))
+          (let
+            ((semi (dl-query db (list (quote active) (quote X))))
+              (magic (dl-magic-query db (list (quote active) (quote X)))))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; All-bound query (existence check) generates an "bb"
+      ;; adornment chain. Verifies the rewriter walks multiple
+      ;; (rel, adn) pairs through the worklist.
+      (dl-mt-test! "magic existence check via bb"
+        (let
+          ((db (dl-program
+                 "parent(a, b). parent(b, c). parent(c, d).
+                  ancestor(X, Y) :- parent(X, Y).
+                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (let
+            ((found (dl-magic-query
+                      db (list (quote ancestor) (quote a) (quote c))))
+              (missing (dl-magic-query
+                         db (list (quote ancestor) (quote a) (quote z)))))
+            (and (= (len found) 1) (= (len missing) 0))))
+        true)
+
+      ;; Magic equivalence on the federation demo.
+      (dl-mt-test! "magic ≡ semi on foaf demo"
+        (let
+          ((db (dl-program-data
+                 (quote ((follows alice bob)
+                         (follows bob carol)
+                         (follows alice dave)))
+                 dl-demo-federation-rules)))
+          (let
+            ((semi (dl-query db (quote (foaf alice X))))
+              (magic (dl-magic-query db (quote (foaf alice X)))))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; Shape validation: dl-magic-query rejects non-list / non-
+      ;; dict goal shapes cleanly rather than crashing in `rest`.
+      (dl-mt-test! "magic rejects string goal"
+        (let ((threw false))
+          (do
+            (guard (e (#t (set! threw true)))
+              (dl-magic-query (dl-make-db) "foo"))
+            threw))
+        true)
+
+      (dl-mt-test! "magic rejects bare dict goal"
+        (let ((threw false))
+          (do
+            (guard (e (#t (set! threw true)))
+              (dl-magic-query (dl-make-db) {:foo "bar"}))
+            threw))
+        true)
+
+      ;; 3-stratum program under magic — distinct rule heads at
+      ;; strata 0/1/2 must all rewrite via the worklist.
+      (dl-mt-test! "magic 3-stratum program"
+        (let
+          ((db (dl-program
+                 "a(1). a(2). a(3). b(2).
+                  c(X) :- a(X), not(b(X)).
+                  d(X) :- c(X), not(banned(X)).
+                  banned(3).")))
+          (let
+            ((semi (dl-query db (list (quote d) (quote X))))
+              (magic (dl-magic-query db (list (quote d) (quote X)))))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; Aggregate -> derived -> threshold chain via magic.
+      (dl-mt-test! "magic aggregate-derived chain"
+        (let
+          ((db (dl-program
+                 "src(1). src(2). src(3).
+                  cnt(N) :- count(N, X, src(X)).
+                  active(N) :- cnt(N), >=(N, 2).")))
+          (let
+            ((semi (dl-query db (list (quote active) (quote N))))
+              (magic (dl-magic-query db (list (quote active) (quote N)))))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; Multi-relation rewrite chain: query r4 → propagate to r3,
+      ;; r2, r1, a. The worklist must process all of them; an
+      ;; earlier bug stopped after only the head pair.
+      (dl-mt-test! "magic chain through 4 rule levels"
+        (let
+          ((db (dl-program
+                 "a(1). a(2). r1(X) :- a(X). r2(X) :- r1(X).
+                  r3(X) :- r2(X). r4(X) :- r3(X).")))
+          (= 2 (len (dl-magic-query db (list (quote r4) (quote X))))))
+        true)
+
+      ;; Shortest-path demo via magic — exercises the rewriter
+      ;; against rules that mix recursive positive lits with an
+      ;; aggregate body literal.
+      (dl-mt-test! "magic on shortest-path demo"
+        (let
+          ((db (dl-program-data
+                 (quote ((edge a b 5) (edge b c 3) (edge a c 10)))
+                 dl-demo-shortest-path-rules)))
+          (let
+            ((semi (dl-query db (quote (shortest a c W))))
+              (magic (dl-magic-query db (quote (shortest a c W)))))
+            (and (= (len semi) (len magic))
+                 (= (len semi) 1))))
+        true)
+
+      ;; Same relation called with different adornment patterns
+      ;; in different rules. The worklist must enqueue and process
+      ;; each (rel, adornment) pair.
+      (dl-mt-test! "magic with multi-adornment same relation"
+        (let
+          ((db (dl-program
+                 "parent(p1, alice). parent(p2, bob).
+                  parent(g, p1). parent(g, p2).
+                  sibling(P1, P2) :- parent(G, P1), parent(G, P2),
+                                     !=(P1, P2).
+                  cousin(X, Y) :- parent(P1, X), parent(P2, Y),
+                                  sibling(P1, P2).")))
+          (let
+            ((semi (dl-query db (list (quote cousin) (quote alice) (quote Y))))
+              (magic (dl-magic-query db (list (quote cousin) (quote alice) (quote Y)))))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; Magic over a rule whose body contains an aggregate.
+      ;; The rewriter passes aggregate body lits through unchanged
+      ;; (no propagation generated for them), so semi-naive's count
+      ;; logic still fires correctly under the rewritten program.
+      (dl-mt-test! "magic over rule with aggregate body"
+        (let
+          ((db (dl-program
+                 "post(p1). post(p2). post(p3).
+                  liked(u1, p1). liked(u2, p1). liked(u3, p1).
+                  liked(u1, p2).
+                  rich(P) :- post(P), count(N, U, liked(U, P)),
+                             >=(N, 2).")))
+          (let
+            ((semi (dl-query db (list (quote rich) (quote P))))
+              (magic (dl-magic-query db (list (quote rich) (quote P)))))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; Mixed EDB + IDB: a relation can be both EDB-seeded and
+      ;; rule-derived. dl-magic-query must include the EDB portion
+      ;; even though the relation has rules.
+      (dl-mt-test! "magic mixed EDB+IDB"
+        (len
+          (dl-magic-query
+            (dl-program
+              "link(a, b). link(c, d). link(e, c).
+               via(a, e).
+               link(X, Y) :- via(X, M), link(M, Y).")
+            (list (quote link) (quote a) (quote X))))
+        2)
+
+      ;; dl-magic-query falls back to dl-query for built-in,
+      ;; aggregate, and negation goals (the magic seed would
+      ;; otherwise be non-ground).
+      (dl-mt-test! "magic-query falls back on aggregate"
+        (let
+          ((r (dl-magic-query
+                (dl-program "p(1). p(2). p(3).")
+                (list (quote count) (quote N) (quote X)
+                      (list (quote p) (quote X))))))
+          (and (= (len r) 1) (= (get (first r) "N") 3)))
+        true)
+
+      (dl-mt-test! "magic-query equivalent to dl-query"
+        (let
+          ((db (dl-program
+                 "parent(a, b). parent(b, c). parent(c, d).
+                  ancestor(X, Y) :- parent(X, Y).
+                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (let
+            ((semi (dl-query db (list (quote ancestor) (quote a) (quote X))))
+              (magic (dl-magic-query
+                       db (list (quote ancestor) (quote a) (quote X)))))
+            (= (len semi) (len magic))))
+        true)
+
+      ;; The magic rewriter passes aggregate body lits through
+      ;; unchanged, so an aggregate over an IDB relation would see an
+      ;; empty inner-goal in the magic db unless the IDB is already
+      ;; materialised. dl-magic-query now pre-saturates the source db
+      ;; to guarantee equivalence with dl-query for every stratified
+      ;; program. Previously this returned `({:N 0})` because `active`
+      ;; (IDB, derived through negation) was never derived in the
+      ;; magic db.
+      (dl-mt-test! "magic over aggregate-of-IDB matches vanilla"
+        (let
+          ((src
+             "u(a). u(b). u(c). u(d). banned(b). banned(d).
+              active(X) :- u(X), not(banned(X)).
+              n(N) :- count(N, X, active(X))."))
+          (let
+            ((vanilla (dl-eval src "?- n(N)."))
+              (magic (dl-eval-magic src "?- n(N).")))
+            (and (= (len vanilla) 1)
+                 (= (len magic) 1)
+                 (= (get (first vanilla) "N")
+                    (get (first magic) "N")))))
+        true)
+
+      ;; magic-query doesn't mutate caller db.
+      (dl-mt-test! "magic-query preserves caller db"
+        (let
+          ((db (dl-program
+                 "parent(a, b). parent(b, c).
+                  ancestor(X, Y) :- parent(X, Y).
+                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (let
+            ((rules-before (len (dl-rules db))))
+            (do
+              (dl-magic-query db (list (quote ancestor) (quote a) (quote X)))
+              (= rules-before (len (dl-rules db))))))
+        true)
+
+      ;; Magic-sets benefit: query touches only one cluster of a
+      ;; multi-component graph. Semi-naive derives the full closure
+      ;; over both clusters; magic only the seeded one.
+      ;; Magic-vs-semi work shape: chain of 12. Semi-naive
+      ;; derives the full closure (78 = 12·13/2). A magic query
+      ;; rooted at node 0 returns the 12 descendants only —
+      ;; demonstrating that magic limits derivation to the
+      ;; query's transitive cone.
+      (dl-mt-test! "magic vs semi work-shape on chain-12"
+        (let
+          ((source (str
+                     "parent(0, 1). parent(1, 2). parent(2, 3). "
+                     "parent(3, 4). parent(4, 5). parent(5, 6). "
+                     "parent(6, 7). parent(7, 8). parent(8, 9). "
+                     "parent(9, 10). parent(10, 11). parent(11, 12). "
+                     "ancestor(X, Y) :- parent(X, Y). "
+                     "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (let
+            ((db1 (dl-make-db)) (db2 (dl-make-db)))
+            (do
+              (dl-load-program! db1 source)
+              (dl-saturate! db1)
+              (dl-load-program! db2 source)
+              (let
+                ((semi-count (len (dl-relation db1 "ancestor")))
+                  (magic-count
+                    (len (dl-magic-query
+                           db2 (list (quote ancestor) 0 (quote X))))))
+                ;; Magic returns only descendants of 0 (12 of them).
+                (and (= semi-count 78) (= magic-count 12))))))
+        true)
+
+      ;; Magic + arithmetic: rules with `is` clauses pass through
+      ;; the rewriter unchanged (built-ins aren't propagated).
+      (dl-mt-test! "magic preserves arithmetic"
+        (let
+          ((source "n(1). n(2). n(3).
+                    doubled(X, Y) :- n(X), is(Y, *(X, 2))."))
+          (let
+            ((semi (dl-eval source "?- doubled(2, Y)."))
+              (magic (dl-eval-magic source "?- doubled(2, Y).")))
+            (= (len semi) (len magic))))
+        true)
+
+      (dl-mt-test! "magic skips irrelevant clusters"
+        (let
+          ;; Two disjoint chains. Query is rooted in cluster 1.
+          ((db (dl-program
+                 "parent(a, b). parent(b, c).
+                  parent(x, y). parent(y, z).
+                  ancestor(X, Y) :- parent(X, Y).
+                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (do
+            (dl-saturate! db)
+            (let
+              ((semi-count (len (dl-relation db "ancestor")))
+                (magic-results
+                  (dl-magic-query
+                    db (list (quote ancestor) (quote a) (quote X)))))
+              ;; Semi-naive derives 6 (3 in each cluster). Magic
+              ;; gives 3 query results (a's reachable: b, c).
+              (and (= semi-count 6) (= (len magic-results) 2)))))
+        true)
+
+      (dl-mt-test! "magic-rewritten finds same answers"
+        (let
+          ((rules
+             (list
+               {:head (list (quote ancestor) (quote X) (quote Y))
+                :body (list (list (quote parent) (quote X) (quote Y)))}
+               {:head (list (quote ancestor) (quote X) (quote Z))
+                :body
+                (list (list (quote parent) (quote X) (quote Y))
+                      (list (quote ancestor) (quote Y) (quote Z)))}))
+            (edb (list
+                   (list (quote parent) (quote a) (quote b))
+                   (list (quote parent) (quote b) (quote c)))))
+          (let
+            ((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
+              (db (dl-make-db)))
+            (do
+              (for-each (fn (f) (dl-add-fact! db f)) edb)
+              (dl-add-fact! db (get rewritten :seed))
+              (for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
+              (dl-saturate! db)
+              (len (dl-query db (list (quote ancestor) (quote a) (quote X)))))))
+        2))))
+
+(define
+  dl-magic-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-mt-pass 0)
+      (set! dl-mt-fail 0)
+      (set! dl-mt-failures (list))
+      (dl-mt-run-all!)
+      {:passed dl-mt-pass
+       :failed dl-mt-fail
+       :total (+ dl-mt-pass dl-mt-fail)
+       :failures dl-mt-failures})))

lib/datalog/tests/negation.sx

@@ -0,0 +1,252 @@
+;; lib/datalog/tests/negation.sx — stratified negation tests.
+
+(define dl-nt-pass 0)
+(define dl-nt-fail 0)
+(define dl-nt-failures (list))
+
+(define
+  dl-nt-deep=?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-nt-deq-l? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-nt-deq-d? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-nt-deq-l?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-nt-deep=? (nth a i) (nth b i))) false)
+      (else (dl-nt-deq-l? a b (+ i 1))))))
+
+(define
+  dl-nt-deq-d?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i)))
+         (not (dl-nt-deep=? (get a k) (get b k))))
+        false)
+      (else (dl-nt-deq-d? a b ka (+ i 1))))))
+
+(define
+  dl-nt-set=?
+  (fn
+    (a b)
+    (and
+      (= (len a) (len b))
+      (dl-nt-subset? a b)
+      (dl-nt-subset? b a))))
+
+(define
+  dl-nt-subset?
+  (fn
+    (xs ys)
+    (cond
+      ((= (len xs) 0) true)
+      ((not (dl-nt-contains? ys (first xs))) false)
+      (else (dl-nt-subset? (rest xs) ys)))))
+
+(define
+  dl-nt-contains?
+  (fn
+    (xs target)
+    (cond
+      ((= (len xs) 0) false)
+      ((dl-nt-deep=? (first xs) target) true)
+      (else (dl-nt-contains? (rest xs) target)))))
+
+(define
+  dl-nt-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-nt-deep=? got expected)
+      (set! dl-nt-pass (+ dl-nt-pass 1))
+      (do
+        (set! dl-nt-fail (+ dl-nt-fail 1))
+        (append!
+          dl-nt-failures
+          (str
+            name
+            "\n    expected: " expected
+            "\n    got:      " got))))))
+
+(define
+  dl-nt-test-set!
+  (fn
+    (name got expected)
+    (if
+      (dl-nt-set=? got expected)
+      (set! dl-nt-pass (+ dl-nt-pass 1))
+      (do
+        (set! dl-nt-fail (+ dl-nt-fail 1))
+        (append!
+          dl-nt-failures
+          (str
+            name
+            "\n    expected (set): " expected
+            "\n    got:            " got))))))
+
+(define
+  dl-nt-throws?
+  (fn
+    (thunk)
+    (let
+      ((threw false))
+      (do
+        (guard
+          (e (#t (set! threw true)))
+          (thunk))
+        threw))))
+
+(define
+  dl-nt-run-all!
+  (fn
+    ()
+    (do
+      ;; Negation against EDB-only relation.
+      (dl-nt-test-set! "not against EDB"
+        (dl-query
+          (dl-program
+            "p(1). p(2). p(3). r(2).
+             q(X) :- p(X), not(r(X)).")
+          (list (quote q) (quote X)))
+        (list {:X 1} {:X 3}))
+
+      ;; Negation against derived relation — needs stratification.
+      (dl-nt-test-set! "not against derived rel"
+        (dl-query
+          (dl-program
+            "p(1). p(2). p(3). s(2).
+             r(X) :- s(X).
+             q(X) :- p(X), not(r(X)).")
+          (list (quote q) (quote X)))
+        (list {:X 1} {:X 3}))
+
+      ;; Two-step strata: r derives via s; q derives via not r.
+      (dl-nt-test-set! "two-step strata"
+        (dl-query
+          (dl-program
+            "node(a). node(b). node(c). node(d).
+             edge(a, b). edge(b, c). edge(c, a).
+             reach(X, Y) :- edge(X, Y).
+             reach(X, Z) :- edge(X, Y), reach(Y, Z).
+             unreachable(X) :- node(X), not(reach(a, X)).")
+          (list (quote unreachable) (quote X)))
+        (list {:X (quote d)}))
+
+      ;; Combine negation with arithmetic and comparison.
+      (dl-nt-test-set! "negation with arithmetic"
+        (dl-query
+          (dl-program
+            "n(1). n(2). n(3). n(4). n(5). odd(1). odd(3). odd(5).
+             even(X) :- n(X), not(odd(X)).")
+          (list (quote even) (quote X)))
+        (list {:X 2} {:X 4}))
+
+      ;; Empty negation result.
+      (dl-nt-test-set! "negation always succeeds"
+        (dl-query
+          (dl-program
+            "p(1). p(2). q(X) :- p(X), not(r(X)).")
+          (list (quote q) (quote X)))
+        (list {:X 1} {:X 2}))
+
+      ;; Negation always fails.
+      (dl-nt-test-set! "negation always fails"
+        (dl-query
+          (dl-program
+            "p(1). p(2). r(1). r(2). q(X) :- p(X), not(r(X)).")
+          (list (quote q) (quote X)))
+        (list))
+
+      ;; Anonymous `_` in a negated literal is existentially quantified
+      ;; — it doesn't need to be bound by an earlier body lit. Without
+      ;; this exemption the safety check would reject the common idiom
+      ;; `orphan(X) :- person(X), not(parent(X, _))`.
+      (dl-nt-test-set! "negation with anonymous var — orphan idiom"
+        (dl-query
+          (dl-program
+            "person(a). person(b). person(c). parent(a, b).
+             orphan(X) :- person(X), not(parent(X, _)).")
+          (list (quote orphan) (quote X)))
+        (list {:X (quote b)} {:X (quote c)}))
+
+      ;; Multiple anonymous vars are each independently existential.
+      (dl-nt-test-set! "negation with multiple anonymous vars"
+        (dl-query
+          (dl-program
+            "u(a). u(b). u(c). edge(a, x). edge(b, y).
+             solo(X) :- u(X), not(edge(X, _)).")
+          (list (quote solo) (quote X)))
+        (list {:X (quote c)}))
+
+      ;; Stratifiability checks.
+      (dl-nt-test! "non-stratifiable rejected"
+        (dl-nt-throws?
+          (fn ()
+            (let ((db (dl-make-db)))
+              (do
+                (dl-add-rule!
+                  db
+                  {:head (list (quote p) (quote X))
+                   :body (list (list (quote q) (quote X))
+                               {:neg (list (quote r) (quote X))})})
+                (dl-add-rule!
+                  db
+                  {:head (list (quote r) (quote X))
+                   :body (list (list (quote p) (quote X)))})
+                (dl-add-fact! db (list (quote q) 1))
+                (dl-saturate! db)))))
+        true)
+
+      (dl-nt-test! "stratifiable accepted"
+        (dl-nt-throws?
+          (fn ()
+            (dl-program
+              "p(1). p(2). r(2).
+               q(X) :- p(X), not(r(X)).")))
+        false)
+
+      ;; Multi-stratum chain.
+      (dl-nt-test-set! "three-level strata"
+        (dl-query
+          (dl-program
+            "a(1). a(2). a(3). a(4).
+             b(X) :- a(X), not(c(X)).
+             c(X) :- d(X).
+             d(2).
+             d(4).")
+          (list (quote b) (quote X)))
+        (list {:X 1} {:X 3}))
+
+      ;; Safety violation: negation refers to unbound var.
+      (dl-nt-test! "negation safety violation"
+        (dl-nt-throws?
+          (fn ()
+            (dl-program
+              "p(1). q(X) :- p(X), not(r(Y)).")))
+        true))))
+
+(define
+  dl-negation-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-nt-pass 0)
+      (set! dl-nt-fail 0)
+      (set! dl-nt-failures (list))
+      (dl-nt-run-all!)
+      {:passed dl-nt-pass
+       :failed dl-nt-fail
+       :total (+ dl-nt-pass dl-nt-fail)
+       :failures dl-nt-failures})))

lib/datalog/tests/parse.sx

@@ -0,0 +1,179 @@
+;; lib/datalog/tests/parse.sx — parser unit tests
+;;
+;; Run via: bash lib/datalog/conformance.sh
+;; Or:      (load "lib/datalog/tokenizer.sx") (load "lib/datalog/parser.sx")
+;;          (load "lib/datalog/tests/parse.sx") (dl-parse-tests-run!)
+
+(define dl-pt-pass 0)
+(define dl-pt-fail 0)
+(define dl-pt-failures (list))
+
+;; Order-independent structural equality. Lists compared positionally,
+;; dicts as sets of (key, value) pairs. Numbers via = (so 30.0 = 30).
+(define
+  dl-deep-equal?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-deep-equal-list? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let
+          ((ka (keys a)) (kb (keys b)))
+          (and
+            (= (len ka) (len kb))
+            (dl-deep-equal-dict? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-deep-equal-list?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-deep-equal? (nth a i) (nth b i))) false)
+      (else (dl-deep-equal-list? a b (+ i 1))))))
+
+(define
+  dl-deep-equal-dict?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i))) (not (dl-deep-equal? (get a k) (get b k))))
+        false)
+      (else (dl-deep-equal-dict? a b ka (+ i 1))))))
+
+(define
+  dl-pt-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-deep-equal? got expected)
+      (set! dl-pt-pass (+ dl-pt-pass 1))
+      (do
+        (set! dl-pt-fail (+ dl-pt-fail 1))
+        (append!
+          dl-pt-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define
+  dl-pt-throws?
+  (fn
+    (thunk)
+    (let
+      ((threw false))
+      (do (guard (e (#t (set! threw true))) (thunk)) threw))))
+
+(define
+  dl-pt-run-all!
+  (fn
+    ()
+    (do
+      (dl-pt-test! "empty program" (dl-parse "") (list))
+      (dl-pt-test! "fact" (dl-parse "parent(tom, bob).") (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))}))
+      (dl-pt-test!
+        "two facts"
+        (dl-parse "parent(tom, bob). parent(bob, ann).")
+        (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))} {:body (list) :head (list (quote parent) (quote bob) (quote ann))}))
+      (dl-pt-test! "zero-ary fact" (dl-parse "ready.") (list {:body (list) :head (list (quote ready))}))
+      (dl-pt-test!
+        "rule one body lit"
+        (dl-parse "ancestor(X, Y) :- parent(X, Y).")
+        (list {:body (list (list (quote parent) (quote X) (quote Y))) :head (list (quote ancestor) (quote X) (quote Y))}))
+      (dl-pt-test!
+        "recursive rule"
+        (dl-parse "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
+        (list {:body (list (list (quote parent) (quote X) (quote Y)) (list (quote ancestor) (quote Y) (quote Z))) :head (list (quote ancestor) (quote X) (quote Z))}))
+      (dl-pt-test!
+        "query single"
+        (dl-parse "?- ancestor(tom, X).")
+        (list {:query (list (list (quote ancestor) (quote tom) (quote X)))}))
+      (dl-pt-test!
+        "query multi"
+        (dl-parse "?- p(X), q(X).")
+        (list {:query (list (list (quote p) (quote X)) (list (quote q) (quote X)))}))
+      (dl-pt-test!
+        "negation"
+        (dl-parse "safe(X) :- person(X), not(parent(X, _)).")
+        (list {:body (list (list (quote person) (quote X)) {:neg (list (quote parent) (quote X) (quote _))}) :head (list (quote safe) (quote X))}))
+      (dl-pt-test!
+        "number arg"
+        (dl-parse "age(alice, 30).")
+        (list {:body (list) :head (list (quote age) (quote alice) 30)}))
+      (dl-pt-test!
+        "string arg"
+        (dl-parse "label(x, \"hi\").")
+        (list {:body (list) :head (list (quote label) (quote x) "hi")}))
+      ;; Quoted 'atoms' parse as strings — a uppercase-starting name
+      ;; in quotes used to misclassify as a variable and reject the
+      ;; fact as non-ground.
+      (dl-pt-test!
+        "quoted atom arg parses as string"
+        (dl-parse "p('Hello World').")
+        (list {:body (list) :head (list (quote p) "Hello World")}))
+      (dl-pt-test!
+        "comparison literal"
+        (dl-parse "p(X) :- <(X, 5).")
+        (list {:body (list (list (string->symbol "<") (quote X) 5)) :head (list (quote p) (quote X))}))
+      (dl-pt-test!
+        "is with arith"
+        (dl-parse "succ(X, Y) :- nat(X), is(Y, +(X, 1)).")
+        (list {:body (list (list (quote nat) (quote X)) (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1))) :head (list (quote succ) (quote X) (quote Y))}))
+      (dl-pt-test!
+        "mixed program"
+        (dl-parse "p(a). p(b). q(X) :- p(X). ?- q(Y).")
+        (list {:body (list) :head (list (quote p) (quote a))} {:body (list) :head (list (quote p) (quote b))} {:body (list (list (quote p) (quote X))) :head (list (quote q) (quote X))} {:query (list (list (quote q) (quote Y)))}))
+      (dl-pt-test!
+        "comments skipped"
+        (dl-parse "% comment\nfoo(a).\n/* block */ bar(b).")
+        (list {:body (list) :head (list (quote foo) (quote a))} {:body (list) :head (list (quote bar) (quote b))}))
+      (dl-pt-test!
+        "underscore var"
+        (dl-parse "p(X) :- q(X, _).")
+        (list {:body (list (list (quote q) (quote X) (quote _))) :head (list (quote p) (quote X))}))
+      ;; Negative number literals parse as one negative number,
+      ;; while subtraction (`-(X, Y)`) compound is preserved.
+      (dl-pt-test!
+        "negative integer literal"
+        (dl-parse "n(-3).")
+        (list {:head (list (quote n) -3) :body (list)}))
+
+      (dl-pt-test!
+        "subtraction compound preserved"
+        (dl-parse "r(X) :- is(X, -(10, 3)).")
+        (list
+          {:head (list (quote r) (quote X))
+           :body (list (list (quote is) (quote X)
+                             (list (string->symbol "-") 10 3)))}))
+
+      (dl-pt-test!
+        "number as relation name raises"
+        (dl-pt-throws? (fn () (dl-parse "1(X) :- p(X).")))
+        true)
+
+      (dl-pt-test!
+        "var as relation name raises"
+        (dl-pt-throws? (fn () (dl-parse "P(X).")))
+        true)
+
+      (dl-pt-test!
+        "missing dot raises"
+        (dl-pt-throws? (fn () (dl-parse "p(a)")))
+        true)
+      (dl-pt-test!
+        "trailing comma raises"
+        (dl-pt-throws? (fn () (dl-parse "p(a,).")))
+        true))))
+
+(define
+  dl-parse-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-pt-pass 0)
+      (set! dl-pt-fail 0)
+      (set! dl-pt-failures (list))
+      (dl-pt-run-all!)
+      {:failures dl-pt-failures :total (+ dl-pt-pass dl-pt-fail) :passed dl-pt-pass :failed dl-pt-fail})))

lib/datalog/tests/semi_naive.sx

@@ -0,0 +1,153 @@
+;; lib/datalog/tests/semi_naive.sx — semi-naive correctness vs naive.
+;;
+;; Strategy: differential — run both saturators on each program and
+;; compare the resulting per-relation tuple counts. Counting (not
+;; element-wise set equality) keeps the suite fast under the bundled
+;; conformance session; correctness on the inhabitants is covered by
+;; eval.sx and builtins.sx (which use dl-saturate! by default — the
+;; semi-naive saturator).
+
+(define dl-sn-pass 0)
+(define dl-sn-fail 0)
+(define dl-sn-failures (list))
+
+(define
+  dl-sn-test!
+  (fn
+    (name got expected)
+    (if
+      (equal? got expected)
+      (set! dl-sn-pass (+ dl-sn-pass 1))
+      (do
+        (set! dl-sn-fail (+ dl-sn-fail 1))
+        (append!
+          dl-sn-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; Load `source` into both a semi-naive and a naive db and return a
+;; list of (rel-name semi-count naive-count) triples. Both sets must
+;; have the same union of relation names.
+(define
+  dl-sn-counts
+  (fn
+    (source)
+    (let
+      ((db-s (dl-program source)) (db-n (dl-program source)))
+      (do
+        (dl-saturate! db-s)
+        (dl-saturate-naive! db-n)
+        (let
+          ((out (list)))
+          (do
+            (for-each
+              (fn
+                (k)
+                (append!
+                  out
+                  (list
+                    k
+                    (len (dl-relation db-s k))
+                    (len (dl-relation db-n k)))))
+              (keys (get db-s :facts)))
+            out))))))
+
+(define
+  dl-sn-counts-agree?
+  (fn
+    (counts)
+    (cond
+      ((= (len counts) 0) true)
+      (else
+        (let
+          ((row (first counts)))
+          (and
+            (= (nth row 1) (nth row 2))
+            (dl-sn-counts-agree? (rest counts))))))))
+
+(define
+  dl-sn-chain-source
+  (fn
+    (n)
+    (let
+      ((parts (list "")))
+      (do
+        (define
+          dl-sn-loop
+          (fn
+            (i)
+            (when
+              (< i n)
+              (do
+                (append! parts (str "parent(" i ", " (+ i 1) "). "))
+                (dl-sn-loop (+ i 1))))))
+        (dl-sn-loop 0)
+        (str
+          (join "" parts)
+          "ancestor(X, Y) :- parent(X, Y). "
+          "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))))
+
+(define
+  dl-sn-run-all!
+  (fn
+    ()
+    (do
+      (dl-sn-test!
+        "ancestor closure counts match"
+        (dl-sn-counts-agree?
+          (dl-sn-counts
+            "parent(a, b). parent(b, c). parent(c, d).\n             ancestor(X, Y) :- parent(X, Y).\n             ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
+        true)
+      (dl-sn-test!
+        "cyclic reach counts match"
+        (dl-sn-counts-agree?
+          (dl-sn-counts
+            "edge(1, 2). edge(2, 3). edge(3, 1). edge(3, 4).\n             reach(X, Y) :- edge(X, Y).\n             reach(X, Z) :- edge(X, Y), reach(Y, Z)."))
+        true)
+      (dl-sn-test!
+        "same-gen counts match"
+        (dl-sn-counts-agree?
+          (dl-sn-counts
+            "parent(a, b). parent(a, c). parent(b, d). parent(c, e).\n             person(a). person(b). person(c). person(d). person(e).\n             sg(X, X) :- person(X).\n             sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y)."))
+        true)
+      (dl-sn-test!
+        "rules with builtins counts match"
+        (dl-sn-counts-agree?
+          (dl-sn-counts
+            "n(1). n(2). n(3). n(4). n(5).\n             small(X) :- n(X), <(X, 5).\n             succ(X, Y) :- n(X), <(X, 5), is(Y, +(X, 1))."))
+        true)
+      (dl-sn-test!
+        "static rule fires under semi-naive"
+        (dl-sn-counts-agree?
+          (dl-sn-counts "p(a). p(b). q(X) :- p(X), =(X, a)."))
+        true)
+      ;; Chain length 12 — multiple semi-naive iterations against
+      ;; the recursive ancestor rule (differential vs naive).
+      (dl-sn-test!
+        "chain-12 ancestor counts match"
+        (dl-sn-counts-agree? (dl-sn-counts (dl-sn-chain-source 12)))
+        true)
+      ;; Chain length 25 — semi-naive only — first-arg index makes
+      ;; this tractable in conformance budget.
+      (dl-sn-test!
+        "chain-25 ancestor count value (semi only)"
+        (let
+          ((db (dl-program (dl-sn-chain-source 25))))
+          (do (dl-saturate! db) (len (dl-relation db "ancestor"))))
+        325)
+      (dl-sn-test!
+        "query through semi saturate"
+        (let
+          ((db (dl-program "parent(a, b). parent(b, c).\n                  ancestor(X, Y) :- parent(X, Y).\n                  ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
+          (len (dl-query db (list (quote ancestor) (quote a) (quote X)))))
+        2))))
+
+(define
+  dl-semi-naive-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-sn-pass 0)
+      (set! dl-sn-fail 0)
+      (set! dl-sn-failures (list))
+      (dl-sn-run-all!)
+      {:failures dl-sn-failures :total (+ dl-sn-pass dl-sn-fail) :passed dl-sn-pass :failed dl-sn-fail})))

lib/datalog/tests/tokenize.sx

@@ -0,0 +1,189 @@
+;; lib/datalog/tests/tokenize.sx — tokenizer unit tests
+;;
+;; Run via: bash lib/datalog/conformance.sh
+;; Or:      (load "lib/datalog/tokenizer.sx") (load "lib/datalog/tests/tokenize.sx")
+;;          (dl-tokenize-tests-run!)
+
+(define dl-tk-pass 0)
+(define dl-tk-fail 0)
+(define dl-tk-failures (list))
+
+(define
+  dl-tk-test!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! dl-tk-pass (+ dl-tk-pass 1))
+      (do
+        (set! dl-tk-fail (+ dl-tk-fail 1))
+        (append!
+          dl-tk-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define dl-tk-types (fn (toks) (map (fn (t) (get t :type)) toks)))
+(define dl-tk-values (fn (toks) (map (fn (t) (get t :value)) toks)))
+
+(define
+  dl-tk-run-all!
+  (fn
+    ()
+    (do
+      (dl-tk-test! "empty" (dl-tk-types (dl-tokenize "")) (list "eof"))
+      (dl-tk-test!
+        "atom dot"
+        (dl-tk-types (dl-tokenize "foo."))
+        (list "atom" "punct" "eof"))
+      (dl-tk-test!
+        "atom dot value"
+        (dl-tk-values (dl-tokenize "foo."))
+        (list "foo" "." nil))
+      (dl-tk-test!
+        "var"
+        (dl-tk-types (dl-tokenize "X."))
+        (list "var" "punct" "eof"))
+      (dl-tk-test!
+        "underscore var"
+        (dl-tk-types (dl-tokenize "_x."))
+        (list "var" "punct" "eof"))
+      (dl-tk-test!
+        "integer"
+        (dl-tk-values (dl-tokenize "42"))
+        (list 42 nil))
+      (dl-tk-test!
+        "decimal"
+        (dl-tk-values (dl-tokenize "3.14"))
+        (list 3.14 nil))
+      (dl-tk-test!
+        "string"
+        (dl-tk-values (dl-tokenize "\"hello\""))
+        (list "hello" nil))
+      ;; Quoted 'atoms' tokenize as strings — see the type-table
+      ;; comment in lib/datalog/tokenizer.sx for the rationale.
+      (dl-tk-test!
+        "quoted atom as string"
+        (dl-tk-types (dl-tokenize "'two words'"))
+        (list "string" "eof"))
+      (dl-tk-test!
+        "quoted atom value"
+        (dl-tk-values (dl-tokenize "'two words'"))
+        (list "two words" nil))
+      ;; A quoted atom whose name would otherwise be a variable
+      ;; (uppercase / leading underscore) is now safely a string —
+      ;; this was the bug that motivated the type change.
+      (dl-tk-test!
+        "quoted Uppercase as string"
+        (dl-tk-types (dl-tokenize "'Hello'"))
+        (list "string" "eof"))
+      (dl-tk-test! ":-" (dl-tk-values (dl-tokenize ":-")) (list ":-" nil))
+      (dl-tk-test! "?-" (dl-tk-values (dl-tokenize "?-")) (list "?-" nil))
+      (dl-tk-test! "<=" (dl-tk-values (dl-tokenize "<=")) (list "<=" nil))
+      (dl-tk-test! ">=" (dl-tk-values (dl-tokenize ">=")) (list ">=" nil))
+      (dl-tk-test! "!=" (dl-tk-values (dl-tokenize "!=")) (list "!=" nil))
+      (dl-tk-test!
+        "single op values"
+        (dl-tk-values (dl-tokenize "< > = + - * /"))
+        (list "<" ">" "=" "+" "-" "*" "/" nil))
+      (dl-tk-test!
+        "single op types"
+        (dl-tk-types (dl-tokenize "< > = + - * /"))
+        (list "op" "op" "op" "op" "op" "op" "op" "eof"))
+      (dl-tk-test!
+        "punct"
+        (dl-tk-values (dl-tokenize "( ) , ."))
+        (list "(" ")" "," "." nil))
+      (dl-tk-test!
+        "fact tokens"
+        (dl-tk-types (dl-tokenize "parent(tom, bob)."))
+        (list "atom" "punct" "atom" "punct" "atom" "punct" "punct" "eof"))
+      (dl-tk-test!
+        "rule shape"
+        (dl-tk-types (dl-tokenize "p(X) :- q(X)."))
+        (list
+          "atom"
+          "punct"
+          "var"
+          "punct"
+          "op"
+          "atom"
+          "punct"
+          "var"
+          "punct"
+          "punct"
+          "eof"))
+      (dl-tk-test!
+        "comparison literal"
+        (dl-tk-values (dl-tokenize "<(X, 5)"))
+        (list "<" "(" "X" "," 5 ")" nil))
+      (dl-tk-test!
+        "is form"
+        (dl-tk-values (dl-tokenize "is(Y, +(X, 1))"))
+        (list "is" "(" "Y" "," "+" "(" "X" "," 1 ")" ")" nil))
+      (dl-tk-test!
+        "line comment"
+        (dl-tk-types (dl-tokenize "% comment line\nfoo."))
+        (list "atom" "punct" "eof"))
+      (dl-tk-test!
+        "block comment"
+        (dl-tk-types (dl-tokenize "/* a\nb */ x."))
+        (list "atom" "punct" "eof"))
+      ;; Unexpected characters surface at tokenize time rather
+      ;; than being silently consumed (previously `?(X)` parsed as
+      ;; if the leading `?` weren't there).
+      (dl-tk-test!
+        "unexpected char raises"
+        (let ((threw false))
+          (do
+            (guard (e (#t (set! threw true)))
+              (dl-tokenize "?(X)"))
+            threw))
+        true)
+
+      ;; Unterminated string / quoted-atom must raise.
+      (dl-tk-test!
+        "unterminated string raises"
+        (let ((threw false))
+          (do
+            (guard (e (#t (set! threw true)))
+              (dl-tokenize "\"unclosed"))
+            threw))
+        true)
+
+      (dl-tk-test!
+        "unterminated quoted atom raises"
+        (let ((threw false))
+          (do
+            (guard (e (#t (set! threw true)))
+              (dl-tokenize "'unclosed"))
+            threw))
+        true)
+
+      ;; Unterminated block comment must raise — previously it was
+      ;; silently consumed to EOF.
+      (dl-tk-test!
+        "unterminated block comment raises"
+        (let ((threw false))
+          (do
+            (guard (e (#t (set! threw true)))
+              (dl-tokenize "/* unclosed comment"))
+            threw))
+        true)
+      (dl-tk-test!
+        "whitespace"
+        (dl-tk-types (dl-tokenize "  foo  ,\t bar  ."))
+        (list "atom" "punct" "atom" "punct" "eof"))
+      (dl-tk-test!
+        "positions"
+        (map (fn (t) (get t :pos)) (dl-tokenize "foo bar"))
+        (list 0 4 7)))))
+
+(define
+  dl-tokenize-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-tk-pass 0)
+      (set! dl-tk-fail 0)
+      (set! dl-tk-failures (list))
+      (dl-tk-run-all!)
+      {:failures dl-tk-failures :total (+ dl-tk-pass dl-tk-fail) :passed dl-tk-pass :failed dl-tk-fail})))

lib/datalog/tests/unify.sx

@@ -0,0 +1,194 @@
+;; lib/datalog/tests/unify.sx — unification + substitution tests.
+
+(define dl-ut-pass 0)
+(define dl-ut-fail 0)
+(define dl-ut-failures (list))
+
+(define
+  dl-ut-deep-equal?
+  (fn
+    (a b)
+    (cond
+      ((and (list? a) (list? b))
+        (and (= (len a) (len b)) (dl-ut-deq-list? a b 0)))
+      ((and (dict? a) (dict? b))
+        (let
+          ((ka (keys a)) (kb (keys b)))
+          (and (= (len ka) (len kb)) (dl-ut-deq-dict? a b ka 0))))
+      ((and (number? a) (number? b)) (= a b))
+      (else (equal? a b)))))
+
+(define
+  dl-ut-deq-list?
+  (fn
+    (a b i)
+    (cond
+      ((>= i (len a)) true)
+      ((not (dl-ut-deep-equal? (nth a i) (nth b i))) false)
+      (else (dl-ut-deq-list? a b (+ i 1))))))
+
+(define
+  dl-ut-deq-dict?
+  (fn
+    (a b ka i)
+    (cond
+      ((>= i (len ka)) true)
+      ((let ((k (nth ka i))) (not (dl-ut-deep-equal? (get a k) (get b k))))
+        false)
+      (else (dl-ut-deq-dict? a b ka (+ i 1))))))
+
+(define
+  dl-ut-test!
+  (fn
+    (name got expected)
+    (if
+      (dl-ut-deep-equal? got expected)
+      (set! dl-ut-pass (+ dl-ut-pass 1))
+      (do
+        (set! dl-ut-fail (+ dl-ut-fail 1))
+        (append!
+          dl-ut-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+(define
+  dl-ut-run-all!
+  (fn
+    ()
+    (do
+      (dl-ut-test! "var? uppercase" (dl-var? (quote X)) true)
+      (dl-ut-test! "var? underscore" (dl-var? (quote _foo)) true)
+      (dl-ut-test! "var? lowercase" (dl-var? (quote tom)) false)
+      (dl-ut-test! "var? number" (dl-var? 5) false)
+      (dl-ut-test! "var? string" (dl-var? "hi") false)
+      (dl-ut-test! "var? list" (dl-var? (list 1)) false)
+      (dl-ut-test!
+        "atom-atom match"
+        (dl-unify (quote tom) (quote tom) (dl-empty-subst))
+        {})
+      (dl-ut-test!
+        "atom-atom fail"
+        (dl-unify (quote tom) (quote bob) (dl-empty-subst))
+        nil)
+      (dl-ut-test!
+        "num-num match"
+        (dl-unify 5 5 (dl-empty-subst))
+        {})
+      (dl-ut-test!
+        "num-num fail"
+        (dl-unify 5 6 (dl-empty-subst))
+        nil)
+      (dl-ut-test!
+        "string match"
+        (dl-unify "hi" "hi" (dl-empty-subst))
+        {})
+      (dl-ut-test! "string fail" (dl-unify "hi" "bye" (dl-empty-subst)) nil)
+      (dl-ut-test!
+        "var-atom binds"
+        (dl-unify (quote X) (quote tom) (dl-empty-subst))
+        {:X (quote tom)})
+      (dl-ut-test!
+        "atom-var binds"
+        (dl-unify (quote tom) (quote X) (dl-empty-subst))
+        {:X (quote tom)})
+      (dl-ut-test!
+        "var-var same"
+        (dl-unify (quote X) (quote X) (dl-empty-subst))
+        {})
+      (dl-ut-test!
+        "var-var bind"
+        (let
+          ((s (dl-unify (quote X) (quote Y) (dl-empty-subst))))
+          (dl-walk (quote X) s))
+        (quote Y))
+      (dl-ut-test!
+        "tuple match"
+        (dl-unify
+          (list (quote parent) (quote X) (quote bob))
+          (list (quote parent) (quote tom) (quote Y))
+          (dl-empty-subst))
+        {:X (quote tom) :Y (quote bob)})
+      (dl-ut-test!
+        "tuple arity mismatch"
+        (dl-unify
+          (list (quote p) (quote X))
+          (list (quote p) (quote a) (quote b))
+          (dl-empty-subst))
+        nil)
+      (dl-ut-test!
+        "tuple head mismatch"
+        (dl-unify
+          (list (quote p) (quote X))
+          (list (quote q) (quote X))
+          (dl-empty-subst))
+        nil)
+      (dl-ut-test!
+        "walk chain"
+        (let
+          ((s1 (dl-unify (quote X) (quote Y) (dl-empty-subst))))
+          (let
+            ((s2 (dl-unify (quote Y) (quote tom) s1)))
+            (dl-walk (quote X) s2)))
+        (quote tom))
+
+      ;; Walk with circular substitution must not infinite-loop.
+      ;; Cycles return the current term unchanged.
+      (dl-ut-test!
+        "walk circular subst no hang"
+        (let ((s (dl-bind (quote B) (quote A)
+                   (dl-bind (quote A) (quote B) (dl-empty-subst)))))
+          (dl-walk (quote A) s))
+        (quote A))
+      (dl-ut-test!
+        "apply subst on tuple"
+        (let
+          ((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
+          (dl-apply-subst (list (quote parent) (quote X) (quote Y)) s))
+        (list (quote parent) (quote tom) (quote Y)))
+      (dl-ut-test!
+        "ground? all const"
+        (dl-ground?
+          (list (quote p) (quote tom) 5)
+          (dl-empty-subst))
+        true)
+      (dl-ut-test!
+        "ground? unbound var"
+        (dl-ground? (list (quote p) (quote X)) (dl-empty-subst))
+        false)
+      (dl-ut-test!
+        "ground? bound var"
+        (let
+          ((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
+          (dl-ground? (list (quote p) (quote X)) s))
+        true)
+      (dl-ut-test!
+        "ground? bare var"
+        (dl-ground? (quote X) (dl-empty-subst))
+        false)
+      (dl-ut-test!
+        "vars-of basic"
+        (dl-vars-of
+          (list (quote p) (quote X) (quote tom) (quote Y) (quote X)))
+        (list "X" "Y"))
+      (dl-ut-test!
+        "vars-of ground"
+        (dl-vars-of (list (quote p) (quote tom) (quote bob)))
+        (list))
+      (dl-ut-test!
+        "vars-of nested compound"
+        (dl-vars-of
+          (list
+            (quote is)
+            (quote Z)
+            (list (string->symbol "+") (quote X) 1)))
+        (list "Z" "X")))))
+
+(define
+  dl-unify-tests-run!
+  (fn
+    ()
+    (do
+      (set! dl-ut-pass 0)
+      (set! dl-ut-fail 0)
+      (set! dl-ut-failures (list))
+      (dl-ut-run-all!)
+      {:failures dl-ut-failures :total (+ dl-ut-pass dl-ut-fail) :passed dl-ut-pass :failed dl-ut-fail})))

lib/datalog/tokenizer.sx

@@ -0,0 +1,269 @@
+;; lib/datalog/tokenizer.sx — Datalog source → token stream
+;;
+;; Tokens: {:type T :value V :pos P}
+;; Types:
+;;   "atom"    — lowercase-start bare identifier
+;;   "var"     — uppercase-start or _-start ident (value is the name)
+;;   "number"  — numeric literal (decoded to number)
+;;   "string"  — "..." string literal OR quoted 'atom' (treated as a
+;;               string value to avoid the var-vs-atom ambiguity that
+;;               would arise from a quoted atom whose name starts with
+;;               an uppercase letter or underscore)
+;;   "punct"   — ( ) , .
+;;   "op"      — :- ?- <= >= != < > = + - * /
+;;   "eof"
+;;
+;; Datalog has no function symbols in arg position; the parser still
+;; accepts nested compounds for arithmetic ((is X (+ A B))) but safety
+;; analysis rejects non-arithmetic nesting at rule-load time.
+
+(define dl-make-token (fn (type value pos) {:type type :value value :pos pos}))
+
+(define dl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
+(define dl-lower? (fn (c) (and (>= c "a") (<= c "z"))))
+(define dl-upper? (fn (c) (and (>= c "A") (<= c "Z"))))
+
+(define
+  dl-ident-char?
+  (fn (c) (or (dl-lower? c) (dl-upper? c) (dl-digit? c) (= c "_"))))
+
+(define dl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
+
+(define
+  dl-tokenize
+  (fn
+    (src)
+    (let
+      ((tokens (list)) (pos 0) (src-len (len src)))
+      (define
+        dl-peek
+        (fn
+          (offset)
+          (if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
+      (define cur (fn () (dl-peek 0)))
+      (define advance! (fn (n) (set! pos (+ pos n))))
+      (define
+        at?
+        (fn
+          (s)
+          (let
+            ((sl (len s)))
+            (and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
+      (define
+        dl-emit!
+        (fn
+          (type value start)
+          (append! tokens (dl-make-token type value start))))
+      (define
+        skip-line-comment!
+        (fn
+          ()
+          (when
+            (and (< pos src-len) (not (= (cur) "\n")))
+            (do (advance! 1) (skip-line-comment!)))))
+      (define
+        skip-block-comment!
+        (fn
+          ()
+          (cond
+            ((>= pos src-len)
+              (error (str "Tokenizer: unterminated block comment "
+                          "(started at position " pos ")")))
+            ((and (= (cur) "*") (< (+ pos 1) src-len) (= (dl-peek 1) "/"))
+              (advance! 2))
+            (else (do (advance! 1) (skip-block-comment!))))))
+      (define
+        skip-ws!
+        (fn
+          ()
+          (cond
+            ((>= pos src-len) nil)
+            ((dl-ws? (cur)) (do (advance! 1) (skip-ws!)))
+            ((= (cur) "%")
+              (do (advance! 1) (skip-line-comment!) (skip-ws!)))
+            ((and (= (cur) "/") (< (+ pos 1) src-len) (= (dl-peek 1) "*"))
+              (do (advance! 2) (skip-block-comment!) (skip-ws!)))
+            (else nil))))
+      (define
+        read-ident
+        (fn
+          (start)
+          (do
+            (when
+              (and (< pos src-len) (dl-ident-char? (cur)))
+              (do (advance! 1) (read-ident start)))
+            (slice src start pos))))
+      (define
+        read-decimal-digits!
+        (fn
+          ()
+          (when
+            (and (< pos src-len) (dl-digit? (cur)))
+            (do (advance! 1) (read-decimal-digits!)))))
+      (define
+        read-number
+        (fn
+          (start)
+          (do
+            (read-decimal-digits!)
+            (when
+              (and
+                (< pos src-len)
+                (= (cur) ".")
+                (< (+ pos 1) src-len)
+                (dl-digit? (dl-peek 1)))
+              (do (advance! 1) (read-decimal-digits!)))
+            (parse-number (slice src start pos)))))
+      (define
+        read-quoted
+        (fn
+          (quote-char)
+          (let
+            ((chars (list)))
+            (advance! 1)
+            (define
+              loop
+              (fn
+                ()
+                (cond
+                  ((>= pos src-len)
+                    (error
+                      (str "Tokenizer: unterminated "
+                           (if (= quote-char "'") "quoted atom" "string")
+                           " (started near position " pos ")")))
+                  ((= (cur) "\\")
+                    (do
+                      (advance! 1)
+                      (when
+                        (< pos src-len)
+                        (let
+                          ((ch (cur)))
+                          (do
+                            (cond
+                              ((= ch "n") (append! chars "\n"))
+                              ((= ch "t") (append! chars "\t"))
+                              ((= ch "r") (append! chars "\r"))
+                              ((= ch "\\") (append! chars "\\"))
+                              ((= ch "'") (append! chars "'"))
+                              ((= ch "\"") (append! chars "\""))
+                              (else (append! chars ch)))
+                            (advance! 1))))
+                      (loop)))
+                  ((= (cur) quote-char) (advance! 1))
+                  (else
+                    (do (append! chars (cur)) (advance! 1) (loop))))))
+            (loop)
+            (join "" chars))))
+      (define
+        scan!
+        (fn
+          ()
+          (do
+            (skip-ws!)
+            (when
+              (< pos src-len)
+              (let
+                ((ch (cur)) (start pos))
+                (cond
+                  ((at? ":-")
+                    (do
+                      (dl-emit! "op" ":-" start)
+                      (advance! 2)
+                      (scan!)))
+                  ((at? "?-")
+                    (do
+                      (dl-emit! "op" "?-" start)
+                      (advance! 2)
+                      (scan!)))
+                  ((at? "<=")
+                    (do
+                      (dl-emit! "op" "<=" start)
+                      (advance! 2)
+                      (scan!)))
+                  ((at? ">=")
+                    (do
+                      (dl-emit! "op" ">=" start)
+                      (advance! 2)
+                      (scan!)))
+                  ((at? "!=")
+                    (do
+                      (dl-emit! "op" "!=" start)
+                      (advance! 2)
+                      (scan!)))
+                  ((dl-digit? ch)
+                    (do
+                      (dl-emit! "number" (read-number start) start)
+                      (scan!)))
+                  ((= ch "'")
+                    ;; Quoted 'atoms' tokenize as strings so a name
+                    ;; like 'Hello World' doesn't get misclassified
+                    ;; as a variable by dl-var? (which inspects the
+                    ;; symbol's first character).
+                    (do (dl-emit! "string" (read-quoted "'") start) (scan!)))
+                  ((= ch "\"")
+                    (do (dl-emit! "string" (read-quoted "\"") start) (scan!)))
+                  ((dl-lower? ch)
+                    (do (dl-emit! "atom" (read-ident start) start) (scan!)))
+                  ((or (dl-upper? ch) (= ch "_"))
+                    (do (dl-emit! "var" (read-ident start) start) (scan!)))
+                  ((= ch "(")
+                    (do
+                      (dl-emit! "punct" "(" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch ")")
+                    (do
+                      (dl-emit! "punct" ")" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch ",")
+                    (do
+                      (dl-emit! "punct" "," start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch ".")
+                    (do
+                      (dl-emit! "punct" "." start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch "<")
+                    (do
+                      (dl-emit! "op" "<" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch ">")
+                    (do
+                      (dl-emit! "op" ">" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch "=")
+                    (do
+                      (dl-emit! "op" "=" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch "+")
+                    (do
+                      (dl-emit! "op" "+" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch "-")
+                    (do
+                      (dl-emit! "op" "-" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch "*")
+                    (do
+                      (dl-emit! "op" "*" start)
+                      (advance! 1)
+                      (scan!)))
+                  ((= ch "/")
+                    (do
+                      (dl-emit! "op" "/" start)
+                      (advance! 1)
+                      (scan!)))
+                  (else (error
+                          (str "Tokenizer: unexpected character '" ch
+                               "' at position " start)))))))))
+      (scan!)
+      (dl-emit! "eof" nil pos)
+      tokens)))

lib/datalog/unify.sx

@@ -0,0 +1,171 @@
+;; lib/datalog/unify.sx — unification + substitution for Datalog terms.
+;;
+;; Term taxonomy (after parsing):
+;;   variable  — SX symbol whose first char is uppercase A–Z or '_'.
+;;   constant  — SX symbol whose first char is lowercase a–z (atom name).
+;;   number    — numeric literal.
+;;   string    — string literal.
+;;   compound  — SX list (functor arg ... arg). In core Datalog these
+;;               only appear as arithmetic expressions (see Phase 4
+;;               safety analysis); compound-against-compound unification
+;;               is supported anyway for completeness.
+;;
+;; Substitutions are immutable dicts keyed by variable name (string).
+;; A failed unification returns nil; success returns the extended subst.
+
+(define dl-empty-subst (fn () {}))
+
+(define
+  dl-var?
+  (fn
+    (term)
+    (and
+      (symbol? term)
+      (let
+        ((name (symbol->string term)))
+        (and
+          (> (len name) 0)
+          (let
+            ((c (slice name 0 1)))
+            (or (and (>= c "A") (<= c "Z")) (= c "_"))))))))
+
+;; Walk: chase variable bindings until we hit a non-variable or an unbound
+;; variable. The result is either a non-variable term or an unbound var.
+(define
+  dl-walk
+  (fn (term subst) (dl-walk-aux term subst (list))))
+
+;; Internal: walk with a visited-var set so circular substitutions
+;; (from raw dl-bind misuse) don't infinite-loop. Cycles return the
+;; current term unchanged.
+(define
+  dl-walk-aux
+  (fn
+    (term subst visited)
+    (if
+      (dl-var? term)
+      (let
+        ((name (symbol->string term)))
+        (cond
+          ((dl-member? name visited) term)
+          ((and (dict? subst) (has-key? subst name))
+            (let ((seen (list)))
+              (do
+                (for-each (fn (v) (append! seen v)) visited)
+                (append! seen name)
+                (dl-walk-aux (get subst name) subst seen))))
+          (else term)))
+      term)))
+
+;; Bind a variable symbol to a value in subst, returning a new subst.
+(define
+  dl-bind
+  (fn (var-sym value subst) (assoc subst (symbol->string var-sym) value)))
+
+(define
+  dl-unify
+  (fn
+    (t1 t2 subst)
+    (if
+      (nil? subst)
+      nil
+      (let
+        ((u1 (dl-walk t1 subst)) (u2 (dl-walk t2 subst)))
+        (cond
+          ((dl-var? u1)
+            (cond
+              ((and (dl-var? u2) (= (symbol->string u1) (symbol->string u2)))
+                subst)
+              (else (dl-bind u1 u2 subst))))
+          ((dl-var? u2) (dl-bind u2 u1 subst))
+          ((and (list? u1) (list? u2))
+            (if
+              (= (len u1) (len u2))
+              (dl-unify-list u1 u2 subst 0)
+              nil))
+          ((and (number? u1) (number? u2)) (if (= u1 u2) subst nil))
+          ((and (string? u1) (string? u2)) (if (= u1 u2) subst nil))
+          ((and (symbol? u1) (symbol? u2))
+            (if (= (symbol->string u1) (symbol->string u2)) subst nil))
+          (else nil))))))
+
+(define
+  dl-unify-list
+  (fn
+    (a b subst i)
+    (cond
+      ((nil? subst) nil)
+      ((>= i (len a)) subst)
+      (else
+        (dl-unify-list
+          a
+          b
+          (dl-unify (nth a i) (nth b i) subst)
+          (+ i 1))))))
+
+;; Apply substitution: walk the term and recurse into lists.
+(define
+  dl-apply-subst
+  (fn
+    (term subst)
+    (let
+      ((w (dl-walk term subst)))
+      (if (list? w) (map (fn (x) (dl-apply-subst x subst)) w) w))))
+
+;; Ground? — true iff no free variables remain after walking.
+(define
+  dl-ground?
+  (fn
+    (term subst)
+    (let
+      ((w (dl-walk term subst)))
+      (cond
+        ((dl-var? w) false)
+        ((list? w) (dl-ground-list? w subst 0))
+        (else true)))))
+
+(define
+  dl-ground-list?
+  (fn
+    (xs subst i)
+    (cond
+      ((>= i (len xs)) true)
+      ((not (dl-ground? (nth xs i) subst)) false)
+      (else (dl-ground-list? xs subst (+ i 1))))))
+
+;; Return the list of variable names appearing in a term (deduped, in
+;; left-to-right order). Useful for safety analysis later.
+(define
+  dl-vars-of
+  (fn (term) (let ((seen (list))) (do (dl-vars-of-aux term seen) seen))))
+
+(define
+  dl-vars-of-aux
+  (fn
+    (term acc)
+    (cond
+      ((dl-var? term)
+        (let
+          ((name (symbol->string term)))
+          (when (not (dl-member? name acc)) (append! acc name))))
+      ((list? term) (dl-vars-of-list term acc 0))
+      (else nil))))
+
+(define
+  dl-vars-of-list
+  (fn
+    (xs acc i)
+    (when
+      (< i (len xs))
+      (do
+        (dl-vars-of-aux (nth xs i) acc)
+        (dl-vars-of-list xs acc (+ i 1))))))
+
+(define
+  dl-member?
+  (fn
+    (x xs)
+    (cond
+      ((= (len xs) 0) false)
+      ((= (first xs) x) true)
+      (else (dl-member? x (rest xs))))))

lib/forth/ans-tests/README.md

@@ -0,0 +1,14 @@
+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

@@ -0,0 +1,775 @@
+\ 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

@@ -0,0 +1,66 @@
+\ 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

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

@@ -0,0 +1,158 @@
+;; 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,7 +5,39 @@
 
 (define
   forth-execute-word
-  (fn (state word) (let ((body (get word "body"))) (body state))))
+  (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))))))))
 
 (define
   forth-interpret-token
@@ -17,7 +49,7 @@
         (not (nil? w))
         (forth-execute-word state w)
         (let
-          ((n (forth-parse-number tok (get state "base"))))
+          ((n (forth-parse-number tok (get (get state "vars") "base"))))
           (if
             (not (nil? n))
             (forth-push state n)

lib/forth/scoreboard.json

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

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

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

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

@@ -0,0 +1,333 @@
+;; 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/reflective/class-chain.sx

@@ -0,0 +1,129 @@
+;; lib/guest/reflective/class-chain.sx — class inheritance walker.
+;;
+;; Extracted from Smalltalk's `st-method-lookup-walk` (single-parent
+;; class chain for message-send dispatch) and CLOS's `clos-specificity`
+;; (multi-parent class graph for method-precedence distance). Both walk
+;; a class-name → parent-name(s) graph applying a probe at each node;
+;; the cfg adapter normalises single-parent and multi-parent classes
+;; into a uniform `:parents-of` callback that returns a (possibly
+;; empty) list of parent class names.
+;;
+;; Adapter cfg
+;; -----------
+;;   :parents-of  — fn (class-name) → list of parent class names.
+;;                  Empty list = no parents (root). Single-parent guests
+;;                  return a 1-element list; multi-parent guests (CLOS)
+;;                  may return any number.
+;;   :class?      — fn (name) → bool. False short-circuits the walk —
+;;                  used to skip non-existent class names mid-chain.
+;;
+;; Public API
+;;   (refl-class-chain-find-with CFG CLASS-NAME PROBE)
+;;     Depth-first walk from CLASS-NAME up its parent chain. At each
+;;     class, calls `(probe class-name)`. Returns the first non-nil
+;;     probe result, or nil if no class produces one. Probes evaluate
+;;     left-to-right across siblings in multi-parent guests.
+;;
+;;   (refl-class-chain-depth-with CFG CLASS-NAME ANCESTOR-NAME)
+;;     Minimum hop count from CLASS-NAME to ANCESTOR-NAME along any
+;;     parent path. CLASS-NAME itself counts as depth 0. Returns nil
+;;     if ANCESTOR-NAME is unreachable.
+;;
+;;   (refl-class-chain-ancestors-with CFG CLASS-NAME)
+;;     Flat list of all reachable ancestor names in DFS order (no
+;;     dedup; multi-parent guests may want to dedup themselves).
+;;
+;; Consumer migrations
+;; -------------------
+;; - Smalltalk: see `lib/smalltalk/runtime.sx` — `st-method-lookup-walk`
+;;   becomes a one-line probe through `refl-class-chain-find-with`.
+;; - CLOS: see `lib/common-lisp/clos.sx` — `clos-specificity` becomes a
+;;   thin wrapper around `refl-class-chain-depth-with`.
+
+(define
+  refl-find-in-parents-with
+  (fn
+    (cfg parents probe)
+    (cond
+      ((or (nil? parents) (= (length parents) 0)) nil)
+      (:else
+        (let
+          ((hit (refl-class-chain-find-with cfg (first parents) probe)))
+          (cond
+            ((not (nil? hit)) hit)
+            (:else (refl-find-in-parents-with cfg (rest parents) probe))))))))
+
+(define
+  refl-class-chain-find-with
+  (fn
+    (cfg class-name probe)
+    (cond
+      ((nil? class-name) nil)
+      ((not ((get cfg :class?) class-name)) nil)
+      (:else
+        (let
+          ((hit (probe class-name)))
+          (cond
+            ((not (nil? hit)) hit)
+            (:else
+              (refl-find-in-parents-with
+                cfg
+                ((get cfg :parents-of) class-name)
+                probe))))))))
+
+(define
+  refl-class-chain-depth-walk
+  (fn
+    (cfg cur target depth)
+    (cond
+      ((= cur target) depth)
+      ((nil? cur) nil)
+      ((not ((get cfg :class?) cur)) nil)
+      (:else
+        (let
+          ((parents ((get cfg :parents-of) cur)))
+          (let
+            ((results (map (fn (p) (refl-class-chain-depth-walk cfg p target (+ depth 1))) parents)))
+            (let
+              ((non-nil (filter (fn (x) (not (nil? x))) results)))
+              (cond
+                ((or (nil? non-nil) (= (length non-nil) 0)) nil)
+                (:else
+                  (reduce
+                    (fn (a b) (if (< a b) a b))
+                    (first non-nil)
+                    (rest non-nil)))))))))))
+
+(define
+  refl-class-chain-depth-with
+  (fn
+    (cfg class-name ancestor-name)
+    (refl-class-chain-depth-walk cfg class-name ancestor-name 0)))
+
+(define
+  refl-class-chain-ancestors-with
+  (fn (cfg class-name) (refl-ancestors-walk cfg class-name (list))))
+
+(define
+  refl-ancestors-walk
+  (fn
+    (cfg cn acc)
+    (cond
+      ((nil? cn) acc)
+      ((not ((get cfg :class?) cn)) acc)
+      (:else
+        (let
+          ((parents ((get cfg :parents-of) cn)))
+          (refl-ancestors-walk-list cfg parents (append acc (list cn))))))))
+
+(define
+  refl-ancestors-walk-list
+  (fn
+    (cfg parents acc)
+    (cond
+      ((or (nil? parents) (= (length parents) 0)) acc)
+      (:else
+        (refl-ancestors-walk-list
+          cfg
+          (rest parents)
+          (refl-ancestors-walk cfg (first parents) acc))))))

lib/guest/reflective/env.sx

@@ -0,0 +1,159 @@
+;; lib/guest/reflective/env.sx — first-class environment kit.
+;;
+;; Extracted from Kernel-on-SX (lib/kernel/eval.sx) when Tcl's
+;; uplevel/upvar machinery (lib/tcl/runtime.sx) materialised as a
+;; second consumer needing the same scope-chain semantics.
+;;
+;; Canonical wire shape
+;; --------------------
+;;   {:refl-tag :env :bindings DICT :parent ENV-OR-NIL}
+;;
+;;   - :bindings is a mutable SX dict keyed by symbol name.
+;;   - :parent is either another env or nil (root).
+;;   - Lookup walks the parent chain until a hit or nil.
+;;   - Default cfg uses dict-set! to mutate bindings in place.
+;;
+;; Consumers with their own shape (e.g., Tcl's {:level :locals :parent})
+;; pass an adapter cfg dict — same trick as lib/guest/match.sx's cfg
+;; for unification over guest-specific term shapes.
+;;
+;; Adapter cfg keys
+;; ----------------
+;;   :bindings-of  — fn (scope) → DICT
+;;   :parent-of    — fn (scope) → SCOPE-OR-NIL
+;;   :extend       — fn (scope) → SCOPE         (push a fresh child)
+;;   :bind!        — fn (scope name val) → scope (functional or mutable)
+;;   :env?         — fn (v) → bool              (predicate; cheap shape check)
+;;
+;; Public API — canonical shape, mutable, raises on miss
+;;
+;;   (refl-make-env)
+;;   (refl-extend-env PARENT)
+;;   (refl-env? V)
+;;   (refl-env-bind! ENV NAME VAL)
+;;   (refl-env-has? ENV NAME)
+;;   (refl-env-lookup ENV NAME)
+;;   (refl-env-lookup-or-nil ENV NAME)
+;;
+;; Public API — adapter-cfg, any shape
+;;
+;;   (refl-env-extend-with CFG SCOPE)
+;;   (refl-env-bind!-with  CFG SCOPE NAME VAL)
+;;   (refl-env-has?-with   CFG SCOPE NAME)
+;;   (refl-env-lookup-with CFG SCOPE NAME)
+;;   (refl-env-lookup-or-nil-with CFG SCOPE NAME)
+;;   (refl-env-find-frame-with CFG SCOPE NAME)
+;;     — returns the scope in the chain that contains NAME (or nil).
+;;       Consumers needing source-frame mutation use this.
+;;
+;;   (refl-canonical-cfg) — the default cfg, exposed so consumers
+;;                          can compare or extend it.
+
+;; ── Canonical-shape predicates and constructors ─────────────────
+
+(define refl-env? (fn (v) (and (dict? v) (= (get v :refl-tag) :env))))
+
+(define refl-make-env (fn () {:parent nil :refl-tag :env :bindings {}}))
+
+(define refl-extend-env (fn (parent) {:parent parent :refl-tag :env :bindings {}}))
+
+(define
+  refl-env-bind!
+  (fn (env name val) (dict-set! (get env :bindings) name val) env))
+
+(define
+  refl-env-has?
+  (fn
+    (env name)
+    (cond
+      ((nil? env) false)
+      ((not (refl-env? env)) false)
+      ((dict-has? (get env :bindings) name) true)
+      (:else (refl-env-has? (get env :parent) name)))))
+
+(define
+  refl-env-lookup
+  (fn
+    (env name)
+    (cond
+      ((nil? env) (error (str "refl-env-lookup: unbound symbol: " name)))
+      ((not (refl-env? env))
+        (error (str "refl-env-lookup: corrupt env: " env)))
+      ((dict-has? (get env :bindings) name) (get (get env :bindings) name))
+      (:else (refl-env-lookup (get env :parent) name)))))
+
+(define
+  refl-env-lookup-or-nil
+  (fn
+    (env name)
+    (cond
+      ((nil? env) nil)
+      ((not (refl-env? env)) nil)
+      ((dict-has? (get env :bindings) name) (get (get env :bindings) name))
+      (:else (refl-env-lookup-or-nil (get env :parent) name)))))
+
+;; ── Adapter-cfg variants — any wire shape ───────────────────────
+
+(define refl-env-extend-with (fn (cfg scope) ((get cfg :extend) scope)))
+
+(define
+  refl-env-bind!-with
+  (fn (cfg scope name val) ((get cfg :bind!) scope name val)))
+
+(define
+  refl-env-has?-with
+  (fn
+    (cfg scope name)
+    (cond
+      ((nil? scope) false)
+      ((not ((get cfg :env?) scope)) false)
+      ((dict-has? ((get cfg :bindings-of) scope) name) true)
+      (:else (refl-env-has?-with cfg ((get cfg :parent-of) scope) name)))))
+
+(define
+  refl-env-lookup-with
+  (fn
+    (cfg scope name)
+    (cond
+      ((nil? scope) (error (str "refl-env-lookup: unbound symbol: " name)))
+      ((not ((get cfg :env?) scope))
+        (error (str "refl-env-lookup: corrupt scope: " scope)))
+      ((dict-has? ((get cfg :bindings-of) scope) name)
+        (get ((get cfg :bindings-of) scope) name))
+      (:else (refl-env-lookup-with cfg ((get cfg :parent-of) scope) name)))))
+
+(define
+  refl-env-lookup-or-nil-with
+  (fn
+    (cfg scope name)
+    (cond
+      ((nil? scope) nil)
+      ((not ((get cfg :env?) scope)) nil)
+      ((dict-has? ((get cfg :bindings-of) scope) name)
+        (get ((get cfg :bindings-of) scope) name))
+      (:else
+        (refl-env-lookup-or-nil-with cfg ((get cfg :parent-of) scope) name)))))
+
+;; Returns the SCOPE in the chain that contains NAME, or nil if no
+;; scope binds it. Consumers (e.g. Smalltalk) use this to mutate the
+;; binding at its source frame rather than introducing a new shadow
+;; binding at the current frame. Pairs with `refl-env-lookup-with`
+;; for callers that need both the value and the defining scope.
+
+(define refl-env-find-frame-with
+  (fn (cfg scope name)
+    (cond
+      ((nil? scope) nil)
+      ((not ((get cfg :env?) scope)) nil)
+      ((dict-has? ((get cfg :bindings-of) scope) name) scope)
+      (:else
+        (refl-env-find-frame-with cfg ((get cfg :parent-of) scope) name)))))
+
+(define refl-env-find-frame
+  (fn (env name) (refl-env-find-frame-with refl-canonical-cfg env name)))
+
+;; ── Default canonical cfg ───────────────────────────────────────
+;; Exposed so consumers can use it explicitly, compose with it, or
+;; check adapter-correctness against the canonical implementation.
+
+(define refl-canonical-cfg {:bind! (fn (e n v) (refl-env-bind! e n v)) :parent-of (fn (e) (get e :parent)) :env? (fn (v) (refl-env? v)) :bindings-of (fn (e) (get e :bindings)) :extend (fn (e) (refl-extend-env e))})

lib/guest/reflective/quoting.sx

@@ -0,0 +1,77 @@
+;; lib/guest/reflective/quoting.sx — quasiquote walker.
+;;
+;; Extracted from Kernel's `knl-quasi-walk` and Scheme's `scm-quasi-walk`,
+;; which differ only in:
+;;   - the unquote keyword name (Kernel: "$unquote" / "$unquote-splicing";
+;;     Scheme: "unquote" / "unquote-splicing")
+;;   - the host evaluator function (`kernel-eval` vs `scheme-eval`)
+;;
+;; Algorithm is identical. Adapter cfg parameterises the two
+;; language-specific knobs.
+;;
+;; Adapter cfg keys
+;; ----------------
+;;   :unquote-name           — string, name of the unquote keyword
+;;   :unquote-splicing-name  — string, name of the splice keyword
+;;   :eval                   — fn (form env) → value
+;;
+;; Public API
+;;   (refl-quasi-walk-with CFG FORM ENV)
+;;     Top-level walker. Returns FORM with unquotes evaluated in ENV.
+;;
+;;   (refl-quasi-walk-list-with CFG FORMS ENV)
+;;     Walks a list of forms, splicing unquote-splicing results inline.
+;;
+;;   (refl-quasi-list-concat XS YS)
+;;     Pure-SX list append (no host append/append! needed).
+
+(define
+  refl-quasi-list-concat
+  (fn
+    (xs ys)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) ys)
+      (:else (cons (first xs) (refl-quasi-list-concat (rest xs) ys))))))
+
+(define
+  refl-quasi-walk-with
+  (fn
+    (cfg form env)
+    (cond
+      ((not (list? form)) form)
+      ((= (length form) 0) form)
+      ((and (string? (first form)) (= (first form) (get cfg :unquote-name)))
+        (cond
+          ((not (= (length form) 2))
+            (error
+              (str (get cfg :unquote-name) ": expects exactly 1 argument")))
+          (:else ((get cfg :eval) (nth form 1) env))))
+      (:else (refl-quasi-walk-list-with cfg form env)))))
+
+(define
+  refl-quasi-walk-list-with
+  (fn
+    (cfg forms env)
+    (cond
+      ((or (nil? forms) (= (length forms) 0)) (list))
+      (:else
+        (let
+          ((head (first forms)))
+          (cond
+            ((and (list? head) (= (length head) 2) (string? (first head)) (= (first head) (get cfg :unquote-splicing-name)))
+              (let
+                ((spliced ((get cfg :eval) (nth head 1) env)))
+                (cond
+                  ((not (list? spliced))
+                    (error
+                      (str
+                        (get cfg :unquote-splicing-name)
+                        ": value must be a list")))
+                  (:else
+                    (refl-quasi-list-concat
+                      spliced
+                      (refl-quasi-walk-list-with cfg (rest forms) env))))))
+            (:else
+              (cons
+                (refl-quasi-walk-with cfg head env)
+                (refl-quasi-walk-list-with cfg (rest forms) env)))))))))

lib/guest/test-runner.sx

@@ -0,0 +1,50 @@
+;; lib/guest/test-runner.sx — per-suite test harness for guest test files.
+;;
+;; Across the codebase 142+ test files implement the identical four-form
+;; boilerplate: `<X>-test-pass`, `<X>-test-fail`, `<X>-test-fails`, and
+;; an `<X>-test` recording function. Only the prefix differs. This kit
+;; collapses the boilerplate to a per-suite mutable dict + a recording
+;; helper, so each test file goes from ~12 lines of harness to ~3:
+;;
+;;   (define ke-suite (refl-make-test-suite))
+;;   (define ke-test  (fn (n a e) (refl-test ke-suite n a e)))
+;;   (define ke-tests-run! (fn () (refl-test-report ke-suite)))
+;;
+;; The suite is a mutable dict `{:pass N :fail N :fails LIST}`. Each
+;; failed assertion appends `{:name NAME :expected EXPECTED :actual ACT}`
+;; to :fails — same shape every existing harness already produces.
+;;
+;; The `:fails` list is mutated in place via `append!`, so callers who
+;; have a reference to it see the same updates. (Same semantic the
+;; existing per-suite globals had — just held in the suite dict now.)
+;;
+;; Public API
+;;   (refl-make-test-suite)              — fresh suite
+;;   (refl-test SUITE NAME ACT EXP)      — record one assertion
+;;   (refl-test-report SUITE)            — return {:total :passed :failed :fails}
+;;   (refl-test-pass? SUITE)             — convenience: all green?
+;;   (refl-test-suite? V)                — predicate
+
+(define refl-make-test-suite (fn () {:fail 0 :pass 0 :fails (list)}))
+
+(define
+  refl-test-suite?
+  (fn
+    (v)
+    (and (dict? v) (number? (get v :pass)) (number? (get v :fail)))))
+
+(define
+  refl-test
+  (fn
+    (suite name actual expected)
+    (cond
+      ((= actual expected)
+        (dict-set! suite :pass (+ (get suite :pass) 1)))
+      (:else
+        (begin
+          (dict-set! suite :fail (+ (get suite :fail) 1))
+          (append! (get suite :fails) {:name name :actual actual :expected expected}))))))
+
+(define refl-test-report (fn (suite) {:total (+ (get suite :pass) (get suite :fail)) :passed (get suite :pass) :failed (get suite :fail) :fails (get suite :fails)}))
+
+(define refl-test-pass? (fn (suite) (= (get suite :fail) 0)))

lib/haskell/desugar.sx

@@ -210,6 +210,7 @@
                 :op (nth node 1)
                 (hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
+            ((= tag "type-ann") (hk-desugar (nth node 1)))
             ((= tag "neg") (list :neg (hk-desugar (nth node 1))))
             ((= tag "if")
               (list

lib/haskell/parser.sx

@@ -275,38 +275,47 @@
                             (list :sect-right op-name expr-e))))))
                   (:else
                     (let
-                      ((first-e (hk-parse-expr-inner))
-                        (items (list))
-                        (is-tuple false))
-                      (append! items first-e)
-                      (define
-                        hk-tup-loop
-                        (fn
-                          ()
-                          (when
-                            (hk-match? "comma" nil)
-                            (do
-                              (hk-advance!)
-                              (set! is-tuple true)
-                              (append! items (hk-parse-expr-inner))
-                              (hk-tup-loop)))))
-                      (hk-tup-loop)
+                      ((first-e (hk-parse-expr-inner)))
                       (cond
-                        ((hk-match? "rparen" nil)
+                        ((hk-match? "reservedop" "::")
                           (do
                             (hk-advance!)
-                            (if is-tuple (list :tuple items) first-e)))
+                            (let
+                              ((ann-type (hk-parse-type)))
+                              (hk-expect! "rparen" nil)
+                              (list :type-ann first-e ann-type))))
                         (:else
                           (let
-                            ((op-info2 (hk-section-op-info)))
+                            ((items (list)) (is-tuple false))
+                            (append! items first-e)
+                            (define
+                              hk-tup-loop
+                              (fn
+                                ()
+                                (when
+                                  (hk-match? "comma" nil)
+                                  (do
+                                    (hk-advance!)
+                                    (set! is-tuple true)
+                                    (append! items (hk-parse-expr-inner))
+                                    (hk-tup-loop)))))
+                            (hk-tup-loop)
                             (cond
-                              ((and (not (nil? op-info2)) (not is-tuple) (let ((after2 (hk-peek-at (get op-info2 "len")))) (and (not (nil? after2)) (= (get after2 "type") "rparen"))))
-                                (let
-                                  ((op-name (get op-info2 "name")))
-                                  (hk-consume-op!)
+                              ((hk-match? "rparen" nil)
+                                (do
                                   (hk-advance!)
-                                  (list :sect-left op-name first-e)))
-                              (:else (hk-err "expected ')' after expression"))))))))))))))
+                                  (if is-tuple (list :tuple items) first-e)))
+                              (:else
+                                (let
+                                  ((op-info2 (hk-section-op-info)))
+                                  (cond
+                                    ((and (not (nil? op-info2)) (not is-tuple) (let ((after2 (hk-peek-at (get op-info2 "len")))) (and (not (nil? after2)) (= (get after2 "type") "rparen"))))
+                                      (let
+                                        ((op-name (get op-info2 "name")))
+                                        (hk-consume-op!)
+                                        (hk-advance!)
+                                        (list :sect-left op-name first-e)))
+                                    (:else (hk-err "expected ')' after expression")))))))))))))))))
       (define
         hk-comp-qual-is-gen?
         (fn
@@ -1724,10 +1733,18 @@
                   (= (hk-peek-type) "eof")
                   (hk-match? "vrbrace" nil)
                   (hk-match? "rbrace" nil))))
+            (define
+              hk-body-step
+              (fn
+                ()
+                (cond
+                  ((hk-match? "reserved" "import")
+                    (append! imports (hk-parse-import)))
+                  (:else (append! decls (hk-parse-decl))))))
             (when
               (not (hk-body-at-end?))
               (do
-                (append! decls (hk-parse-decl))
+                (hk-body-step)
                 (define
                   hk-body-loop
                   (fn
@@ -1738,7 +1755,7 @@
                         (hk-advance!)
                         (when
                           (not (hk-body-at-end?))
-                          (append! decls (hk-parse-decl)))
+                          (hk-body-step))
                         (hk-body-loop)))))
                 (hk-body-loop)))
             (list imports decls))))

lib/haskell/tests/parse-extras.sx

@@ -0,0 +1,102 @@
+;; Phase 17 — parser polish unit tests.
+
+(hk-test
+  "type-ann: literal int annotated"
+  (hk-deep-force (hk-run "main = (42 :: Int)"))
+  42)
+
+(hk-test
+  "type-ann: arithmetic annotated"
+  (hk-deep-force (hk-run "main = (1 + 2 :: Int)"))
+  3)
+
+(hk-test
+  "type-ann: function arg annotated"
+  (hk-deep-force
+    (hk-run "f x = x + 1\nmain = f (1 :: Int)"))
+  2)
+
+(hk-test
+  "type-ann: string annotated"
+  (hk-deep-force (hk-run "main = (\"hi\" :: String)"))
+  "hi")
+
+(hk-test
+  "type-ann: bool annotated"
+  (hk-deep-force (hk-run "main = (True :: Bool)"))
+  (list "True"))
+
+(hk-test
+  "type-ann: tuple annotated"
+  (hk-deep-force (hk-run "main = ((1, 2) :: (Int, Int))"))
+  (list "Tuple" 1 2))
+
+(hk-test
+  "type-ann: nested annotation in arithmetic"
+  (hk-deep-force (hk-run "main = (1 :: Int) + (2 :: Int)"))
+  3)
+
+(hk-test
+  "type-ann: function-typed annotation passes through eval"
+  (hk-deep-force
+    (hk-run "main = let f = ((\\x -> x + 1) :: Int -> Int) in f 5"))
+  6)
+
+(hk-test
+  "no regression: plain parens still work"
+  (hk-deep-force (hk-run "main = (5)"))
+  5)
+
+(hk-test
+  "no regression: 3-tuple still works"
+  (hk-deep-force (hk-run "main = (1, 2, 3)"))
+  (list "Tuple" 1 2 3))
+
+(hk-test
+  "no regression: section-left still works"
+  (hk-deep-force (hk-run "main = (3 +) 4"))
+  7)
+
+(hk-test
+  "no regression: section-right still works"
+  (hk-deep-force (hk-run "main = (+ 3) 4"))
+  7)
+
+(hk-test
+  "import: still works as the very first decl"
+  (hk-deep-force
+    (hk-run "import qualified Data.IORef as I
+main = do { r <- I.newIORef 7; I.readIORef r }"))
+  (list "IO" 7))
+
+(hk-test
+  "import: between decls — after main"
+  (hk-deep-force
+    (hk-run "main = do { r <- I.newIORef 11; I.readIORef r }
+import qualified Data.IORef as I"))
+  (list "IO" 11))
+
+(hk-test
+  "import: between two decls — uses helper after import"
+  (hk-deep-force
+    (hk-run "f x = x + 100
+import qualified Data.IORef as I
+main = do { r <- I.newIORef 5; I.modifyIORef r f; I.readIORef r }"))
+  (list "IO" 105))
+
+(hk-test
+  "import: two imports in different positions"
+  (hk-deep-force
+    (hk-run "import qualified Data.IORef as I
+helper x = x * 2
+import qualified Data.Map as M
+main = do { r <- I.newIORef (helper 21); I.readIORef r }"))
+  (list "IO" 42))
+
+(hk-test
+  "import: unqualified, mid-file"
+  (hk-deep-force
+    (hk-run "go x = x
+import Data.IORef
+main = go 9"))
+  9)

lib/haskell/tests/typecheck.sx

@@ -16,15 +16,18 @@
       true)))
 
 ;; ─── Valid programs pass through ─────────────────────────────────────────────
-(hk-test "typed ok: simple arithmetic" (hk-run-typed "main = 1 + 2") 3)
+(hk-test "typed ok: simple arithmetic"
+  (hk-deep-force (hk-run-typed "main = 1 + 2")) 3)
 
-(hk-test "typed ok: boolean" (hk-run-typed "main = True") (list "True"))
+(hk-test "typed ok: boolean"
+  (hk-deep-force (hk-run-typed "main = True")) (list "True"))
 
-(hk-test "typed ok: let binding" (hk-run-typed "main = let x = 1 in x + 2") 3)
+(hk-test "typed ok: let binding"
+  (hk-deep-force (hk-run-typed "main = let x = 1 in x + 2")) 3)
 
 (hk-test
   "typed ok: two independent fns"
-  (hk-run-typed "f x = x + 1\nmain = f 5")
+  (hk-deep-force (hk-run-typed "f x = x + 1\nmain = f 5"))
   6)
 
 ;; ─── Untypeable programs are rejected ────────────────────────────────────────
@@ -76,7 +79,7 @@
 
 (hk-test
   "run-typed sig ok: Int declared matches"
-  (hk-run-typed "main :: Int\nmain = 1 + 2")
+  (hk-deep-force (hk-run-typed "main :: Int\nmain = 1 + 2"))
   3)
 
 {:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/hyperscript/runtime.sx

@@ -3242,97 +3242,112 @@
 
 (define hs-token-op? (fn (tok) (dict-get tok :op)))
 
+;; ── WebSocket / socket feature ───────────────────────────────────
+
 (define
   hs-try-json-parse
-  (fn (data) (if (string? data) (guard (_e nil) (json-parse data)) nil)))
-
-(define
-  hs-socket-normalise-url
-  (fn
-    (url)
-    (if
-      (or (starts-with? url "ws://") (starts-with? url "wss://"))
-      url
-      (let
-        ((proto (host-get (host-global "location") "protocol"))
-          (host-str (host-get (host-global "location") "host")))
-        (let
-          ((scheme (if (= proto "https:") "wss://" "ws://")))
-          (str scheme host-str url))))))
-
-(define
-  hs-socket-bind-name!
-  (fn
-    (name-path wrapper)
-    (let
-      ((win (host-global "window")))
-      (if
-        (= (len name-path) 1)
-        (host-set! win (first name-path) wrapper)
-        (do
-          (when
-            (nil? (host-get win (first name-path)))
-            (host-set! win (first name-path) (host-new "Object")))
-          (host-set!
-            (host-get win (first name-path))
-            (nth name-path 1)
-            wrapper))))))
+  (fn (s) (host-call (host-global "JSON") "parse" s)))
 
 (define
   hs-socket-resolve-rpc!
   (fn
-    (wrapper data)
+    (wrapper msg)
     (let
-      ((iid (host-get data "iid")))
-      (when
-        (not (nil? iid))
-        (let
-          ((pending (host-get wrapper "_pending")))
-          (when
-            (not (nil? pending))
-            (let
-              ((entry (host-get pending iid)))
-              (when
-                (not (nil? entry))
-                (host-set! pending iid nil)
-                (if
-                  (not (nil? (host-get data "throw")))
-                  (host-call-fn
-                    (host-get entry "reject")
-                    (list (host-get data "throw")))
-                  (host-call-fn
-                    (host-get entry "resolve")
-                    (list (host-get data "return"))))))))))))
+      ((pending (host-get wrapper "pending")) (iid (host-get msg "iid")))
+      (let
+        ((resolver (host-get pending iid)))
+        (when
+          (not (nil? resolver))
+          (if
+            (not (nil? (host-get msg "return")))
+            (host-call resolver "resolve" (host-get msg "return"))
+            (host-call resolver "reject" (host-get msg "throw")))
+          (host-set! pending iid nil))))))
 
 (define
   hs-socket-register!
   (fn
-    (name-path url timeout on-message-handler json?)
+    (name-path url timeout-ms handler json?)
     (let
-      ((norm-url (hs-socket-normalise-url url)))
+      ((ws-url (cond ((or (starts-with? url "ws://") (starts-with? url "wss://")) url) (true (let ((proto (host-get (host-global "location") "protocol")) (h (host-get (host-global "location") "host"))) (str (if (= proto "https:") "wss:" "ws:") "//" h url))))))
       (let
-        ((wrapper (host-new "Object")))
-        (do
-          (host-set! wrapper "_url" norm-url)
-          (host-set! wrapper "_timeout" (if (nil? timeout) 0 timeout))
-          (host-set! wrapper "_pending" (host-new "Object"))
-          (host-set! wrapper "_closed" false)
+        ((ws (host-new "WebSocket" ws-url)))
+        (let
+          ((wrapper (host-new "Object")))
+          (host-set! wrapper "raw" ws)
+          (host-set! wrapper "url" ws-url)
+          (host-set! wrapper "timeout" timeout-ms)
+          (host-set! wrapper "pending" (host-new "Object"))
+          (host-set! wrapper "handler" handler)
+          (host-set! wrapper "json?" json?)
+          (host-set! wrapper "closed?" false)
+          (host-set! wrapper "closedFlag" nil)
           (let
-            ((ws (host-new "WebSocket" norm-url)))
-            (do
-              (host-set! wrapper "_ws" ws)
-              (let
-                ((msg-handler (host-callback (fn (evt) (do (let ((parsed (hs-try-json-parse (host-get evt "data")))) (when (and (not (nil? parsed)) (not (nil? (host-get parsed "iid")))) (hs-socket-resolve-rpc! wrapper parsed))) (when (not (nil? on-message-handler)) (if json? (let ((data (hs-try-json-parse (host-get evt "data")))) (when (not (nil? data)) (on-message-handler data))) (on-message-handler evt))))))))
-                (do
-                  (host-set! ws "onmessage" msg-handler)
-                  (host-set! wrapper "_onmessage_handler" msg-handler)
-                  (host-set!
-                    ws
-                    "onclose"
-                    (host-callback
-                      (fn (e) (host-set! wrapper "_closed" true))))
-                  (host-call-fn
-                    (host-global "_hsSetupSocket")
-                    (list wrapper))
-                  (hs-socket-bind-name! name-path wrapper)
-                  wrapper)))))))))
+            ((proxy-factory (host-global "_hs_make_rpc_proxy")))
+            (when
+              proxy-factory
+              (host-set!
+                wrapper
+                "rpc"
+                (host-call proxy-factory "call" nil wrapper))))
+          (host-set!
+            ws
+            "onmessage"
+            (host-callback
+              (fn
+                (event)
+                (let
+                  ((data (host-get event "data")))
+                  (let
+                    ((parsed (hs-try-json-parse data)))
+                    (cond
+                      ((and (not (nil? parsed)) (not (nil? (host-get parsed "iid"))))
+                        (hs-socket-resolve-rpc! wrapper parsed))
+                      ((not (nil? handler))
+                        (if
+                          json?
+                          (if
+                            (not (nil? parsed))
+                            (handler parsed)
+                            (error "Received non-JSON message"))
+                          (handler event)))))))))
+          (host-call
+            ws
+            "addEventListener"
+            "close"
+            (host-callback
+              (fn
+                (evt)
+                (host-set! wrapper "closedFlag" "1"))))
+          (host-set!
+            wrapper
+            "dispatchEvent"
+            (host-callback
+              (fn
+                (evt)
+                (let
+                  ((payload (host-new "Object")))
+                  (host-set! payload "type" (host-get evt "type"))
+                  (host-call
+                    (host-get wrapper "raw")
+                    "send"
+                    (host-call
+                      (host-global "JSON")
+                      "stringify"
+                      payload))))))
+          (define
+            bind-path!
+            (fn
+              (obj path)
+              (if
+                (= (len path) 1)
+                (host-set! obj (first path) wrapper)
+                (let
+                  ((key (first path)) (rest-path (rest path)))
+                  (let
+                    ((next (or (host-get obj key) (host-new "Object"))))
+                    (host-set! obj key next)
+                    (bind-path! next rest-path))))))
+          (bind-path! (host-global "window") name-path)
+          wrapper)))))
+

lib/jit.sx

@@ -0,0 +1,89 @@
+;; lib/jit.sx — SX-level convenience wrappers over the JIT cache control
+;; primitives (jit-stats, jit-set-threshold!, jit-set-budget!, jit-reset-cache!,
+;; jit-reset-counters!). Host-specific implementations live in
+;; hosts/<host>/lib/sx_*.ml; the API surface is portable across hosts.
+
+;; with-jit-threshold — temporarily set the JIT call-count threshold for
+;; the duration of body, restoring the previous value on exit. Useful for
+;; sections that want eager compilation (threshold=1) or want to skip JIT
+;; entirely (threshold=999999) for diagnostic comparison.
+(defmacro
+  with-jit-threshold
+  (n &rest body)
+  `(let
+     ((__old (get (jit-stats) "threshold")))
+     (jit-set-threshold! ,n)
+     (let
+       ((__r (do ,@body)))
+       (jit-set-threshold! __old)
+       __r)))
+
+;; with-jit-budget — temporarily set the LRU cache budget. Setting to 0
+;; disables JIT entirely (everything falls through to the interpreter);
+;; large values are effectively unbounded.
+(defmacro
+  with-jit-budget
+  (n &rest body)
+  `(let
+     ((__old (get (jit-stats) "budget")))
+     (jit-set-budget! ,n)
+     (let
+       ((__r (do ,@body)))
+       (jit-set-budget! __old)
+       __r)))
+
+;; with-fresh-jit — clear the cache before body, run body, clear again
+;; after. Use between sessions / request batches / test suites where you
+;; want deterministic timing free of carryover.
+(defmacro
+  with-fresh-jit
+  (&rest body)
+  `(let
+     ((__r (do (jit-reset-cache!) ,@body)))
+     (jit-reset-cache!)
+     __r))
+
+;; jit-report — human-readable summary of current JIT state. Returns a
+;; string suitable for logging.
+(define
+  jit-report
+  (fn
+    ()
+    (let
+      ((s (jit-stats)))
+      (let
+        ((compiled (get s "compiled"))
+          (skipped (get s "below-threshold"))
+          (failed (get s "compile-failed"))
+          (evicted (get s "evicted"))
+          (cache-size (get s "cache-size"))
+          (budget (get s "budget"))
+          (threshold (get s "threshold")))
+        (let
+          ((total (+ compiled skipped failed)))
+          (str
+            "jit: " cache-size "/" budget " cached "
+            "(thr=" threshold ") · "
+            compiled " compiled, "
+            skipped " below-thr, "
+            failed " failed, "
+            evicted " evicted "
+            "(" (if (> total 0) (* 100 (/ compiled total)) 0) "% compile rate)"))))))
+
+;; jit-disable! / jit-enable! — convenience helpers. Disabling sets budget
+;; to 0 which causes the VM to skip JIT entirely on the next call. Enable
+;; restores the budget to its previous value (or 5000 if no previous).
+(define _jit-saved-budget (list 5000))
+
+(define
+  jit-disable!
+  (fn
+    ()
+    (set! _jit-saved-budget (list (get (jit-stats) "budget")))
+    (jit-set-budget! 0)))
+
+(define
+  jit-enable!
+  (fn
+    ()
+    (jit-set-budget! (first _jit-saved-budget))))

lib/js/lexer.sx

@@ -29,6 +29,16 @@
       (and (>= c "a") (<= c "f"))
       (and (>= c "A") (<= c "F")))))
 
+(define
+  js-hex-value
+  (fn
+    (c)
+    (cond
+      ((and (>= c "0") (<= c "9")) (- (char-code c) 48))
+      ((and (>= c "a") (<= c "f")) (- (char-code c) 87))
+      ((and (>= c "A") (<= c "F")) (- (char-code c) 55))
+      (else 0))))
+
 (define
   js-letter?
   (fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
@@ -37,9 +47,9 @@
 
 (define js-ident-char? (fn (c) (or (js-ident-start? c) (js-digit? c))))
 
+;; ── Reserved words ────────────────────────────────────────────────
 (define js-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
 
-;; ── Reserved words ────────────────────────────────────────────────
 (define
   js-keywords
   (list
@@ -86,15 +96,18 @@
     "await"
     "of"))
 
+;; ── Main tokenizer ────────────────────────────────────────────────
 (define js-keyword? (fn (word) (contains? js-keywords word)))
 
-;; ── Main tokenizer ────────────────────────────────────────────────
 (define
   js-tokenize
   (fn
     (src)
     (let
-      ((tokens (list)) (pos 0) (src-len (len src)))
+      ((tokens (list))
+        (pos 0)
+        (src-len (len src))
+        (nl-before false))
       (define
         js-peek
         (fn
@@ -109,11 +122,7 @@
           (let
             ((sl (len s)))
             (and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
-      (define
-        js-emit!
-        (fn
-          (type value start)
-          (append! tokens (js-make-token type value start))))
+      (define js-emit! (fn (type value start) (append! tokens {:nl nl-before :type type :value value :pos start})))
       (define
         skip-line-comment!
         (fn
@@ -136,7 +145,13 @@
           ()
           (cond
             ((>= pos src-len) nil)
-            ((js-ws? (cur)) (do (advance! 1) (skip-ws!)))
+            ((js-ws? (cur))
+              (do
+                (when
+                  (or (= (cur) "\n") (= (cur) "\r"))
+                  (set! nl-before true))
+                (advance! 1)
+                (skip-ws!)))
             ((and (= (cur) "/") (< (+ pos 1) src-len) (= (js-peek 1) "/"))
               (do (advance! 2) (skip-line-comment!) (skip-ws!)))
             ((and (= (cur) "/") (< (+ pos 1) src-len) (= (js-peek 1) "*"))
@@ -254,11 +269,55 @@
                               ((= ch "b") (append! chars "\\b"))
                               ((= ch "f") (append! chars "\\f"))
                               ((= ch "v") (append! chars "\\v"))
+                              ((= ch "u")
+                                (if
+                                  (and
+                                    (< (+ pos 4) src-len)
+                                    (js-hex-digit? (js-peek 1))
+                                    (js-hex-digit? (js-peek 2))
+                                    (js-hex-digit? (js-peek 3))
+                                    (js-hex-digit? (js-peek 4)))
+                                  (do
+                                    (append!
+                                      chars
+                                      (char-from-code
+                                        (+
+                                          (*
+                                            4096
+                                            (js-hex-value
+                                              (js-peek 1)))
+                                          (*
+                                            256
+                                            (js-hex-value
+                                              (js-peek 2)))
+                                          (*
+                                            16
+                                            (js-hex-value
+                                              (js-peek 3)))
+                                          (js-hex-value (js-peek 4)))))
+                                    (advance! 4))
+                                  (append! chars ch)))
+                              ((= ch "x")
+                                (if
+                                  (and
+                                    (< (+ pos 2) src-len)
+                                    (js-hex-digit? (js-peek 1))
+                                    (js-hex-digit? (js-peek 2)))
+                                  (do
+                                    (append!
+                                      chars
+                                      (char-from-code
+                                        (+
+                                          (* 16 (js-hex-value (js-peek 1)))
+                                          (js-hex-value (js-peek 2)))))
+                                    (advance! 2))
+                                  (append! chars ch)))
                               (else (append! chars ch)))
                             (advance! 1))))
                       (loop)))
                   ((= (cur) quote-char) (advance! 1))
-                  (else (do (append! chars (cur)) (advance! 1) (loop))))))
+                  (else
+                    (do (append! chars (cur)) (advance! 1) (loop))))))
             (loop)
             (join "" chars))))
       (define
@@ -289,7 +348,8 @@
                       ()
                       (cond
                         ((>= pos src-len) nil)
-                        ((and (= (cur) "}") (= depth 1)) (advance! 1))
+                        ((and (= (cur) "}") (= depth 1))
+                          (advance! 1))
                         ((= (cur) "}")
                           (do
                             (append! buf (cur))
@@ -325,7 +385,9 @@
                                             (advance! 1)))
                                         (sloop)))
                                     ((= (cur) q)
-                                      (do (append! buf (cur)) (advance! 1)))
+                                      (do
+                                        (append! buf (cur))
+                                        (advance! 1)))
                                     (else
                                       (do
                                         (append! buf (cur))
@@ -334,7 +396,10 @@
                               (sloop)
                               (expr-loop))))
                         (else
-                          (do (append! buf (cur)) (advance! 1) (expr-loop))))))
+                          (do
+                            (append! buf (cur))
+                            (advance! 1)
+                            (expr-loop))))))
                   (expr-loop)
                   (join "" buf))))
             (define
@@ -376,14 +441,17 @@
                               (else (append! chars ch)))
                             (advance! 1))))
                       (loop)))
-                  (else (do (append! chars (cur)) (advance! 1) (loop))))))
+                  (else
+                    (do (append! chars (cur)) (advance! 1) (loop))))))
             (loop)
             (flush-chars!)
             (if
               (= (len parts) 0)
               ""
               (if
-                (and (= (len parts) 1) (= (nth (nth parts 0) 0) "str"))
+                (and
+                  (= (len parts) 1)
+                  (= (nth (nth parts 0) 0) "str"))
                 (nth (nth parts 0) 1)
                 parts)))))
       (define
@@ -399,7 +467,7 @@
                 ((ty (dict-get tk "type")) (vv (dict-get tk "value")))
                 (cond
                   ((= ty "punct")
-                    (and (not (= vv ")")) (not (= vv "]"))))
+                    (and (not (= vv ")")) (not (= vv "]")) (not (= vv "}"))))
                   ((= ty "op") true)
                   ((= ty "keyword")
                     (contains?
@@ -453,9 +521,13 @@
                       (append! buf (cur))
                       (advance! 1)
                       (body-loop)))
-                  ((and (= (cur) "/") (not in-class)) (advance! 1))
+                  ((and (= (cur) "/") (not in-class))
+                    (advance! 1))
                   (else
-                    (begin (append! buf (cur)) (advance! 1) (body-loop))))))
+                    (begin
+                      (append! buf (cur))
+                      (advance! 1)
+                      (body-loop))))))
             (body-loop)
             (let
               ((flags-buf (list)))
@@ -470,7 +542,7 @@
                       (advance! 1)
                       (flags-loop)))))
               (flags-loop)
-              {:pattern (join "" buf) :flags (join "" flags-buf)}))))
+              {:flags (join "" flags-buf) :pattern (join "" buf)}))))
       (define
         try-op-4!
         (fn
@@ -510,64 +582,113 @@
         (fn
           (start)
           (cond
-            ((at? "==") (do (js-emit! "op" "==" start) (advance! 2) true))
-            ((at? "!=") (do (js-emit! "op" "!=" start) (advance! 2) true))
-            ((at? "<=") (do (js-emit! "op" "<=" start) (advance! 2) true))
-            ((at? ">=") (do (js-emit! "op" ">=" start) (advance! 2) true))
-            ((at? "&&") (do (js-emit! "op" "&&" start) (advance! 2) true))
-            ((at? "||") (do (js-emit! "op" "||" start) (advance! 2) true))
-            ((at? "??") (do (js-emit! "op" "??" start) (advance! 2) true))
-            ((at? "=>") (do (js-emit! "op" "=>" start) (advance! 2) true))
-            ((at? "**") (do (js-emit! "op" "**" start) (advance! 2) true))
-            ((at? "<<") (do (js-emit! "op" "<<" start) (advance! 2) true))
-            ((at? ">>") (do (js-emit! "op" ">>" start) (advance! 2) true))
-            ((at? "++") (do (js-emit! "op" "++" start) (advance! 2) true))
-            ((at? "--") (do (js-emit! "op" "--" start) (advance! 2) true))
-            ((at? "+=") (do (js-emit! "op" "+=" start) (advance! 2) true))
-            ((at? "-=") (do (js-emit! "op" "-=" start) (advance! 2) true))
-            ((at? "*=") (do (js-emit! "op" "*=" start) (advance! 2) true))
-            ((at? "/=") (do (js-emit! "op" "/=" start) (advance! 2) true))
-            ((at? "%=") (do (js-emit! "op" "%=" start) (advance! 2) true))
-            ((at? "&=") (do (js-emit! "op" "&=" start) (advance! 2) true))
-            ((at? "|=") (do (js-emit! "op" "|=" start) (advance! 2) true))
-            ((at? "^=") (do (js-emit! "op" "^=" start) (advance! 2) true))
-            ((at? "?.") (do (js-emit! "op" "?." start) (advance! 2) true))
+            ((at? "==")
+              (do (js-emit! "op" "==" start) (advance! 2) true))
+            ((at? "!=")
+              (do (js-emit! "op" "!=" start) (advance! 2) true))
+            ((at? "<=")
+              (do (js-emit! "op" "<=" start) (advance! 2) true))
+            ((at? ">=")
+              (do (js-emit! "op" ">=" start) (advance! 2) true))
+            ((at? "&&")
+              (do (js-emit! "op" "&&" start) (advance! 2) true))
+            ((at? "||")
+              (do (js-emit! "op" "||" start) (advance! 2) true))
+            ((at? "??")
+              (do (js-emit! "op" "??" start) (advance! 2) true))
+            ((at? "=>")
+              (do (js-emit! "op" "=>" start) (advance! 2) true))
+            ((at? "**")
+              (do (js-emit! "op" "**" start) (advance! 2) true))
+            ((at? "<<")
+              (do (js-emit! "op" "<<" start) (advance! 2) true))
+            ((at? ">>")
+              (do (js-emit! "op" ">>" start) (advance! 2) true))
+            ((at? "++")
+              (do (js-emit! "op" "++" start) (advance! 2) true))
+            ((at? "--")
+              (do (js-emit! "op" "--" start) (advance! 2) true))
+            ((at? "+=")
+              (do (js-emit! "op" "+=" start) (advance! 2) true))
+            ((at? "-=")
+              (do (js-emit! "op" "-=" start) (advance! 2) true))
+            ((at? "*=")
+              (do (js-emit! "op" "*=" start) (advance! 2) true))
+            ((at? "/=")
+              (do (js-emit! "op" "/=" start) (advance! 2) true))
+            ((at? "%=")
+              (do (js-emit! "op" "%=" start) (advance! 2) true))
+            ((at? "&=")
+              (do (js-emit! "op" "&=" start) (advance! 2) true))
+            ((at? "|=")
+              (do (js-emit! "op" "|=" start) (advance! 2) true))
+            ((at? "^=")
+              (do (js-emit! "op" "^=" start) (advance! 2) true))
+            ((at? "?.")
+              (do (js-emit! "op" "?." start) (advance! 2) true))
             (else false))))
       (define
         emit-one-op!
         (fn
           (ch start)
           (cond
-            ((= ch "(") (do (js-emit! "punct" "(" start) (advance! 1)))
-            ((= ch ")") (do (js-emit! "punct" ")" start) (advance! 1)))
-            ((= ch "[") (do (js-emit! "punct" "[" start) (advance! 1)))
-            ((= ch "]") (do (js-emit! "punct" "]" start) (advance! 1)))
-            ((= ch "{") (do (js-emit! "punct" "{" start) (advance! 1)))
-            ((= ch "}") (do (js-emit! "punct" "}" start) (advance! 1)))
-            ((= ch ",") (do (js-emit! "punct" "," start) (advance! 1)))
-            ((= ch ";") (do (js-emit! "punct" ";" start) (advance! 1)))
-            ((= ch ":") (do (js-emit! "punct" ":" start) (advance! 1)))
-            ((= ch ".") (do (js-emit! "punct" "." start) (advance! 1)))
-            ((= ch "?") (do (js-emit! "op" "?" start) (advance! 1)))
-            ((= ch "+") (do (js-emit! "op" "+" start) (advance! 1)))
-            ((= ch "-") (do (js-emit! "op" "-" start) (advance! 1)))
-            ((= ch "*") (do (js-emit! "op" "*" start) (advance! 1)))
-            ((= ch "/") (do (js-emit! "op" "/" start) (advance! 1)))
-            ((= ch "%") (do (js-emit! "op" "%" start) (advance! 1)))
-            ((= ch "=") (do (js-emit! "op" "=" start) (advance! 1)))
-            ((= ch "<") (do (js-emit! "op" "<" start) (advance! 1)))
-            ((= ch ">") (do (js-emit! "op" ">" start) (advance! 1)))
-            ((= ch "!") (do (js-emit! "op" "!" start) (advance! 1)))
-            ((= ch "&") (do (js-emit! "op" "&" start) (advance! 1)))
-            ((= ch "|") (do (js-emit! "op" "|" start) (advance! 1)))
-            ((= ch "^") (do (js-emit! "op" "^" start) (advance! 1)))
-            ((= ch "~") (do (js-emit! "op" "~" start) (advance! 1)))
+            ((= ch "(")
+              (do (js-emit! "punct" "(" start) (advance! 1)))
+            ((= ch ")")
+              (do (js-emit! "punct" ")" start) (advance! 1)))
+            ((= ch "[")
+              (do (js-emit! "punct" "[" start) (advance! 1)))
+            ((= ch "]")
+              (do (js-emit! "punct" "]" start) (advance! 1)))
+            ((= ch "{")
+              (do (js-emit! "punct" "{" start) (advance! 1)))
+            ((= ch "}")
+              (do (js-emit! "punct" "}" start) (advance! 1)))
+            ((= ch ",")
+              (do (js-emit! "punct" "," start) (advance! 1)))
+            ((= ch ";")
+              (do (js-emit! "punct" ";" start) (advance! 1)))
+            ((= ch ":")
+              (do (js-emit! "punct" ":" start) (advance! 1)))
+            ((= ch ".")
+              (do (js-emit! "punct" "." start) (advance! 1)))
+            ((= ch "?")
+              (do (js-emit! "op" "?" start) (advance! 1)))
+            ((= ch "+")
+              (do (js-emit! "op" "+" start) (advance! 1)))
+            ((= ch "-")
+              (do (js-emit! "op" "-" start) (advance! 1)))
+            ((= ch "*")
+              (do (js-emit! "op" "*" start) (advance! 1)))
+            ((= ch "/")
+              (do (js-emit! "op" "/" start) (advance! 1)))
+            ((= ch "%")
+              (do (js-emit! "op" "%" start) (advance! 1)))
+            ((= ch "=")
+              (do (js-emit! "op" "=" start) (advance! 1)))
+            ((= ch "<")
+              (do (js-emit! "op" "<" start) (advance! 1)))
+            ((= ch ">")
+              (do (js-emit! "op" ">" start) (advance! 1)))
+            ((= ch "!")
+              (do (js-emit! "op" "!" start) (advance! 1)))
+            ((= ch "&")
+              (do (js-emit! "op" "&" start) (advance! 1)))
+            ((= ch "|")
+              (do (js-emit! "op" "|" start) (advance! 1)))
+            ((= ch "^")
+              (do (js-emit! "op" "^" start) (advance! 1)))
+            ((= ch "~")
+              (do (js-emit! "op" "~" start) (advance! 1)))
+            ((= ch "\\")
+              (error "Unexpected char '\\' in source"))
             (else (advance! 1)))))
       (define
         scan!
         (fn
           ()
           (do
+            (set! nl-before false)
             (skip-ws!)
             (when
               (< pos src-len)

lib/js/parser.sx

@@ -153,6 +153,32 @@
           (do (jp-advance! st) (list (quote js-ident) "this")))
         ((and (= (get t :type) "keyword") (= (get t :value) "new"))
           (do (jp-advance! st) (jp-parse-new-expr st)))
+        ((and (= (get t :type) "keyword") (= (get t :value) "function"))
+          (do
+            (jp-advance! st)
+            (let
+              ((nm
+                 (if
+                   (= (get (jp-peek st) :type) "ident")
+                   (let ((n (get (jp-peek st) :value))) (do (jp-advance! st) n))
+                   nil)))
+              (let
+                ((params (jp-parse-param-list st)))
+                (let
+                  ((body (jp-parse-fn-body st)))
+                  (list (quote js-funcexpr) nm params body))))))
+        ((and (= (get t :type) "keyword") (= (get t :value) "true"))
+          (do (jp-advance! st) (list (quote js-bool) true)))
+        ((and (= (get t :type) "keyword") (= (get t :value) "false"))
+          (do (jp-advance! st) (list (quote js-bool) false)))
+        ((and (= (get t :type) "keyword") (= (get t :value) "null"))
+          (do (jp-advance! st) (list (quote js-null))))
+        ((and (= (get t :type) "keyword") (= (get t :value) "undefined"))
+          (do (jp-advance! st) (list (quote js-undef))))
+        ((= (get t :type) "number")
+          (do (jp-advance! st) (list (quote js-num) (get t :value))))
+        ((= (get t :type) "string")
+          (do (jp-advance! st) (list (quote js-str) (get t :value))))
         ((and (= (get t :type) "punct") (= (get t :value) "("))
           (jp-parse-paren-or-arrow st))
         (else
@@ -211,7 +237,7 @@
               (let
                 ((params (jp-parse-param-list st)))
                 (let
-                  ((body (jp-parse-block st)))
+                  ((body (jp-parse-fn-body st)))
                   (list (quote js-funcexpr-async) nm params body))))))
         ((= (get t :type) "ident")
           (do
@@ -363,7 +389,7 @@
               (let
                 ((params (jp-parse-param-list st)))
                 (let
-                  ((body (jp-parse-block st)))
+                  ((body (jp-parse-fn-body st)))
                   (list (quote js-funcexpr) nm params body))))))
         ((= (get t :type) "ident")
           (do
@@ -418,16 +444,51 @@
               (dict-set! st :idx saved)
               (jp-advance! st)
               (let
-                ((e (jp-parse-assignment st)))
+                ((e (jp-parse-comma-seq st)))
                 (jp-expect! st "punct" ")")
-                e)))
+                (jp-paren-wrap e))))
           (do
             (dict-set! st :idx saved)
             (jp-advance! st)
             (let
-              ((e (jp-parse-assignment st)))
+              ((e (jp-parse-comma-seq st)))
               (jp-expect! st "punct" ")")
-              e)))))))
+              (jp-paren-wrap e))))))))
+
+(define
+  jp-paren-wrap
+  (fn
+    (e)
+    (cond
+      ((and (list? e) (= (first e) (quote js-unop)))
+        (list (quote js-paren) e))
+      (else e))))
+
+(define
+  jp-parse-comma-seq
+  (fn
+    (st)
+    (let
+      ((first-expr (jp-parse-assignment st)))
+      (if
+        (jp-at? st "punct" ",")
+        (jp-parse-comma-seq-rest st (list first-expr))
+        first-expr))))
+
+(define
+  jp-parse-comma-seq-rest
+  (fn
+    (st acc)
+    (do
+      (jp-advance! st)
+      (let
+        ((next-expr (jp-parse-assignment st)))
+        (let
+          ((acc2 (append acc (list next-expr))))
+          (if
+            (jp-at? st "punct" ",")
+            (jp-parse-comma-seq-rest st acc2)
+            (cons (quote js-comma) (list acc2))))))))
 
 (define
   jp-collect-params
@@ -485,6 +546,11 @@
     (st elems)
     (cond
       ((jp-at? st "punct" "]") nil)
+      ((jp-at? st "punct" ",")
+        (begin
+          (append! elems (list (quote js-undef)))
+          (jp-advance! st)
+          (jp-array-loop st elems)))
       (else
         (begin
           (cond
@@ -558,6 +624,20 @@
             (jp-advance! st)
             (jp-expect! st "punct" ":")
             (append! kvs {:value (jp-parse-assignment st) :key (get t :value)})))
+        ((and (= (get t :type) "punct") (= (get t :value) "["))
+          (do
+            (jp-advance! st)
+            (let
+              ((key-expr (jp-parse-assignment st)))
+              (jp-expect! st "punct" "]")
+              (jp-expect! st "punct" ":")
+              (append!
+                kvs
+                {:value (jp-parse-assignment st) :computed-key key-expr :key ""}))))
+        ((and (= (get t :type) "punct") (= (get t :value) "..."))
+          (do
+            (jp-advance! st)
+            (append! kvs {:spread (jp-parse-assignment st)})))
         (else (error (str "Unexpected in object: " (get t :type))))))))
 
 (define
@@ -629,7 +709,7 @@
                       st
                       (list (quote js-optchain-member) left (get t :value))))
                   (error "expected ident, [ or ( after ?.")))))))
-      ((or (jp-at? st "op" "++") (jp-at? st "op" "--"))
+      ((and (or (jp-at? st "op" "++") (jp-at? st "op" "--")) (not (jp-token-nl? st)))
         (let
           ((op (get (jp-peek st) :value)))
           (jp-advance! st)
@@ -682,6 +762,12 @@
             (cond
               ((< prec 0) left)
               ((< prec min-prec) left)
+              ((and (= op "**") (list? left) (= (first left) (quote js-unop)))
+                (error
+                  (str
+                    "SyntaxError: Unary operator '"
+                    (nth left 1)
+                    "' used immediately before exponentiation expression")))
               (else
                 (do
                   (jp-advance! st)
@@ -835,6 +921,12 @@
   jp-eat-semi
   (fn (st) (if (jp-at? st "punct" ";") (do (jp-advance! st) nil) nil)))
 
+(define
+  jp-token-nl?
+  (fn
+    (st)
+    (let ((tok (jp-peek st))) (if tok (= (get tok :nl) true) false))))
+
 (define
   jp-parse-vardecl
   (fn
@@ -1052,15 +1144,63 @@
         ((c (jp-parse-assignment st)))
         (do
           (jp-expect! st "punct" ")")
+          (jp-disallow-decl-stmt! st "if")
           (let
             ((t (jp-parse-stmt st)))
             (if
               (jp-at? st "keyword" "else")
               (do
                 (jp-advance! st)
+                (jp-disallow-decl-stmt! st "else")
                 (list (quote js-if) c t (jp-parse-stmt st)))
               (list (quote js-if) c t nil))))))))
 
+(define
+  jp-disallow-decl-stmt!
+  (fn
+    (st context)
+    (let
+      ((t (jp-peek st)))
+      (cond
+        ((and (= (get t :type) "keyword")
+              (or (= (get t :value) "let")
+                  (= (get t :value) "const")
+                  (= (get t :value) "function")
+                  (= (get t :value) "class")))
+          (cond
+            ((and (= (get t :value) "let")
+                  (or (= (get (jp-peek-at st 1) :type) "ident")
+                      (and (= (get (jp-peek-at st 1) :type) "punct")
+                           (or (= (get (jp-peek-at st 1) :value) "[")
+                               (= (get (jp-peek-at st 1) :value) "{")))))
+              (error
+                (str
+                  "SyntaxError: Lexical declaration cannot appear in single-statement context: "
+                  context)))
+            ((or (= (get t :value) "const")
+                 (= (get t :value) "function")
+                 (= (get t :value) "class"))
+              (error
+                (str
+                  "SyntaxError: "
+                  (get t :value)
+                  " declaration cannot appear in single-statement context: "
+                  context)))
+            (else nil)))
+        (else nil)))))
+
+(define
+  jp-bump!
+  (fn
+    (st key)
+    (dict-set! st key (+ (get st key) 1))))
+
+(define
+  jp-decr!
+  (fn
+    (st key)
+    (dict-set! st key (- (get st key) 1))))
+
 (define
   jp-parse-while-stmt
   (fn
@@ -1072,7 +1212,11 @@
         ((c (jp-parse-assignment st)))
         (do
           (jp-expect! st "punct" ")")
-          (let ((body (jp-parse-stmt st))) (list (quote js-while) c body)))))))
+          (jp-disallow-decl-stmt! st "while")
+          (jp-bump! st :loop-depth)
+          (let ((body (jp-parse-stmt st)))
+            (jp-decr! st :loop-depth)
+            (list (quote js-while) c body)))))))
 
 (define
   jp-parse-do-while-stmt
@@ -1080,8 +1224,11 @@
     (st)
     (do
       (jp-advance! st)
+      (jp-disallow-decl-stmt! st "do")
+      (jp-bump! st :loop-depth)
       (let
         ((body (jp-parse-stmt st)))
+        (jp-decr! st :loop-depth)
         (do
           (if
             (jp-at? st "keyword" "while")
@@ -1126,8 +1273,11 @@
                   (let
                     ((iter (jp-parse-assignment st)))
                     (jp-expect! st "punct" ")")
+                    (jp-disallow-decl-stmt! st "for-of/in")
+                    (jp-bump! st :loop-depth)
                     (let
                       ((body (jp-parse-stmt st)))
+                      (jp-decr! st :loop-depth)
                       (list (quote js-for-of-in) iter-kind ident iter body)))))))
           (else
             (let
@@ -1138,8 +1288,11 @@
                 (let
                   ((step (if (jp-at? st "punct" ")") nil (jp-parse-assignment st))))
                   (jp-expect! st "punct" ")")
+                  (jp-disallow-decl-stmt! st "for")
+                  (jp-bump! st :loop-depth)
                   (let
                     ((body (jp-parse-stmt st)))
+                    (jp-decr! st :loop-depth)
                     (list (quote js-for) init cond-ast step body)))))))))))
 
 (define
@@ -1162,10 +1315,14 @@
     (st)
     (do
       (jp-advance! st)
+      (when
+        (= (get st :fn-depth) 0)
+        (error "SyntaxError: Illegal return statement"))
       (if
         (or
           (jp-at? st "punct" ";")
           (jp-at? st "punct" "}")
+          (jp-token-nl? st)
           (jp-at? st "eof" nil))
         (do (jp-eat-semi st) (list (quote js-return) nil))
         (let
@@ -1188,7 +1345,7 @@
           (let
             ((params (jp-parse-param-list st)))
             (let
-              ((body (jp-parse-block st)))
+              ((body (jp-parse-fn-body st)))
               (list (quote js-funcdecl) nm params body))))))))
 
 (define
@@ -1207,7 +1364,7 @@
           (let
             ((params (jp-parse-param-list st)))
             (let
-              ((body (jp-parse-block st)))
+              ((body (jp-parse-fn-body st)))
               (list (quote js-funcdecl-async) nm params body))))))))
 
 (define
@@ -1256,7 +1413,7 @@
           (let
             ((params (jp-parse-param-list st)))
             (let
-              ((body (jp-parse-block st)))
+              ((body (jp-parse-fn-body st)))
               (list
                 (quote js-method)
                 (if static? "static" "instance")
@@ -1284,9 +1441,11 @@
       ((disc (jp-parse-assignment st)))
       (jp-expect! st "punct" ")")
       (jp-expect! st "punct" "{")
+      (jp-bump! st :switch-depth)
       (let
         ((cases (list)))
         (jp-parse-switch-cases st cases)
+        (jp-decr! st :switch-depth)
         (jp-expect! st "punct" "}")
         (list (quote js-switch) disc cases)))))
 
@@ -1362,9 +1521,40 @@
       ((jp-at? st "keyword" "for") (jp-parse-for-stmt st))
       ((jp-at? st "keyword" "return") (jp-parse-return-stmt st))
       ((jp-at? st "keyword" "break")
-        (do (jp-advance! st) (jp-eat-semi st) (list (quote js-break))))
+        (do
+          (jp-advance! st)
+          (cond
+            ((= (get (jp-peek st) :type) "ident")
+              (do (jp-advance! st) (jp-eat-semi st) (list (quote js-break))))
+            (else
+              (do
+                (when
+                  (and (= (get st :loop-depth) 0) (= (get st :switch-depth) 0))
+                  (error "SyntaxError: Illegal break statement"))
+                (jp-eat-semi st)
+                (list (quote js-break)))))))
       ((jp-at? st "keyword" "continue")
-        (do (jp-advance! st) (jp-eat-semi st) (list (quote js-continue))))
+        (do
+          (jp-advance! st)
+          (cond
+            ((= (get (jp-peek st) :type) "ident")
+              (do (jp-advance! st) (jp-eat-semi st) (list (quote js-continue))))
+            (else
+              (do
+                (when
+                  (= (get st :loop-depth) 0)
+                  (error "SyntaxError: Illegal continue statement"))
+                (jp-eat-semi st)
+                (list (quote js-continue)))))))
+      ((and
+         (= (get (jp-peek st) :type) "ident")
+         (= (get (jp-peek-at st 1) :type) "punct")
+         (= (get (jp-peek-at st 1) :value) ":"))
+        (do
+          (jp-advance! st)
+          (jp-advance! st)
+          (jp-disallow-decl-stmt! st "label")
+          (jp-parse-stmt st)))
       ((jp-at? st "keyword" "class") (jp-parse-class-decl st))
       ((jp-at? st "keyword" "throw") (jp-parse-throw-stmt st))
       ((jp-at? st "keyword" "try") (jp-parse-try-stmt st))
@@ -1374,7 +1564,7 @@
       ((jp-at? st "keyword" "switch") (jp-parse-switch-stmt st))
       (else
         (let
-          ((e (jp-parse-assignment st)))
+          ((e (jp-parse-comma-seq st)))
           (do (jp-eat-semi st) (list (quote js-exprstmt) e)))))))
 
 (define
@@ -1400,10 +1590,33 @@
   jp-parse-arrow-body
   (fn
     (st)
-    (if
-      (jp-at? st "punct" "{")
-      (jp-parse-block st)
-      (jp-parse-assignment st))))
+    (jp-bump! st :fn-depth)
+    (let
+      ((saved-loop (get st :loop-depth)) (saved-switch (get st :switch-depth)))
+      (dict-set! st :loop-depth 0)
+      (dict-set! st :switch-depth 0)
+      (let
+        ((body (if (jp-at? st "punct" "{") (jp-parse-block st) (jp-parse-assignment st))))
+        (jp-decr! st :fn-depth)
+        (dict-set! st :loop-depth saved-loop)
+        (dict-set! st :switch-depth saved-switch)
+        body))))
+
+(define
+  jp-parse-fn-body
+  (fn
+    (st)
+    (jp-bump! st :fn-depth)
+    (let
+      ((saved-loop (get st :loop-depth)) (saved-switch (get st :switch-depth)))
+      (dict-set! st :loop-depth 0)
+      (dict-set! st :switch-depth 0)
+      (let
+        ((body (jp-parse-block st)))
+        (jp-decr! st :fn-depth)
+        (dict-set! st :loop-depth saved-loop)
+        (dict-set! st :switch-depth saved-switch)
+        body))))
 
 (define
   js-parse
@@ -1414,7 +1627,7 @@
         (= (len tokens) 0)
         (and (= (len tokens) 1) (= (get (nth tokens 0) :type) "eof")))
       (list (quote js-program) (list))
-      (let ((st {:idx 0 :tokens tokens :arrow-candidate true})) (jp-parse-program st)))))
+      (let ((st {:idx 0 :tokens tokens :arrow-candidate true :loop-depth 0 :switch-depth 0 :fn-depth 0})) (jp-parse-program st)))))
 
 (define
   js-parse-expr
@@ -1427,4 +1640,4 @@
           (= (len tokens) 0)
           (and (= (len tokens) 1) (= (get (nth tokens 0) :type) "eof")))
         (list)
-        (let ((st {:idx 0 :tokens tokens :arrow-candidate true})) (jp-parse-assignment st))))))
+        (let ((st {:idx 0 :tokens tokens :arrow-candidate true :loop-depth 0 :switch-depth 0 :fn-depth 0})) (jp-parse-assignment st))))))

lib/js/test.sh

@@ -1486,6 +1486,24 @@ cat > "$TMPFILE" << 'EPOCHS'
 (eval "(get (RegExp \"hello\" \"gi\") \"global\")")
 (epoch 6032)
 (eval "(get (RegExp \"foo\" \"i\") \"ignoreCase\")")
+;; ── Phase 1.ASI: automatic semicolon insertion ─────────────────
+(epoch 4200)
+(eval "(js-eval \"function f() { return\n42\n} f()\")")
+(epoch 4201)
+(eval "(js-eval \"function g() { return 42 } g()\")")
+(epoch 4202)
+(eval "(let ((toks (js-tokenize \"a\nb\"))) (get (nth toks 1) :nl))")
+(epoch 4203)
+(eval "(let ((toks (js-tokenize \"a b\"))) (get (nth toks 1) :nl))")
+
+(epoch 4300)
+(eval "(js-eval \"var x = 5; x\")")
+(epoch 4301)
+(eval "(js-eval \"function f() { return x; var x = 42; } f()\")")
+(epoch 4302)
+(eval "(js-eval \"function f() { var y = 7; return y; } f()\")")
+(epoch 4303)
+(eval "(js-eval \"function f() { var z; z = 3; return z; } f()\")")
 
 EPOCHS
 
@@ -2280,6 +2298,16 @@ check 6025 "set delete→size 0"     '0'
 check 6030 "RegExp? result"        'true'
 check 6031 "RegExp global flag"    'true'
 check 6032 "RegExp ignoreCase"     'true'
+# ── Phase 1.ASI: automatic semicolon insertion ────────────────────
+check 4200 "return+newline → undefined"    '"js-undefined"'
+check 4201 "return+space+val → val"        '42'
+check 4202 "nl-before flag set after newline" 'true'
+check 4203 "nl-before flag false on same line" 'false'
+
+check 4300 "var decl program-level"         '5'
+check 4301 "var hoisted before use → undef" '"js-undefined"'
+check 4302 "var in function body"           '7'
+check 4303 "var then set in function"       '3'
 
 TOTAL=$((PASS + FAIL))
 if [ $FAIL -eq 0 ]; then

lib/js/test262-runner.py

@@ -52,7 +52,7 @@ UPSTREAM = REPO / "lib" / "js" / "test262-upstream"
 TEST_ROOT = UPSTREAM / "test"
 HARNESS_DIR = UPSTREAM / "harness"
 
-DEFAULT_PER_TEST_TIMEOUT_S = 5.0
+DEFAULT_PER_TEST_TIMEOUT_S = 15.0
 DEFAULT_BATCH_TIMEOUT_S = 120
 
 # Cache dir for precomputed SX source of harness JS (one file per Python run).
@@ -134,6 +134,9 @@ var verifyProperty = function (obj, name, desc, opts) {
   }
 };
 var verifyPrimordialProperty = verifyProperty;
+var verifyEqualTo = function (obj, name, value) {
+  assert.sameValue(obj[name], value, name + " equals");
+};
 var verifyNotEnumerable = function (o, n, v, w, x) { };
 var verifyNotWritable = function (o, n, v, w, x) { };
 var verifyNotConfigurable = function (o, n, v, w, x) { };
@@ -146,6 +149,50 @@ var isConstructor = function (f) {
   // Best-effort: built-in functions and arrows aren't; declared `function` decls are.
   return false;
 };
+// $DONE / asyncTest — async-flag tests call $DONE(err) to signal completion.
+// Since we drain microtasks synchronously, $DONE is just a final-assertion sink.
+var $DONE = function (err) {
+  if (err) { throw new Test262Error((err && err.message) || err); }
+};
+var asyncTest = function (testFunc) {
+  Promise.resolve(testFunc()).then(function () { $DONE(); }, function (e) { $DONE(e); });
+};
+// promiseHelper.js include — used by Promise.all/race tests for ordering checks.
+var checkSequence = function (arr, message) {
+  for (var i = 0; i < arr.length; i = i + 1) {
+    if (arr[i] !== (i + 1)) {
+      throw new Test262Error((message || "Sequence") + " expected " + (i+1) + " at index " + i + " but got " + arr[i]);
+    }
+  }
+  return true;
+};
+var checkSettledPromises = function (settleds, expected, message) {
+  var msg = message ? message + " " : "";
+  if (settleds.length !== expected.length) {
+    throw new Test262Error(msg + "lengths differ: " + settleds.length + " vs " + expected.length);
+  }
+  for (var i = 0; i < settleds.length; i = i + 1) {
+    if (settleds[i].status !== expected[i].status) {
+      throw new Test262Error(msg + "status[" + i + "]: " + settleds[i].status + " vs " + expected[i].status);
+    }
+    if (expected[i].status === "fulfilled" && settleds[i].value !== expected[i].value) {
+      throw new Test262Error(msg + "value[" + i + "]: " + settleds[i].value + " vs " + expected[i].value);
+    }
+    if (expected[i].status === "rejected" && settleds[i].reason !== expected[i].reason) {
+      throw new Test262Error(msg + "reason[" + i + "]: " + settleds[i].reason + " vs " + expected[i].reason);
+    }
+  }
+};
+// decimalToHexString.js include — used by URI/escape tests.
+var decimalToHexString = function (n) {
+  var hex = "0123456789ABCDEF";
+  if (n < 0) { n = n + 65536; }
+  return hex[(n >> 12) & 15] + hex[(n >> 8) & 15] + hex[(n >> 4) & 15] + hex[n & 15];
+};
+var decimalToPercentHexString = function (n) {
+  var hex = "0123456789ABCDEF";
+  return "%" + hex[(n >> 4) & 15] + hex[n & 15];
+};
 // Trivial helper for tests that use Array.isArray-like functionality
 // (many tests reach for it via compareArray)
 """
@@ -358,6 +405,8 @@ def classify_negative_result(fm: Frontmatter, kind: str, payload: str):
             or ("expected" in low and "got" in low)
             or "js-transpile-unop" in low
             or "js-transpile-binop" in low
+            or "js-transpile-assign" in low
+            or "js-transpile" in low
             or "js-compound-update" in low
             or "parse" in low
         ):
@@ -1012,11 +1061,45 @@ def _worker_run(args):
 # ---------------------------------------------------------------------------
 
 
+_HARNESS_INCLUDE_CACHE: dict = {}
+
+# Only inline these small harness files per-test. Large ones like propertyHelper.js
+# multiply js-eval/JIT cost by ~5-10x and push tests over the per-test timeout.
+_INLINE_INCLUDES = {"nans.js", "sta.js", "byteConversionValues.js", "compareArray.js"}
+
+
+def _load_harness_include(name: str) -> str:
+    """Read an upstream harness include file (e.g. nans.js).
+    Returns empty string if the file isn't present.
+    """
+    if name in _HARNESS_INCLUDE_CACHE:
+        return _HARNESS_INCLUDE_CACHE[name]
+    path = HARNESS_DIR / name
+    try:
+        src = path.read_text()
+    except OSError:
+        src = ""
+    _HARNESS_INCLUDE_CACHE[name] = src
+    return src
+
+
 def assemble_source(t):
     """Return JS source to feed to js-eval. Harness is preloaded, so we only
-    append the test source (plus negative-test prep if needed).
+    append the test source (plus a small allowlist of per-test includes).
     """
-    return t.src
+    if not getattr(t.fm, "includes", None):
+        return t.src
+    parts = []
+    for inc in t.fm.includes:
+        if inc not in _INLINE_INCLUDES:
+            continue
+        chunk = _load_harness_include(inc)
+        if chunk:
+            parts.append(chunk)
+    if not parts:
+        return t.src
+    parts.append(t.src)
+    return "\n".join(parts)
 
 
 def aggregate(results):
@@ -1194,7 +1277,7 @@ def main(argv):
     shards = [[] for _ in range(n_workers)]
     for i, t in enumerate(tests):
         shards[i % n_workers].append(
-            (t.rel, t.category, t.src, t.fm.negative_phase, t.fm.negative_type)
+            (t.rel, t.category, assemble_source(t), t.fm.negative_phase, t.fm.negative_type)
         )
 
     t_run_start = time.monotonic()

lib/js/test262-scoreboard.json

@@ -1,137 +1,53 @@
 {
   "totals": {
-    "pass": 162,
-    "fail": 128,
-    "skip": 1597,
-    "timeout": 10,
-    "total": 1897,
-    "runnable": 300,
-    "pass_rate": 54.0
+    "pass": 4,
+    "fail": 10,
+    "skip": 16,
+    "timeout": 0,
+    "total": 30,
+    "runnable": 14,
+    "pass_rate": 28.6
   },
   "categories": [
     {
-      "category": "built-ins/Math",
-      "total": 327,
-      "pass": 43,
-      "fail": 56,
-      "skip": 227,
-      "timeout": 1,
-      "pass_rate": 43.0,
+      "category": "built-ins/Function",
+      "total": 30,
+      "pass": 4,
+      "fail": 10,
+      "skip": 16,
+      "timeout": 0,
+      "pass_rate": 28.6,
       "top_failures": [
         [
-          "TypeError: not a function",
-          36
-        ],
-        [
-          "Test262Error (assertion failed)",
-          20
-        ],
-        [
-          "Timeout",
-          1
-        ]
-      ]
-    },
-    {
-      "category": "built-ins/Number",
-      "total": 340,
-      "pass": 77,
-      "fail": 19,
-      "skip": 240,
-      "timeout": 4,
-      "pass_rate": 77.0,
-      "top_failures": [
-        [
-          "Test262Error (assertion failed)",
-          19
-        ],
-        [
-          "Timeout",
+          "SyntaxError (parse/unsupported syntax)",
           4
-        ]
-      ]
-    },
-    {
-      "category": "built-ins/String",
-      "total": 1223,
-      "pass": 42,
-      "fail": 53,
-      "skip": 1123,
-      "timeout": 5,
-      "pass_rate": 42.0,
-      "top_failures": [
-        [
-          "Test262Error (assertion failed)",
-          44
-        ],
-        [
-          "Timeout",
-          5
         ],
         [
           "ReferenceError (undefined symbol)",
-          2
+          3
         ],
         [
-          "Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)",
-          2
-        ],
-        [
-          "Unhandled: Not callable: \\\\\\",
-          2
+          "TypeError (other)",
+          3
         ]
       ]
-    },
-    {
-      "category": "built-ins/StringIteratorPrototype",
-      "total": 7,
-      "pass": 0,
-      "fail": 0,
-      "skip": 7,
-      "timeout": 0,
-      "pass_rate": 0.0,
-      "top_failures": []
     }
   ],
   "top_failure_modes": [
     [
-      "Test262Error (assertion failed)",
-      83
-    ],
-    [
-      "TypeError: not a function",
-      36
-    ],
-    [
-      "Timeout",
-      10
+      "SyntaxError (parse/unsupported syntax)",
+      4
     ],
     [
       "ReferenceError (undefined symbol)",
-      2
+      3
     ],
     [
-      "Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)",
-      2
-    ],
-    [
-      "Unhandled: Not callable: \\\\\\",
-      2
-    ],
-    [
-      "SyntaxError (parse/unsupported syntax)",
-      1
-    ],
-    [
-      "Unhandled: Not callable: {:__proto__ {:valueOf <lambda()> :propertyIsEn",
-      1
-    ],
-    [
-      "Unhandled: js-transpile-binop: unsupported op: >>>\\",
-      1
+      "TypeError (other)",
+      3
     ]
   ],
   "pinned_commit": "d5e73fc8d2c663554fb72e2380a8c2bc1a318a33",
-  "elapsed_seconds": 274.5,
+  "elapsed_seconds": 11.2,
   "workers": 1
 }

lib/js/test262-scoreboard.md

@@ -1,47 +1,26 @@
 # test262 scoreboard
 
 Pinned commit: `d5e73fc8d2c663554fb72e2380a8c2bc1a318a33`
-Wall time: 274.5s
+Wall time: 11.2s
 
-**Total:** 162/300 runnable passed (54.0%). Raw: pass=162 fail=128 skip=1597 timeout=10 total=1897.
+**Total:** 4/14 runnable passed (28.6%). Raw: pass=4 fail=10 skip=16 timeout=0 total=30.
 
 ## Top failure modes
 
-- **83x** Test262Error (assertion failed)
-- **36x** TypeError: not a function
-- **10x** Timeout
-- **2x** ReferenceError (undefined symbol)
-- **2x** Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)
-- **2x** Unhandled: Not callable: \\\
-- **1x** SyntaxError (parse/unsupported syntax)
-- **1x** Unhandled: Not callable: {:__proto__ {:valueOf <lambda()> :propertyIsEn
-- **1x** Unhandled: js-transpile-binop: unsupported op: >>>\
+- **4x** SyntaxError (parse/unsupported syntax)
+- **3x** ReferenceError (undefined symbol)
+- **3x** TypeError (other)
 
 ## Categories (worst pass-rate first, min 10 runnable)
 
 | Category | Pass | Fail | Skip | Timeout | Total | Pass % |
 |---|---:|---:|---:|---:|---:|---:|
-| built-ins/String | 42 | 53 | 1123 | 5 | 1223 | 42.0% |
-| built-ins/Math | 43 | 56 | 227 | 1 | 327 | 43.0% |
-| built-ins/Number | 77 | 19 | 240 | 4 | 340 | 77.0% |
+| built-ins/Function | 4 | 10 | 16 | 0 | 30 | 28.6% |
 
 ## Per-category top failures (min 10 runnable, worst first)
 
-### built-ins/String  (42/100 — 42.0%)
+### built-ins/Function  (4/14 — 28.6%)
 
-- **44x** Test262Error (assertion failed)
-- **5x** Timeout
-- **2x** ReferenceError (undefined symbol)
-- **2x** Unhandled: Not callable: {:__proto__ {:toLowerCase <lambda(&rest, args)
-- **2x** Unhandled: Not callable: \\\
-
-### built-ins/Math  (43/100 — 43.0%)
-
-- **36x** TypeError: not a function
-- **20x** Test262Error (assertion failed)
-- **1x** Timeout
-
-### built-ins/Number  (77/100 — 77.0%)
-
-- **19x** Test262Error (assertion failed)
-- **4x** Timeout
+- **4x** SyntaxError (parse/unsupported syntax)
+- **3x** ReferenceError (undefined symbol)
+- **3x** TypeError (other)

lib/js/transpile.sx

@@ -98,6 +98,7 @@
             (list (js-sym "js-regex-new") (nth ast 1) (nth ast 2)))
           ((js-tag? ast "js-null") nil)
           ((js-tag? ast "js-undef") (list (js-sym "quote") :js-undefined))
+          ((js-tag? ast "js-paren") (js-transpile (nth ast 1)))
           ((js-tag? ast "js-ident") (js-transpile-ident (nth ast 1)))
           ((js-tag? ast "js-unop")
             (js-transpile-unop (nth ast 1) (nth ast 2)))
@@ -116,7 +117,8 @@
           ((js-tag? ast "js-arrow")
             (js-transpile-arrow (nth ast 1) (nth ast 2)))
           ((js-tag? ast "js-program") (js-transpile-stmts (nth ast 1)))
-          ((js-tag? ast "js-block") (js-transpile-stmts (nth ast 1)))
+          ((js-tag? ast "js-block")
+            (cons (js-sym "begin") (js-transpile-stmt-list (nth ast 1))))
           ((js-tag? ast "js-exprstmt") (js-transpile (nth ast 1)))
           ((js-tag? ast "js-empty") nil)
           ((js-tag? ast "js-var")
@@ -164,6 +166,8 @@
             (js-transpile-new (nth ast 1) (nth ast 2)))
           ((js-tag? ast "js-class")
             (js-transpile-class (nth ast 1) (nth ast 2) (nth ast 3)))
+          ((js-tag? ast "js-comma")
+            (cons (js-sym "begin") (map js-transpile (nth ast 1))))
           ((js-tag? ast "js-throw") (js-transpile-throw (nth ast 1)))
           ((js-tag? ast "js-try")
             (js-transpile-try (nth ast 1) (nth ast 2) (nth ast 3)))
@@ -221,7 +225,23 @@
               (js-sym "js-delete-prop")
               (js-transpile (nth arg 1))
               (js-transpile (nth arg 2))))
+          ((js-tag? arg "js-ident") false)
+          ((js-tag? arg "js-paren") (js-transpile-unop op (nth arg 1)))
           (else true)))
+      ((and (= op "typeof") (js-tag? arg "js-ident"))
+        (let
+          ((name (nth arg 1)))
+          (list
+            (js-sym "if")
+            (list
+              (js-sym "or")
+              (list
+                (js-sym "env-has?")
+                (list (js-sym "current-env"))
+                name)
+              (list (js-sym "dict-has?") (js-sym "js-global") name))
+            (list (js-sym "js-typeof") (js-transpile arg))
+            "undefined")))
       (else
         (let
           ((a (js-transpile arg)))
@@ -231,7 +251,8 @@
             ((= op "!") (list (js-sym "js-not") a))
             ((= op "~") (list (js-sym "js-bitnot") a))
             ((= op "typeof") (list (js-sym "js-typeof") a))
-            ((= op "void") (list (js-sym "quote") :js-undefined))
+            ((= op "void")
+              (list (js-sym "begin") a (list (js-sym "quote") :js-undefined)))
             (else (error (str "js-transpile-unop: unsupported op: " op)))))))))
 
 ;; ── Array literal ─────────────────────────────────────────────────
@@ -295,6 +316,21 @@
               (list (js-sym "js-undefined?") (js-sym "_a")))
             (js-transpile r)
             (js-sym "_a"))))
+      ((= op ">>>")
+        (list
+          (js-sym "js-unsigned-rshift")
+          (js-transpile l)
+          (js-transpile r)))
+      ((= op "<<")
+        (list (js-sym "js-shl") (js-transpile l) (js-transpile r)))
+      ((= op ">>")
+        (list (js-sym "js-shr") (js-transpile l) (js-transpile r)))
+      ((= op "&")
+        (list (js-sym "js-bitand") (js-transpile l) (js-transpile r)))
+      ((= op "|")
+        (list (js-sym "js-bitor") (js-transpile l) (js-transpile r)))
+      ((= op "^")
+        (list (js-sym "js-bitxor") (js-transpile l) (js-transpile r)))
       (else (error (str "js-transpile-binop: unsupported op: " op))))))
 
 ;; ── Object literal ────────────────────────────────────────────────
@@ -373,7 +409,19 @@
     (list
       (js-sym "js-new-call")
       (js-transpile callee)
-      (cons (js-sym "list") (map js-transpile args)))))
+      (cond
+        ((js-has-spread? args)
+          (cons
+            (js-sym "js-array-spread-build")
+            (map
+              (fn
+                (e)
+                (if
+                  (js-tag? e "js-spread")
+                  (list (js-sym "list") "js-spread" (js-transpile (nth e 1)))
+                  (list (js-sym "list") "js-value" (js-transpile e))))
+              args)))
+        (else (cons (js-sym "js-args") (map js-transpile args)))))))
 
 (define
   js-transpile-array
@@ -391,7 +439,7 @@
               (list (js-sym "list") "js-spread" (js-transpile (nth e 1)))
               (list (js-sym "list") "js-value" (js-transpile e))))
           elts))
-      (cons (js-sym "list") (map js-transpile elts)))))
+      (cons (js-sym "js-make-list") (map js-transpile elts)))))
 
 (define
   js-has-spread?
@@ -421,7 +469,7 @@
               (list (js-sym "list") "js-spread" (js-transpile (nth e 1)))
               (list (js-sym "list") "js-value" (js-transpile e))))
           args))
-      (cons (js-sym "list") (map js-transpile args)))))
+      (cons (js-sym "js-args") (map js-transpile args)))))
 
 ;; Transpile a JS expression string to SX source text (for inspection
 ;; in tests). Useful for asserting the exact emitted tree.
@@ -431,18 +479,28 @@
     (entries)
     (list
       (js-sym "let")
-      (list (list (js-sym "_obj") (list (js-sym "dict"))))
+      (list (list (js-sym "_obj") (list (js-sym "js-make-obj"))))
       (cons
         (js-sym "begin")
         (append
           (map
             (fn
               (entry)
-              (list
-                (js-sym "dict-set!")
-                (js-sym "_obj")
-                (get entry :key)
-                (js-transpile (get entry :value))))
+              (cond
+                ((contains? (keys entry) :spread)
+                  (list
+                    (js-sym "js-obj-spread!")
+                    (js-sym "_obj")
+                    (js-transpile (get entry :spread))))
+                (else
+                  (list
+                    (js-sym "js-obj-set!")
+                    (js-sym "_obj")
+                    (if
+                      (contains? (keys entry) :computed-key)
+                      (list (js-sym "js-to-string") (js-transpile (get entry :computed-key)))
+                      (get entry :key))
+                    (js-transpile (get entry :value))))))
             entries)
           (list (js-sym "_obj")))))))
 
@@ -486,6 +544,95 @@
                 (append inits (list (js-transpile body))))))))
       (list (js-sym "fn") param-syms body-tr))))
 
+(define
+  js-collect-var-decl-names
+  (fn
+    (decls)
+    (cond
+      ((empty? decls) (list))
+      ((js-tag? (first decls) "js-vardecl")
+        (cons
+          (nth (first decls) 1)
+          (js-collect-var-decl-names (rest decls))))
+      (else (js-collect-var-decl-names (rest decls))))))
+
+(define
+  js-collect-var-names
+  (fn
+    (stmts)
+    (cond
+      ((empty? stmts) (list))
+      (else
+        (append
+          (js-collect-var-names-stmt (first stmts))
+          (js-collect-var-names (rest stmts)))))))
+
+(define
+  js-collect-var-names-stmt
+  (fn
+    (stmt)
+    (cond
+      ((not (list? stmt)) (list))
+      ((and (js-tag? stmt "js-var") (= (nth stmt 1) "var"))
+        (js-collect-var-decl-names (nth stmt 2)))
+      ((js-tag? stmt "js-block") (js-collect-var-names (nth stmt 1)))
+      ((js-tag? stmt "js-for")
+        (append
+          (js-collect-var-names-stmt (nth stmt 1))
+          (js-collect-var-names-stmt (nth stmt 4))))
+      ((js-tag? stmt "js-for-of-in")
+        (js-collect-var-names-stmt (nth stmt 4)))
+      ((js-tag? stmt "js-while")
+        (js-collect-var-names-stmt (nth stmt 2)))
+      ((js-tag? stmt "js-do-while")
+        (js-collect-var-names-stmt (nth stmt 1)))
+      ((js-tag? stmt "js-if")
+        (append
+          (js-collect-var-names-stmt (nth stmt 2))
+          (if (>= (len stmt) 4) (js-collect-var-names-stmt (nth stmt 3)) (list))))
+      ((js-tag? stmt "js-try")
+        (append
+          (js-collect-var-names-stmt (nth stmt 1))
+          (if (and (>= (len stmt) 3) (list? (nth stmt 2)))
+              (js-collect-var-names-stmt (nth (nth stmt 2) 2))
+              (list))
+          (if (>= (len stmt) 4) (js-collect-var-names-stmt (nth stmt 3)) (list))))
+      ((js-tag? stmt "js-switch")
+        (js-collect-var-names-cases (nth stmt 2)))
+      (else (list)))))
+
+(define
+  js-collect-var-names-cases
+  (fn
+    (cases)
+    (cond
+      ((empty? cases) (list))
+      (else
+        (append
+          (js-collect-var-names (nth (first cases) 2))
+          (js-collect-var-names-cases (rest cases)))))))
+
+(define
+  js-dedup-names
+  (fn
+    (names seen)
+    (cond
+      ((empty? names) (list))
+      ((some (fn (s) (= s (first names))) seen)
+        (js-dedup-names (rest names) seen))
+      (else
+        (cons
+          (first names)
+          (js-dedup-names (rest names) (cons (first names) seen)))))))
+
+(define
+  js-var-hoist-forms
+  (fn
+    (names)
+    (map
+      (fn (name) (list (js-sym "define") (js-sym name) :js-undefined))
+      names)))
+
 (define
   js-transpile-tpl
   (fn
@@ -577,6 +724,12 @@
             (list (js-sym "js-undefined?") lhs-expr))
           rhs-expr
           lhs-expr))
+      ((= op "<<=") (list (js-sym "js-shl") lhs-expr rhs-expr))
+      ((= op ">>=") (list (js-sym "js-shr") lhs-expr rhs-expr))
+      ((= op ">>>=") (list (js-sym "js-unsigned-rshift") lhs-expr rhs-expr))
+      ((= op "&=") (list (js-sym "js-bitand") lhs-expr rhs-expr))
+      ((= op "|=") (list (js-sym "js-bitor") lhs-expr rhs-expr))
+      ((= op "^=") (list (js-sym "js-bitxor") lhs-expr rhs-expr))
       (else (error (str "js-compound-update: unsupported op: " op))))))
 
 (define
@@ -806,7 +959,7 @@
                 (if
                   (= iter-kind "of")
                   (list (js-sym "js-iterable-to-list") iter-sx)
-                  (list (js-sym "js-object-keys") iter-sx))))
+                  (list (js-sym "js-for-in-keys") iter-sx))))
             (list
               (js-sym "for-each")
               (list
@@ -835,7 +988,7 @@
   (fn
     (params)
     (cond
-      ((empty? params) (list))
+      ((empty? params) (list (js-sym "&rest") (js-sym "__extra_args__")))
       ((and (list? (first params)) (js-tag? (first params) "js-rest"))
         (list (js-sym "&rest") (js-sym (nth (first params) 1))))
       (else
@@ -843,6 +996,27 @@
           (js-param-sym (first params))
           (js-build-param-list (rest params)))))))
 
+(define
+  js-arguments-build-form
+  (fn
+    (params)
+    (list (js-sym "js-list-copy") (js-arguments-build-form-raw params))))
+
+(define
+  js-arguments-build-form-raw
+  (fn
+    (params)
+    (cond
+      ((empty? params)
+        (js-sym "__extra_args__"))
+      ((and (list? (first params)) (js-tag? (first params) "js-rest"))
+        (js-sym (nth (first params) 1)))
+      (else
+        (list
+          (js-sym "cons")
+          (js-param-sym (first params))
+          (js-arguments-build-form-raw (rest params)))))))
+
 (define
   js-param-init-forms
   (fn
@@ -876,7 +1050,7 @@
   (fn
     (stmts)
     (let
-      ((hoisted (js-collect-funcdecls stmts)))
+      ((hoisted (append (js-var-hoist-forms (js-dedup-names (js-collect-var-names stmts) (list))) (js-collect-funcdecls stmts))))
       (let
         ((rest-stmts (js-transpile-stmt-list stmts)))
         (cons (js-sym "begin") (append hoisted rest-stmts))))))
@@ -935,12 +1109,12 @@
 
 (define
   js-transpile-var
-  (fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms kind decls))))
+  (fn (kind decls) (cons (js-sym "begin") (js-vardecl-forms decls (= kind "var")))))
 
 (define
   js-vardecl-forms
   (fn
-    (kind decls)
+    (decls is-var)
     (cond
       ((empty? decls) (list))
       (else
@@ -950,10 +1124,10 @@
             ((js-tag? d "js-vardecl")
               (cons
                 (list
-                  (js-sym "define")
+                  (js-sym (if is-var "set!" "define"))
                   (js-sym (nth d 1))
                   (js-transpile (nth d 2)))
-                (js-vardecl-forms kind (rest decls))))
+                (js-vardecl-forms (rest decls) is-var)))
             ((js-tag? d "js-vardecl-obj")
               (let
                 ((names (nth d 1))
@@ -964,7 +1138,7 @@
                   (js-vardecl-obj-forms
                     names
                     tmp-sym
-                    (js-vardecl-forms kind (rest decls))))))
+                    (js-vardecl-forms (rest decls) is-var)))))
             ((js-tag? d "js-vardecl-arr")
               (let
                 ((names (nth d 1))
@@ -976,7 +1150,7 @@
                     names
                     tmp-sym
                     0
-                    (js-vardecl-forms kind (rest decls))))))
+                    (js-vardecl-forms (rest decls) is-var)))))
             (else (error "js-vardecl-forms: unexpected decl"))))))))
 
 (define
@@ -1276,7 +1450,28 @@
     (let
       ((body-tr (js-transpile body)))
       (let
-        ((with-catch (cond ((= catch-part nil) body-tr) (else (let ((pname (nth catch-part 0)) (cbody (nth catch-part 1))) (list (js-sym "guard") (list (if (= pname nil) (js-sym "__exc__") (js-sym pname)) (list (js-sym "else") (js-transpile cbody))) body-tr))))))
+        ((with-catch
+           (cond
+             ((= catch-part nil) body-tr)
+             (else
+               (let
+                 ((pname (nth catch-part 0))
+                   (cbody (nth catch-part 1))
+                   (raw-sym (js-sym "__raw_exc__")))
+                 (list
+                   (js-sym "guard")
+                   (list
+                     raw-sym
+                     (list
+                       (js-sym "else")
+                       (cond
+                         ((= pname nil) (js-transpile cbody))
+                         (else
+                           (list
+                             (js-sym "let")
+                             (list (list (js-sym pname) (list (js-sym "js-wrap-exn") raw-sym)))
+                             (js-transpile cbody))))))
+                   body-tr))))))
         (cond
           ((= finally-part nil) with-catch)
           (else
@@ -1297,7 +1492,7 @@
           (if
             (and (list? body) (js-tag? body "js-block"))
             (let
-              ((hoisted (js-collect-funcdecls (nth body 1))))
+              ((hoisted (append (js-var-hoist-forms (js-dedup-names (js-collect-var-names (nth body 1)) (list))) (js-collect-funcdecls (nth body 1)))))
               (append hoisted (js-transpile-stmt-list (nth body 1))))
             (list (js-transpile body)))))
       (list
@@ -1305,7 +1500,9 @@
         param-syms
         (list
           (js-sym "let")
-          (list (list (js-sym "this") (list (js-sym "js-this"))))
+          (list
+            (list (js-sym "this") (list (js-sym "js-this")))
+            (list (js-sym "arguments") (js-arguments-build-form params)))
           (list
             (js-sym "let")
             (list
@@ -1316,7 +1513,7 @@
                   (list
                     (js-sym "fn")
                     (list (js-sym "__return__"))
-                    (cons (js-sym "begin") (append inits body-forms))))))
+                    (cons (js-sym "begin") (append (append inits body-forms) (list nil)))))))
             (list
               (js-sym "if")
               (list (js-sym "=") (js-sym "__r__") nil)
@@ -1333,7 +1530,7 @@
           (if
             (and (list? body) (js-tag? body "js-block"))
             (let
-              ((hoisted (js-collect-funcdecls (nth body 1))))
+              ((hoisted (append (js-var-hoist-forms (js-dedup-names (js-collect-var-names (nth body 1)) (list))) (js-collect-funcdecls (nth body 1)))))
               (append hoisted (js-transpile-stmt-list (nth body 1))))
             (list (js-transpile body)))))
       (list
@@ -1396,13 +1593,43 @@
         param-syms
         (list (js-sym "js-async-wrap") (list (js-sym "fn") (list) body-tr))))))
 
+(define
+  js-internal-key?
+  (fn
+    (k)
+    (and
+      (string? k)
+      (>= (len k) 4)
+      (= (substring k 0 2) "__")
+      (= (substring k (- (len k) 2) (len k)) "__"))))
+
+(define
+  js-display
+  (fn
+    (val)
+    (cond
+      ((dict? val)
+        (let
+          ((cleaned (dict)))
+          (begin
+            (for-each
+              (fn
+                (k)
+                (when
+                  (not (js-internal-key? k))
+                  (dict-set! cleaned k (js-display (get val k)))))
+              (keys val))
+            cleaned)))
+      ((list? val) (map js-display val))
+      (else val))))
+
 (define
   js-eval
   (fn
     (src)
     (let
-      ((result (eval-expr (js-transpile (js-parse (js-tokenize src))))))
+      ((result (eval-expr (list (quote let) (list (list (js-sym "this") (list (js-sym "js-this")))) (js-transpile (js-parse (js-tokenize src)))))))
       (js-drain-microtasks!)
-      result)))
+      (js-display result))))
 
 (define js-compile-expr (fn (src) (js-transpile (js-parse-expr src))))

lib/kernel/eval.sx

@@ -0,0 +1,214 @@
+;; lib/kernel/eval.sx — Kernel evaluator.
+;;
+;; The evaluator is `lookup-and-combine`: there are no hardcoded special
+;; forms. Even $if / $define! / $lambda are ordinary operatives bound in
+;; the standard environment (Phase 4). This file builds the dispatch
+;; machinery and the operative/applicative tagged-value protocol.
+;;
+;; Tagged values
+;; -------------
+;;   {:refl-tag :env :bindings DICT :parent PARENT-OR-NIL}
+;;     A first-class Kernel environment. Bindings is a mutable SX dict
+;;     keyed by symbol name; parent walks up the lookup chain. Shape
+;;     and operations are inherited from lib/guest/reflective/env.sx
+;;     (canonical wire shape) — Kernel-side names are thin wrappers.
+;;
+;;   {:knl-tag :operative :impl FN}
+;;     Primitive operative. FN receives (args dyn-env) — args are the
+;;     UN-evaluated argument expressions, dyn-env is the calling env.
+;;
+;;   {:knl-tag :operative :params P :env-param EP :body B :static-env SE}
+;;     User-defined operative (built by $vau). Same tag; dispatch in
+;;     kernel-call-operative forks on which keys are present.
+;;
+;;   {:knl-tag :applicative :underlying OP}
+;;     An applicative wraps an operative. Calls evaluate args first,
+;;     then forward to the underlying operative.
+;;
+;; The env-param of a user operative may be the sentinel :knl-ignore,
+;; in which case the dynamic env is not bound.
+;;
+;; Public API
+;;   (kernel-eval EXPR ENV)                     — primary entry
+;;   (kernel-combine COMBINER ARGS DYN-ENV)
+;;   (kernel-call-operative OP ARGS DYN-ENV)
+;;   (kernel-bind-params! ENV PARAMS ARGS)
+;;   (kernel-make-env) / (kernel-extend-env P)
+;;   (kernel-env-bind! E N V) / (kernel-env-lookup E N)
+;;   (kernel-env-has? E N) / (kernel-env? V)
+;;   (kernel-make-primitive-operative IMPL)
+;;   (kernel-make-primitive-applicative IMPL)
+;;   (kernel-make-user-operative PARAMS EPARAM BODY STATIC-ENV)
+;;   (kernel-wrap OP) / (kernel-unwrap APP)
+;;   (kernel-operative? V) / (kernel-applicative? V) / (kernel-combiner? V)
+;;
+;; Consumes: lib/kernel/parser.sx (kernel-string?, kernel-string-value)
+
+;; ── Environments — delegated to lib/guest/reflective/env.sx ──────
+;; The env values themselves now carry `:refl-tag :env` (shared with the
+;; reflective kit). Kernel's API names stay; bodies are thin wrappers.
+
+(define kernel-env?        refl-env?)
+(define kernel-make-env    refl-make-env)
+(define kernel-extend-env  refl-extend-env)
+(define kernel-env-bind!   refl-env-bind!)
+(define kernel-env-has?    refl-env-has?)
+(define kernel-env-lookup  refl-env-lookup)
+
+;; ── Tagged-value constructors and predicates ─────────────────────
+
+(define kernel-make-primitive-operative (fn (impl) {:impl impl :knl-tag :operative}))
+
+(define
+  kernel-make-user-operative
+  (fn (params eparam body static-env) {:knl-tag :operative :static-env static-env :params params :body body :env-param eparam}))
+
+(define
+  kernel-operative?
+  (fn (v) (and (dict? v) (= (get v :knl-tag) :operative))))
+
+(define
+  kernel-applicative?
+  (fn (v) (and (dict? v) (= (get v :knl-tag) :applicative))))
+
+(define
+  kernel-combiner?
+  (fn (v) (or (kernel-operative? v) (kernel-applicative? v))))
+
+(define
+  kernel-wrap
+  (fn
+    (op)
+    (cond
+      ((kernel-operative? op) {:knl-tag :applicative :underlying op})
+      (:else (error "kernel-wrap: argument must be an operative")))))
+
+(define
+  kernel-unwrap
+  (fn
+    (app)
+    (cond
+      ((kernel-applicative? app) (get app :underlying))
+      (:else (error "kernel-unwrap: argument must be an applicative")))))
+
+(define
+  kernel-make-primitive-applicative
+  (fn
+    (impl)
+    (kernel-wrap
+      (kernel-make-primitive-operative (fn (args dyn-env) (impl args))))))
+
+;; As above, but IMPL receives (args dyn-env). Used by combinators that
+;; re-enter the evaluator (map, filter, reduce, apply, eval, ...).
+(define kernel-make-primitive-applicative-with-env
+  (fn (impl)
+    (kernel-wrap
+      (kernel-make-primitive-operative
+        (fn (args dyn-env) (impl args dyn-env))))))
+
+;; ── The evaluator ────────────────────────────────────────────────
+
+(define
+  kernel-eval
+  (fn
+    (expr env)
+    (cond
+      ((number? expr) expr)
+      ((boolean? expr) expr)
+      ((nil? expr) expr)
+      ((kernel-string? expr) (kernel-string-value expr))
+      ((string? expr) (kernel-env-lookup env expr))
+      ((list? expr)
+        (cond
+          ((= (length expr) 0) expr)
+          (:else
+            (let
+              ((combiner (kernel-eval (first expr) env))
+                (args (rest expr)))
+              (kernel-combine combiner args env)))))
+      (:else (error (str "kernel-eval: unknown form: " expr))))))
+
+(define
+  kernel-combine
+  (fn
+    (combiner args dyn-env)
+    (cond
+      ((kernel-operative? combiner)
+        (kernel-call-operative combiner args dyn-env))
+      ((kernel-applicative? combiner)
+        (kernel-combine
+          (get combiner :underlying)
+          (kernel-eval-args args dyn-env)
+          dyn-env))
+      (:else (error (str "kernel-eval: not a combiner: " combiner))))))
+
+;; Operatives may be primitive (:impl is a host fn) or user-defined
+;; (carry :params / :env-param / :body / :static-env). The dispatch
+;; fork is here so kernel-combine stays small.
+(define
+  kernel-call-operative
+  (fn
+    (op args dyn-env)
+    (cond
+      ((dict-has? op :impl) ((get op :impl) args dyn-env))
+      ((dict-has? op :body)
+        (let
+          ((local (kernel-extend-env (get op :static-env))))
+          (kernel-bind-params! local (get op :params) args)
+          (let
+            ((eparam (get op :env-param)))
+            (when
+              (not (= eparam :knl-ignore))
+              (kernel-env-bind! local eparam dyn-env)))
+          ;; :body is a list of forms — evaluate in sequence, return last.
+          (knl-eval-body (get op :body) local)))
+      (:else (error "kernel-call-operative: malformed operative")))))
+
+(define knl-eval-body
+  (fn (forms env)
+    (cond
+      ((= (length forms) 1) (kernel-eval (first forms) env))
+      (:else
+        (begin
+          (kernel-eval (first forms) env)
+          (knl-eval-body (rest forms) env))))))
+
+;; Phase 3 supports a flat parameter list only — destructuring later.
+(define
+  kernel-bind-params!
+  (fn
+    (env params args)
+    (cond
+      ((or (nil? params) (= (length params) 0))
+        (cond
+          ((or (nil? args) (= (length args) 0)) nil)
+          (:else (error "kernel-call: too many arguments"))))
+      ((or (nil? args) (= (length args) 0))
+        (error "kernel-call: too few arguments"))
+      (:else
+        (begin
+          (kernel-env-bind! env (first params) (first args))
+          (kernel-bind-params! env (rest params) (rest args)))))))
+
+(define
+  kernel-eval-args
+  (fn
+    (args env)
+    (cond
+      ((or (nil? args) (= (length args) 0)) (list))
+      (:else
+        (cons
+          (kernel-eval (first args) env)
+          (kernel-eval-args (rest args) env))))))
+
+(define
+  kernel-eval-program
+  (fn
+    (forms env)
+    (cond
+      ((or (nil? forms) (= (length forms) 0)) nil)
+      ((= (length forms) 1) (kernel-eval (first forms) env))
+      (:else
+        (begin
+          (kernel-eval (first forms) env)
+          (kernel-eval-program (rest forms) env))))))

lib/kernel/parser.sx

@@ -0,0 +1,253 @@
+;; lib/kernel/parser.sx — Kernel s-expression reader.
+;;
+;; Reads R-1RK lexical syntax: numbers, strings, symbols, booleans (#t/#f),
+;; the empty list (), nested lists, and ; line comments. Reader macros
+;; (' ` , ,@) deferred to Phase 6 per the plan.
+;;
+;; Public AST shape:
+;;   number      → SX number
+;;   #t / #f     → SX true / false
+;;   ()          → SX empty list (Kernel's nil — the empty list)
+;;   "..."       → {:knl-string "..."}    wrapped to distinguish from symbols
+;;   foo         → "foo"                  bare SX string is a Kernel symbol
+;;   (a b c)     → SX list of forms
+;;
+;; Public API:
+;;   (kernel-parse SRC)      — first form; errors on extra trailing input
+;;   (kernel-parse-all SRC)  — all top-level forms, as SX list
+;;   (kernel-string? V)      — recognise wrapped string literal
+;;   (kernel-string-value V) — extract the underlying string
+;;
+;; Consumes: lib/guest/lex.sx (lex-digit?, lex-whitespace?)
+
+(define kernel-string-make (fn (s) {:knl-string s}))
+(define
+  kernel-string?
+  (fn (v) (and (dict? v) (string? (get v :knl-string)))))
+(define kernel-string-value (fn (v) (get v :knl-string)))
+
+;; Atom delimiters: characters that end a symbol or numeric token.
+(define
+  knl-delim?
+  (fn
+    (c)
+    (or
+      (nil? c)
+      (lex-whitespace? c)
+      (= c "(")
+      (= c ")")
+      (= c "\"")
+      (= c ";")
+      (= c "'")
+      (= c "`")
+      (= c ","))))
+
+;; Numeric grammar:  [+-]? (digit+ ('.' digit+)? | '.' digit+) ([eE][+-]?digit+)?
+(define
+  knl-numeric?
+  (fn
+    (s)
+    (let
+      ((n (string-length s)))
+      (cond
+        ((= n 0) false)
+        (:else
+          (let
+            ((c0 (substring s 0 1)))
+            (let
+              ((start (if (or (= c0 "+") (= c0 "-")) 1 0)))
+              (knl-num-body? s start n))))))))
+
+(define
+  knl-num-body?
+  (fn
+    (s start n)
+    (cond
+      ((>= start n) false)
+      ((= (substring s start (+ start 1)) ".")
+        (knl-num-need-digits? s (+ start 1) n false))
+      ((lex-digit? (substring s start (+ start 1)))
+        (knl-num-int-tail? s (+ start 1) n))
+      (:else false))))
+
+(define
+  knl-num-int-tail?
+  (fn
+    (s i n)
+    (cond
+      ((>= i n) true)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-int-tail? s (+ i 1) n))
+      ((= (substring s i (+ i 1)) ".")
+        (knl-num-need-digits? s (+ i 1) n true))
+      ((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
+        (knl-num-exp-sign? s (+ i 1) n))
+      (:else false))))
+
+(define
+  knl-num-need-digits?
+  (fn
+    (s i n had-int)
+    (cond
+      ((>= i n) had-int)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-frac-tail? s (+ i 1) n))
+      (:else false))))
+
+(define
+  knl-num-frac-tail?
+  (fn
+    (s i n)
+    (cond
+      ((>= i n) true)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-frac-tail? s (+ i 1) n))
+      ((or (= (substring s i (+ i 1)) "e") (= (substring s i (+ i 1)) "E"))
+        (knl-num-exp-sign? s (+ i 1) n))
+      (:else false))))
+
+(define
+  knl-num-exp-sign?
+  (fn
+    (s i n)
+    (cond
+      ((>= i n) false)
+      ((or (= (substring s i (+ i 1)) "+") (= (substring s i (+ i 1)) "-"))
+        (knl-num-exp-digits? s (+ i 1) n false))
+      (:else (knl-num-exp-digits? s i n false)))))
+
+(define
+  knl-num-exp-digits?
+  (fn
+    (s i n had)
+    (cond
+      ((>= i n) had)
+      ((lex-digit? (substring s i (+ i 1)))
+        (knl-num-exp-digits? s (+ i 1) n true))
+      (:else false))))
+
+;; Reader: a closure over (src, pos). Exposes :read-form and :read-all.
+(define
+  knl-make-reader
+  (fn
+    (src)
+    (let
+      ((pos 0) (n (string-length src)))
+      (define
+        at
+        (fn () (if (< pos n) (substring src pos (+ pos 1)) nil)))
+      (define adv (fn () (set! pos (+ pos 1))))
+      (define
+        skip-line
+        (fn () (when (and (at) (not (= (at) "\n"))) (adv) (skip-line))))
+      (define
+        skip-ws
+        (fn
+          ()
+          (cond
+            ((nil? (at)) nil)
+            ((lex-whitespace? (at)) (do (adv) (skip-ws)))
+            ((= (at) ";") (do (adv) (skip-line) (skip-ws)))
+            (:else nil))))
+      (define
+        read-string-body
+        (fn
+          (acc)
+          (cond
+            ((nil? (at)) (error "kernel-parse: unterminated string"))
+            ((= (at) "\"") (do (adv) acc))
+            ((= (at) "\\")
+              (do
+                (adv)
+                (let
+                  ((c (at)))
+                  (when (nil? c) (error "kernel-parse: trailing backslash"))
+                  (adv)
+                  (read-string-body
+                    (str
+                      acc
+                      (cond
+                        ((= c "n") "\n")
+                        ((= c "t") "\t")
+                        ((= c "r") "\r")
+                        ((= c "\"") "\"")
+                        ((= c "\\") "\\")
+                        (:else c)))))))
+            (:else
+              (let ((c (at))) (adv) (read-string-body (str acc c)))))))
+      (define
+        read-atom-body
+        (fn
+          (acc)
+          (cond
+            ((knl-delim? (at)) acc)
+            (:else (let ((c (at))) (adv) (read-atom-body (str acc c)))))))
+      (define
+        classify-atom
+        (fn
+          (s)
+          (cond
+            ((= s "#t") true)
+            ((= s "#f") false)
+            ((knl-numeric? s) (string->number s))
+            (:else s))))
+      (define
+        read-form
+        (fn
+          ()
+          (skip-ws)
+          (cond
+            ((nil? (at)) :knl-eof)
+            ((= (at) ")") (error "kernel-parse: unexpected ')'"))
+            ((= (at) "(") (do (adv) (read-list (list))))
+            ((= (at) "\"")
+              (do (adv) (kernel-string-make (read-string-body ""))))
+            ((= (at) "'")
+              (do (adv) (list "$quote" (read-form))))
+            ((= (at) "`")
+              (do (adv) (list "$quasiquote" (read-form))))
+            ((= (at) ",")
+              (do (adv)
+                  (cond
+                    ((= (at) "@")
+                      (do (adv) (list "$unquote-splicing" (read-form))))
+                    (:else (list "$unquote" (read-form))))))
+            (:else (classify-atom (read-atom-body ""))))))
+      (define
+        read-list
+        (fn
+          (acc)
+          (skip-ws)
+          (cond
+            ((nil? (at)) (error "kernel-parse: unterminated list"))
+            ((= (at) ")") (do (adv) acc))
+            (:else (read-list (append acc (list (read-form))))))))
+      (define
+        read-all
+        (fn
+          (acc)
+          (skip-ws)
+          (if (nil? (at)) acc (read-all (append acc (list (read-form)))))))
+      {:read-form read-form :read-all read-all})))
+
+(define
+  kernel-parse-all
+  (fn (src) ((get (knl-make-reader src) :read-all) (list))))
+
+(define
+  kernel-parse
+  (fn
+    (src)
+    (let
+      ((r (knl-make-reader src)))
+      (let
+        ((form ((get r :read-form))))
+        (cond
+          ((= form :knl-eof) (error "kernel-parse: empty input"))
+          (:else
+            (let
+              ((next ((get r :read-form))))
+              (if
+                (= next :knl-eof)
+                form
+                (error "kernel-parse: trailing input after first form")))))))))

lib/kernel/runtime.sx

@@ -0,0 +1,881 @@
+;; lib/kernel/runtime.sx — the operative–applicative substrate and the
+;; standard Kernel environment.
+;;
+;; Phase 3 supplied four user-visible combiners ($vau, $lambda, wrap,
+;; unwrap). Phase 4 fills out the rest of the R-1RK core: $if, $define!,
+;; $sequence, eval, make-environment, get-current-environment, plus
+;; arithmetic, equality, list/pair, and boolean primitives — enough to
+;; write factorial.
+;;
+;; The standard env is built by EXTENDING the base env, not replacing
+;; it. So `kernel-standard-env` includes everything from `kernel-base-env`.
+;;
+;; Public API
+;;   (kernel-base-env)       — Phase 3 combiners
+;;   (kernel-standard-env)   — Phase 4 standard environment
+
+(define
+  knl-eparam-sentinel
+  (fn
+    (sym)
+    (cond
+      ((= sym "_") :knl-ignore)
+      ((= sym "#ignore") :knl-ignore)
+      (:else sym))))
+
+(define
+  knl-formals-ok?
+  (fn
+    (formals)
+    (cond
+      ((not (list? formals)) false)
+      ((= (length formals) 0) true)
+      ((string? (first formals)) (knl-formals-ok? (rest formals)))
+      (:else false))))
+
+;; ── $vau ─────────────────────────────────────────────────────────
+
+(define
+  kernel-vau-impl
+  (fn
+    (args dyn-env)
+    (cond
+      ((< (length args) 3)
+        (error "$vau: expects (formals env-param body...)"))
+      (:else
+        (let
+          ((formals (first args))
+            (eparam-raw (nth args 1))
+            (body-forms (rest (rest args))))
+          (cond
+            ((not (knl-formals-ok? formals))
+              (error "$vau: formals must be a list of symbols"))
+            ((not (string? eparam-raw))
+              (error "$vau: env-param must be a symbol"))
+            (:else
+              (kernel-make-user-operative
+                formals
+                (knl-eparam-sentinel eparam-raw)
+                body-forms
+                dyn-env))))))))
+
+(define
+  kernel-vau-operative
+  (kernel-make-primitive-operative kernel-vau-impl))
+
+;; ── $lambda ──────────────────────────────────────────────────────
+
+(define
+  kernel-lambda-impl
+  (fn
+    (args dyn-env)
+    (cond
+      ((< (length args) 2)
+        (error "$lambda: expects (formals body...)"))
+      (:else
+        (let
+          ((formals (first args)) (body-forms (rest args)))
+          (cond
+            ((not (knl-formals-ok? formals))
+              (error "$lambda: formals must be a list of symbols"))
+            (:else
+              (kernel-wrap
+                (kernel-make-user-operative
+                  formals
+                  :knl-ignore
+                  body-forms
+                  dyn-env)))))))))
+
+(define
+  kernel-lambda-operative
+  (kernel-make-primitive-operative kernel-lambda-impl))
+
+;; ── wrap / unwrap / predicates ───────────────────────────────────
+
+(define
+  kernel-wrap-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((not (= (length args) 1))
+          (error "wrap: expects exactly 1 argument"))
+        (:else (kernel-wrap (first args)))))))
+
+(define
+  kernel-unwrap-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((not (= (length args) 1))
+          (error "unwrap: expects exactly 1 argument"))
+        (:else (kernel-unwrap (first args)))))))
+
+(define
+  kernel-operative?-applicative
+  (kernel-make-primitive-applicative
+    (fn (args) (kernel-operative? (first args)))))
+
+(define
+  kernel-applicative?-applicative
+  (kernel-make-primitive-applicative
+    (fn (args) (kernel-applicative? (first args)))))
+
+(define
+  kernel-base-env
+  (fn
+    ()
+    (let
+      ((env (kernel-make-env)))
+      (kernel-env-bind! env "$vau" kernel-vau-operative)
+      (kernel-env-bind! env "$lambda" kernel-lambda-operative)
+      (kernel-env-bind! env "wrap" kernel-wrap-applicative)
+      (kernel-env-bind! env "unwrap" kernel-unwrap-applicative)
+      (kernel-env-bind! env "operative?" kernel-operative?-applicative)
+      (kernel-env-bind! env "applicative?" kernel-applicative?-applicative)
+      env)))
+
+;; ── $if / $define! / $sequence ───────────────────────────────────
+
+(define
+  kernel-if-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 3))
+          (error "$if: expects (condition then-expr else-expr)"))
+        (:else
+          (let
+            ((c (kernel-eval (first args) dyn-env)))
+            (if
+              c
+              (kernel-eval (nth args 1) dyn-env)
+              (kernel-eval (nth args 2) dyn-env))))))))
+
+(define
+  kernel-define!-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "$define!: expects (name expr)"))
+        ((not (string? (first args)))
+          (error "$define!: name must be a symbol"))
+        (:else
+          (let
+            ((v (kernel-eval (nth args 1) dyn-env)))
+            (kernel-env-bind! dyn-env (first args) v)
+            v))))))
+
+(define
+  kernel-sequence-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((or (nil? args) (= (length args) 0)) nil)
+        ((= (length args) 1) (kernel-eval (first args) dyn-env))
+        (:else
+          (begin
+            (kernel-eval (first args) dyn-env)
+            ((get kernel-sequence-operative :impl) (rest args) dyn-env)))))))
+
+;; ── eval / make-environment / get-current-environment ───────────
+
+(define
+  kernel-quote-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 1)) (error "$quote: expects 1 argument"))
+        (:else (first args))))))
+
+;; Kernel-side adapter for lib/guest/reflective/quoting.sx.
+;; Kernel uses $unquote / $unquote-splicing (dollar-prefixed) and the
+;; host-level kernel-eval as the evaluator. The walker algorithm
+;; itself is shared with Scheme via the kit.
+(define knl-quasi-cfg
+  {:unquote-name "$unquote"
+   :unquote-splicing-name "$unquote-splicing"
+   :eval (fn (form env) (kernel-eval form env))})
+
+(define knl-quasi-walk
+  (fn (form dyn-env)
+    (refl-quasi-walk-with knl-quasi-cfg form dyn-env)))
+
+;; $cond — multi-clause branch.
+;;   ($cond (TEST1 EXPR1 ...) (TEST2 EXPR2 ...) ...)
+;; Evaluates each TEST in order; first truthy one runs its EXPRs (in
+;; sequence) and returns the last; if no TEST is truthy, returns nil.
+;; A clause with TEST = `else` always matches (sugar for $if's default).
+(define knl-cond-impl
+  (fn (clauses dyn-env)
+    (cond
+      ((or (nil? clauses) (= (length clauses) 0)) nil)
+      (:else
+        (let ((clause (first clauses)))
+          (cond
+            ((not (list? clause))
+              (error "$cond: each clause must be a list"))
+            ((= (length clause) 0)
+              (error "$cond: empty clause"))
+            ((and (string? (first clause)) (= (first clause) "else"))
+              (knl-cond-eval-body (rest clause) dyn-env))
+            (:else
+              (let ((test-val (kernel-eval (first clause) dyn-env)))
+                (cond
+                  (test-val (knl-cond-eval-body (rest clause) dyn-env))
+                  (:else (knl-cond-impl (rest clauses) dyn-env)))))))))))
+
+(define knl-cond-eval-body
+  (fn (body dyn-env)
+    (cond
+      ((or (nil? body) (= (length body) 0)) nil)
+      ((= (length body) 1) (kernel-eval (first body) dyn-env))
+      (:else
+        (begin
+          (kernel-eval (first body) dyn-env)
+          (knl-cond-eval-body (rest body) dyn-env))))))
+
+(define kernel-cond-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env) (knl-cond-impl args dyn-env))))
+
+;; $when COND BODY... — evaluate body iff COND is truthy; else nil.
+(define kernel-when-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 1)
+          (error "$when: expects (cond body...)"))
+        (:else
+          (let ((c (kernel-eval (first args) dyn-env)))
+            (cond
+              (c (knl-cond-eval-body (rest args) dyn-env))
+              (:else nil))))))))
+
+;; $and? — short-circuit AND. Operative (not applicative) so untaken
+;; clauses are NOT evaluated. Empty $and? returns true (the identity).
+(define knl-and?-impl
+  (fn (args dyn-env)
+    (cond
+      ((or (nil? args) (= (length args) 0)) true)
+      ((= (length args) 1) (kernel-eval (first args) dyn-env))
+      (:else
+        (let ((v (kernel-eval (first args) dyn-env)))
+          (cond
+            (v (knl-and?-impl (rest args) dyn-env))
+            (:else v)))))))
+
+(define kernel-and?-operative
+  (kernel-make-primitive-operative knl-and?-impl))
+
+;; $or? — short-circuit OR. Operative; untaken clauses NOT evaluated.
+;; Empty $or? returns false (the identity).
+(define knl-or?-impl
+  (fn (args dyn-env)
+    (cond
+      ((or (nil? args) (= (length args) 0)) false)
+      ((= (length args) 1) (kernel-eval (first args) dyn-env))
+      (:else
+        (let ((v (kernel-eval (first args) dyn-env)))
+          (cond
+            (v v)
+            (:else (knl-or?-impl (rest args) dyn-env))))))))
+
+(define kernel-or?-operative
+  (kernel-make-primitive-operative knl-or?-impl))
+
+;; $unless COND BODY... — evaluate body iff COND is falsy; else nil.
+(define kernel-unless-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 1)
+          (error "$unless: expects (cond body...)"))
+        (:else
+          (let ((c (kernel-eval (first args) dyn-env)))
+            (cond
+              (c nil)
+              (:else (knl-cond-eval-body (rest args) dyn-env)))))))))
+
+(define kernel-quasiquote-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 1))
+          (error "$quasiquote: expects exactly 1 argument"))
+        (:else (knl-quasi-walk (first args) dyn-env))))))
+
+(define
+  kernel-eval-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((not (= (length args) 2))
+          (error "eval: expects (expr env)"))
+        ((not (kernel-env? (nth args 1)))
+          (error "eval: second arg must be a kernel env"))
+        (:else (kernel-eval (first args) (nth args 1)))))))
+
+(define
+  kernel-make-environment-applicative
+  (kernel-make-primitive-applicative
+    (fn
+      (args)
+      (cond
+        ((= (length args) 0) (kernel-make-env))
+        ((= (length args) 1)
+          (cond
+            ((not (kernel-env? (first args)))
+              (error "make-environment: parent must be a kernel env"))
+            (:else (kernel-extend-env (first args)))))
+        (:else (error "make-environment: 0 or 1 argument"))))))
+
+;; ── arithmetic and comparison (binary; trivial to extend later) ─
+
+(define
+  kernel-get-current-env-operative
+  (kernel-make-primitive-operative
+    (fn
+      (args dyn-env)
+      (cond
+        ((not (= (length args) 0))
+          (error "get-current-environment: expects 0 arguments"))
+        (:else dyn-env)))))
+
+(define
+  knl-bin-app
+  (fn
+    (name f)
+    (kernel-make-primitive-applicative
+      (fn
+        (args)
+        (cond
+          ((not (= (length args) 2))
+            (error (str name ": expects 2 arguments")))
+          (:else (f (first args) (nth args 1))))))))
+
+;; Variadic left-fold helper. ZERO-RES is the identity (`(+)` → 0);
+;; ONE-FN handles single-arg case (`(- x)` negates; `(+ x)` returns x).
+(define knl-fold-step
+  (fn (f acc rest-args)
+    (cond
+      ((or (nil? rest-args) (= (length rest-args) 0)) acc)
+      (:else
+        (knl-fold-step f (f acc (first rest-args)) (rest rest-args))))))
+
+(define knl-fold-app
+  (fn (name f zero-res one-fn)
+    (kernel-make-primitive-applicative
+      (fn (args)
+        (cond
+          ((= (length args) 0) zero-res)
+          ((= (length args) 1) (one-fn (first args)))
+          (:else (knl-fold-step f (first args) (rest args))))))))
+
+;; Variadic n-ary chained comparison: `(< 1 2 3)` ≡ `(< 1 2)` AND `(< 2 3)`.
+(define knl-chain-step
+  (fn (cmp prev rest-args)
+    (cond
+      ((or (nil? rest-args) (= (length rest-args) 0)) true)
+      (:else
+        (let ((next (first rest-args)))
+          (cond
+            ((cmp prev next)
+              (knl-chain-step cmp next (rest rest-args)))
+            (:else false)))))))
+
+(define knl-chain-cmp
+  (fn (name cmp)
+    (kernel-make-primitive-applicative
+      (fn (args)
+        (cond
+          ((< (length args) 2)
+            (error (str name ": expects at least 2 arguments")))
+          (:else (knl-chain-step cmp (first args) (rest args))))))))
+
+;; ── list / pair primitives ──────────────────────────────────────
+
+(define
+  knl-unary-app
+  (fn
+    (name f)
+    (kernel-make-primitive-applicative
+      (fn
+        (args)
+        (cond
+          ((not (= (length args) 1))
+            (error (str name ": expects 1 argument")))
+          (:else (f (first args))))))))
+
+(define kernel-cons-applicative (knl-bin-app "cons" (fn (a b) (cons a b))))
+
+(define
+  kernel-car-applicative
+  (knl-unary-app
+    "car"
+    (fn
+      (xs)
+      (cond
+        ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
+          (error "car: empty list"))
+        (:else (first xs))))))
+
+(define
+  kernel-cdr-applicative
+  (knl-unary-app
+    "cdr"
+    (fn
+      (xs)
+      (cond
+        ((or (nil? xs) (and (list? xs) (= (length xs) 0)))
+          (error "cdr: empty list"))
+        (:else (rest xs))))))
+
+(define
+  kernel-list-applicative
+  (kernel-make-primitive-applicative (fn (args) args)))
+
+(define
+  kernel-length-applicative
+  (knl-unary-app "length" (fn (xs) (length xs))))
+
+(define
+  kernel-null?-applicative
+  (knl-unary-app
+    "null?"
+    (fn (v) (or (nil? v) (and (list? v) (= (length v) 0))))))
+
+;; ── boolean / equality ──────────────────────────────────────────
+
+(define
+  kernel-pair?-applicative
+  (knl-unary-app
+    "pair?"
+    (fn (v) (and (list? v) (> (length v) 0)))))
+
+(define knl-append-step
+  (fn (xs ys)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) ys)
+      (:else (cons (first xs) (knl-append-step (rest xs) ys))))))
+
+(define knl-all-lists?
+  (fn (xs)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) true)
+      ((list? (first xs)) (knl-all-lists? (rest xs)))
+      (:else false))))
+
+(define knl-append-all
+  (fn (lists)
+    (cond
+      ((or (nil? lists) (= (length lists) 0)) (list))
+      ((= (length lists) 1) (first lists))
+      (:else
+        (knl-append-step (first lists)
+                         (knl-append-all (rest lists)))))))
+
+(define kernel-append-applicative
+  (kernel-make-primitive-applicative
+    (fn (args)
+      (cond
+        ((knl-all-lists? args) (knl-append-all args))
+        (:else (error "append: all arguments must be lists"))))))
+
+(define knl-reverse-step
+  (fn (xs acc)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) acc)
+      (:else (knl-reverse-step (rest xs) (cons (first xs) acc))))))
+
+(define kernel-reverse-applicative
+  (knl-unary-app "reverse"
+    (fn (xs)
+      (cond
+        ((not (list? xs)) (error "reverse: argument must be a list"))
+        (:else (knl-reverse-step xs (list)))))))
+
+(define kernel-not-applicative (knl-unary-app "not" (fn (v) (not v))))
+
+;; Type predicates (Kernel-visible). Note `string?` covers BOTH symbols
+;; and string-literals in our representation (symbols are bare SX
+;; strings); a `kernel-string?` applicative distinguishes the two if
+;; needed.
+(define kernel-number?-applicative
+  (knl-unary-app "number?" (fn (v) (number? v))))
+(define kernel-string?-applicative
+  (knl-unary-app "string?" (fn (v) (string? v))))
+(define kernel-list?-applicative
+  (knl-unary-app "list?" (fn (v) (list? v))))
+(define kernel-boolean?-applicative
+  (knl-unary-app "boolean?" (fn (v) (boolean? v))))
+(define kernel-symbol?-applicative
+  (knl-unary-app "symbol?" (fn (v) (string? v))))
+
+(define kernel-eq?-applicative (knl-bin-app "eq?" (fn (a b) (= a b))))
+
+;; ── the standard environment ────────────────────────────────────
+
+(define
+  kernel-equal?-applicative
+  (knl-bin-app "equal?" (fn (a b) (= a b))))
+
+;; ── List combinators: map / filter / reduce ─────────────────────
+;; These re-enter the evaluator on each element, so they use the
+;; with-env applicative constructor.
+
+;; When the combiner is an applicative, we MUST unwrap before calling
+;; — otherwise kernel-combine will re-evaluate the already-evaluated
+;; element values (and crash if an element is itself a list).
+(define knl-apply-op
+  (fn (combiner)
+    (cond
+      ((kernel-applicative? combiner) (kernel-unwrap combiner))
+      (:else combiner))))
+
+(define knl-map-step
+  (fn (fn-val xs dyn-env)
+    (let ((op (knl-apply-op fn-val)))
+      (knl-map-walk op xs dyn-env))))
+
+(define knl-map-walk
+  (fn (op xs dyn-env)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) (list))
+      (:else
+        (cons (kernel-combine op (list (first xs)) dyn-env)
+              (knl-map-walk op (rest xs) dyn-env))))))
+
+(define kernel-map-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "map: expects (fn list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "map: first arg must be a combiner"))
+        ((not (list? (nth args 1)))
+          (error "map: second arg must be a list"))
+        (:else (knl-map-step (first args) (nth args 1) dyn-env))))))
+
+(define knl-filter-step
+  (fn (pred xs dyn-env)
+    (knl-filter-walk (knl-apply-op pred) xs dyn-env)))
+
+(define knl-filter-walk
+  (fn (op xs dyn-env)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) (list))
+      (:else
+        (let ((keep? (kernel-combine op (list (first xs)) dyn-env)))
+          (cond
+            (keep?
+              (cons (first xs) (knl-filter-walk op (rest xs) dyn-env)))
+            (:else (knl-filter-walk op (rest xs) dyn-env))))))))
+
+(define kernel-filter-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "filter: expects (pred list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "filter: first arg must be a combiner"))
+        ((not (list? (nth args 1)))
+          (error "filter: second arg must be a list"))
+        (:else (knl-filter-step (first args) (nth args 1) dyn-env))))))
+
+(define knl-reduce-step
+  (fn (fn-val xs acc dyn-env)
+    (knl-reduce-walk (knl-apply-op fn-val) xs acc dyn-env)))
+
+(define knl-reduce-walk
+  (fn (op xs acc dyn-env)
+    (cond
+      ((or (nil? xs) (= (length xs) 0)) acc)
+      (:else
+        (knl-reduce-walk
+          op
+          (rest xs)
+          (kernel-combine op (list acc (first xs)) dyn-env)
+          dyn-env)))))
+
+;; (apply COMBINER ARGS-LIST) — call COMBINER with the elements of
+;; ARGS-LIST as arguments. The Kernel canonical use: turn a constructed
+;; list of values into a function call. We skip the applicative's
+;; auto-eval step (via unwrap) because ARGS-LIST is already values, not
+;; expressions; for a bare operative, we pass through directly.
+(define kernel-apply-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 2))
+          (error "apply: expects (combiner args-list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "apply: first arg must be a combiner"))
+        ((not (list? (nth args 1)))
+          (error "apply: second arg must be a list"))
+        (:else
+          (let ((op (cond
+                      ((kernel-applicative? (first args))
+                        (kernel-unwrap (first args)))
+                      (:else (first args)))))
+            (kernel-combine op (nth args 1) dyn-env)))))))
+
+(define kernel-reduce-applicative
+  (kernel-make-primitive-applicative-with-env
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 3))
+          (error "reduce: expects (fn init list)"))
+        ((not (kernel-combiner? (first args)))
+          (error "reduce: first arg must be a combiner"))
+        ((not (list? (nth args 2)))
+          (error "reduce: third arg must be a list"))
+        (:else
+          (knl-reduce-step (first args) (nth args 2)
+                           (nth args 1) dyn-env))))))
+
+;; ── Encapsulations: Kernel's opaque-type idiom ──────────────────
+;;
+;; (make-encapsulation-type) → (encapsulator predicate decapsulator)
+;;
+;; Each call returns three applicatives over a fresh family identity.
+;; - (encapsulator V) → an opaque wrapper around V.
+;; - (predicate V)    → true iff V was wrapped by THIS family.
+;; - (decapsulator W) → the inner value; errors on wrong family.
+;;
+;; Family identity is a fresh empty dict; SX compares dicts by reference,
+;; so two `(make-encapsulation-type)` calls return distinct families.
+;;
+;; Pattern usage (Phase 5 lacks destructuring, so accessors are explicit):
+;;   ($define! triple (make-encapsulation-type))
+;;   ($define! wrap-promise   (car  triple))
+;;   ($define! promise?       (car  (cdr triple)))
+;;   ($define! unwrap-promise (car  (cdr (cdr triple))))
+
+(define kernel-make-encap-type-impl
+  (fn (args)
+    (cond
+      ((not (= (length args) 0))
+        (error "make-encapsulation-type: expects 0 arguments"))
+      (:else
+        (let ((family {}))
+          (let ((encap
+                  (kernel-make-primitive-applicative
+                    (fn (vargs)
+                      (cond
+                        ((not (= (length vargs) 1))
+                          (error "encapsulator: expects 1 argument"))
+                        (:else
+                          {:knl-tag :encap
+                           :family family
+                           :value (first vargs)})))))
+                (pred
+                  (kernel-make-primitive-applicative
+                    (fn (vargs)
+                      (cond
+                        ((not (= (length vargs) 1))
+                          (error "predicate: expects 1 argument"))
+                        (:else
+                          (let ((v (first vargs)))
+                            (and (dict? v)
+                                 (= (get v :knl-tag) :encap)
+                                 (= (get v :family) family))))))))
+                (decap
+                  (kernel-make-primitive-applicative
+                    (fn (vargs)
+                      (cond
+                        ((not (= (length vargs) 1))
+                          (error "decapsulator: expects 1 argument"))
+                        (:else
+                          (let ((v (first vargs)))
+                            (cond
+                              ((not (and (dict? v)
+                                         (= (get v :knl-tag) :encap)))
+                                (error "decapsulator: not an encapsulation"))
+                              ((not (= (get v :family) family))
+                                (error "decapsulator: wrong family"))
+                              (:else (get v :value))))))))))
+            (list encap pred decap)))))))
+
+(define kernel-make-encap-type-applicative
+  (kernel-make-primitive-applicative kernel-make-encap-type-impl))
+
+;; ── Hygiene: $let, $define-in!, make-environment ────────────────
+;;
+;; Kernel-on-SX is hygienic *by default* because user-defined operatives
+;; (Phase 3) bind their formals + any $define! in a CHILD env extending
+;; the operative's static-env, never the dyn-env. The caller's env is
+;; only mutated when code explicitly says so (e.g. `(eval expr env-arg)`).
+;;
+;; Phase 6 adds two helpers that make the property easy to lean on:
+;;
+;;   ($let ((NAME EXPR) ...) BODY)
+;;     Evaluates each EXPR in the calling env, binds NAME in a fresh
+;;     child env, evaluates BODY in that child env. NAMES don't leak.
+;;
+;;   ($define-in! ENV NAME EXPR)
+;;     Binds NAME=value-of-EXPR in the *specified* env, not the dyn-env.
+;;     Useful for operatives that need to mutate a sandbox env without
+;;     touching their caller's env.
+;;
+;; Shutt's full scope-set / frame-stamp hygiene (lifted symbols carrying
+;; provenance markers so introduced bindings can shadow without
+;; capturing) is research-grade and not implemented here. Notes for
+;; `lib/guest/reflective/hygiene.sx` candidate API below the std env.
+
+(define knl-bind-let-vals!
+  (fn (local bindings dyn-env)
+    (cond
+      ((or (nil? bindings) (= (length bindings) 0)) nil)
+      (:else
+        (let ((b (first bindings)))
+          (cond
+            ((not (and (list? b) (= (length b) 2)))
+              (error "$let: each binding must be (name expr)"))
+            ((not (string? (first b)))
+              (error "$let: binding name must be a symbol"))
+            (:else
+              (begin
+                (kernel-env-bind! local
+                                  (first b)
+                                  (kernel-eval (nth b 1) dyn-env))
+                (knl-bind-let-vals! local (rest bindings) dyn-env)))))))))
+
+(define kernel-let-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 2)
+          (error "$let: expects (bindings body...)"))
+        ((not (list? (first args)))
+          (error "$let: bindings must be a list"))
+        (:else
+          (let ((local (kernel-extend-env dyn-env)))
+            (knl-bind-let-vals! local (first args) dyn-env)
+            (knl-eval-body (rest args) local)))))))
+
+;; $let* — sequential let. Each binding sees prior names in scope.
+;; Implemented by nesting envs one per binding; the body runs in the
+;; innermost env, so later bindings shadow earlier ones if names repeat.
+(define knl-let*-step
+  (fn (bindings env body-forms)
+    (cond
+      ((or (nil? bindings) (= (length bindings) 0))
+        (knl-eval-body body-forms env))
+      (:else
+        (let ((b (first bindings)))
+          (cond
+            ((not (and (list? b) (= (length b) 2)))
+              (error "$let*: each binding must be (name expr)"))
+            ((not (string? (first b)))
+              (error "$let*: binding name must be a symbol"))
+            (:else
+              (let ((child (kernel-extend-env env)))
+                (kernel-env-bind! child
+                                  (first b)
+                                  (kernel-eval (nth b 1) env))
+                (knl-let*-step (rest bindings) child body-forms)))))))))
+
+(define kernel-let*-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((< (length args) 2)
+          (error "$let*: expects (bindings body...)"))
+        ((not (list? (first args)))
+          (error "$let*: bindings must be a list"))
+        (:else
+          (knl-let*-step (first args) dyn-env (rest args)))))))
+
+(define kernel-define-in!-operative
+  (kernel-make-primitive-operative
+    (fn (args dyn-env)
+      (cond
+        ((not (= (length args) 3))
+          (error "$define-in!: expects (env-expr name expr)"))
+        ((not (string? (nth args 1)))
+          (error "$define-in!: name must be a symbol"))
+        (:else
+          (let ((target (kernel-eval (first args) dyn-env)))
+            (cond
+              ((not (kernel-env? target))
+                (error "$define-in!: first arg must evaluate to an env"))
+              (:else
+                (let ((v (kernel-eval (nth args 2) dyn-env)))
+                  (kernel-env-bind! target (nth args 1) v)
+                  v)))))))))
+
+(define
+  kernel-standard-env
+  (fn
+    ()
+    (let
+      ((env (kernel-base-env)))
+      (kernel-env-bind! env "$if" kernel-if-operative)
+      (kernel-env-bind! env "$define!" kernel-define!-operative)
+      (kernel-env-bind! env "$sequence" kernel-sequence-operative)
+      (kernel-env-bind! env "$quote"    kernel-quote-operative)
+      (kernel-env-bind! env "$quasiquote" kernel-quasiquote-operative)
+      (kernel-env-bind! env "$cond"   kernel-cond-operative)
+      (kernel-env-bind! env "$when"   kernel-when-operative)
+      (kernel-env-bind! env "$unless" kernel-unless-operative)
+      (kernel-env-bind! env "$and?"   kernel-and?-operative)
+      (kernel-env-bind! env "$or?"    kernel-or?-operative)
+      (kernel-env-bind! env "eval" kernel-eval-applicative)
+      (kernel-env-bind!
+        env
+        "make-environment"
+        kernel-make-environment-applicative)
+      (kernel-env-bind!
+        env
+        "get-current-environment"
+        kernel-get-current-env-operative)
+      (kernel-env-bind! env "+"
+        (knl-fold-app "+" (fn (a b) (+ a b)) 0 (fn (x) x)))
+      (kernel-env-bind! env "-"
+        (knl-fold-app "-" (fn (a b) (- a b)) 0 (fn (x) (- 0 x))))
+      (kernel-env-bind! env "*"
+        (knl-fold-app "*" (fn (a b) (* a b)) 1 (fn (x) x)))
+      (kernel-env-bind! env "/"
+        (knl-fold-app "/" (fn (a b) (/ a b)) 1 (fn (x) (/ 1 x))))
+      (kernel-env-bind! env "<"   (knl-chain-cmp "<"   (fn (a b) (< a b))))
+      (kernel-env-bind! env ">"   (knl-chain-cmp ">"   (fn (a b) (> a b))))
+      (kernel-env-bind! env "<=?" (knl-chain-cmp "<=?" (fn (a b) (<= a b))))
+      (kernel-env-bind! env ">=?" (knl-chain-cmp ">=?" (fn (a b) (>= a b))))
+      (kernel-env-bind! env "=?" kernel-eq?-applicative)
+      (kernel-env-bind! env "equal?" kernel-equal?-applicative)
+      (kernel-env-bind! env "eq?" kernel-eq?-applicative)
+      (kernel-env-bind! env "cons" kernel-cons-applicative)
+      (kernel-env-bind! env "car" kernel-car-applicative)
+      (kernel-env-bind! env "cdr" kernel-cdr-applicative)
+      (kernel-env-bind! env "list" kernel-list-applicative)
+      (kernel-env-bind! env "length" kernel-length-applicative)
+      (kernel-env-bind! env "null?" kernel-null?-applicative)
+      (kernel-env-bind! env "pair?" kernel-pair?-applicative)
+      (kernel-env-bind! env "map"    kernel-map-applicative)
+      (kernel-env-bind! env "filter" kernel-filter-applicative)
+      (kernel-env-bind! env "reduce" kernel-reduce-applicative)
+      (kernel-env-bind! env "apply"   kernel-apply-applicative)
+      (kernel-env-bind! env "append"  kernel-append-applicative)
+      (kernel-env-bind! env "reverse" kernel-reverse-applicative)
+      (kernel-env-bind! env "number?"  kernel-number?-applicative)
+      (kernel-env-bind! env "string?"  kernel-string?-applicative)
+      (kernel-env-bind! env "list?"    kernel-list?-applicative)
+      (kernel-env-bind! env "boolean?" kernel-boolean?-applicative)
+      (kernel-env-bind! env "symbol?"  kernel-symbol?-applicative)
+      (kernel-env-bind! env "not" kernel-not-applicative)
+      (kernel-env-bind! env "make-encapsulation-type"
+                            kernel-make-encap-type-applicative)
+      (kernel-env-bind! env "$let"         kernel-let-operative)
+      (kernel-env-bind! env "$let*"        kernel-let*-operative)
+      (kernel-env-bind! env "$define-in!"  kernel-define-in!-operative)
+      env)))

lib/kernel/tests/encap.sx

@@ -0,0 +1,171 @@
+;; lib/kernel/tests/encap.sx — exercises make-encapsulation-type.
+;;
+;; The Phase 5 Kernel idiom: build opaque types whose constructor,
+;; predicate, and accessor are all standard Kernel applicatives. The
+;; identity is per-call, so two `(make-encapsulation-type)` calls
+;; produce non-interchangeable families.
+
+(define ken-suite (refl-make-test-suite))
+(define ken-test  (fn (n a e) (refl-test ken-suite n a e)))
+
+(define ken-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+;; A helper that builds a standard env with `encap`/`pred?`/`decap`
+;; bound from a single call to make-encapsulation-type.
+(define
+  ken-make-encap-env
+  (fn
+    ()
+    (let
+      ((env (kernel-standard-env)))
+      (ken-eval-in "($define! triple (make-encapsulation-type))" env)
+      (ken-eval-in "($define! encap (car triple))" env)
+      (ken-eval-in "($define! pred? (car (cdr triple)))" env)
+      (ken-eval-in "($define! decap (car (cdr (cdr triple))))" env)
+      env)))
+
+;; ── construction ────────────────────────────────────────────────
+(ken-test
+  "make: returns 3-element list"
+  (ken-eval-in "(length (make-encapsulation-type))" (kernel-standard-env))
+  3)
+
+(ken-test
+  "make: first is applicative"
+  (kernel-applicative?
+    (ken-eval-in "(car (make-encapsulation-type))" (kernel-standard-env)))
+  true)
+
+(ken-test
+  "make: second is applicative"
+  (kernel-applicative?
+    (ken-eval-in
+      "(car (cdr (make-encapsulation-type)))"
+      (kernel-standard-env)))
+  true)
+
+(ken-test
+  "make: third is applicative"
+  (kernel-applicative?
+    (ken-eval-in
+      "(car (cdr (cdr (make-encapsulation-type))))"
+      (kernel-standard-env)))
+  true)
+
+;; ── round-trip ──────────────────────────────────────────────────
+(ken-test
+  "round-trip: number"
+  (ken-eval-in "(decap (encap 42))" (ken-make-encap-env))
+  42)
+
+(ken-test
+  "round-trip: string"
+  (ken-eval-in "(decap (encap ($quote hello)))" (ken-make-encap-env))
+  "hello")
+
+(ken-test
+  "round-trip: list"
+  (ken-eval-in "(decap (encap (list 1 2 3)))" (ken-make-encap-env))
+  (list 1 2 3))
+
+;; ── predicate ───────────────────────────────────────────────────
+(ken-test
+  "pred?: wrapped value"
+  (ken-eval-in "(pred? (encap 1))" (ken-make-encap-env))
+  true)
+
+(ken-test
+  "pred?: raw value"
+  (ken-eval-in "(pred? 1)" (ken-make-encap-env))
+  false)
+
+(ken-test
+  "pred?: raw string"
+  (ken-eval-in "(pred? ($quote foo))" (ken-make-encap-env))
+  false)
+
+(ken-test
+  "pred?: raw list"
+  (ken-eval-in "(pred? (list))" (ken-make-encap-env))
+  false)
+
+;; ── opacity: different families are not interchangeable ─────────
+(ken-test
+  "opacity: foreign value rejected by predicate"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in "($define! tA (make-encapsulation-type))" env)
+    (ken-eval-in "($define! tB (make-encapsulation-type))" env)
+    (ken-eval-in "($define! encA (car tA))" env)
+    (ken-eval-in "($define! predB (car (cdr tB)))" env)
+    (ken-eval-in "(predB (encA 42))" env))
+  false)
+
+(ken-test
+  "opacity: decap rejects foreign value"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in "($define! tA (make-encapsulation-type))" env)
+    (ken-eval-in "($define! tB (make-encapsulation-type))" env)
+    (ken-eval-in "($define! encA (car tA))" env)
+    (ken-eval-in "($define! decapB (car (cdr (cdr tB))))" env)
+    (guard (e (true :raised)) (ken-eval-in "(decapB (encA 42))" env)))
+  :raised)
+
+(ken-test
+  "opacity: decap rejects raw value"
+  (guard
+    (e (true :raised))
+    (ken-eval-in "(decap 42)" (ken-make-encap-env)))
+  :raised)
+
+;; ── promise: classic Kernel encapsulation use case ──────────────
+;; A "promise" wraps a thunk to compute on demand and memoises the
+;; first result. Built entirely with the standard encap idiom.
+(ken-test
+  "promise: force returns thunk result"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! make-promise (car ptriple))\n         ($define! promise? (car (cdr ptriple)))\n         ($define! decode-promise (car (cdr (cdr ptriple))))\n         ($define! force ($lambda (p) ((decode-promise p))))\n         ($define! delay ($lambda (thunk) (make-promise thunk)))\n         (force (delay ($lambda () (+ 19 23)))))"
+      env))
+  42)
+
+(ken-test
+  "promise: promise? recognises its own type"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! make-promise (car ptriple))\n         ($define! promise? (car (cdr ptriple)))\n         (promise? (make-promise ($lambda () 42))))"
+      env))
+  true)
+
+(ken-test
+  "promise: promise? false on plain value"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! ptriple (make-encapsulation-type))\n         ($define! promise? (car (cdr ptriple)))\n         (promise? 99))"
+      env))
+  false)
+
+;; ── independent families don't leak ─────────────────────────────
+(ken-test
+  "two families: distinct identity"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! t1 (make-encapsulation-type))\n         ($define! t2 (make-encapsulation-type))\n         ($define! enc1 (car t1))\n         ($define! pred2 (car (cdr t2)))\n         (pred2 (enc1 ($quote stuff))))"
+      env))
+  false)
+
+(ken-test
+  "same family: re-bound shares identity"
+  (let
+    ((env (kernel-standard-env)))
+    (ken-eval-in
+      "($sequence\n         ($define! t (make-encapsulation-type))\n         ($define! e (car t))\n         ($define! p (car (cdr t)))\n         ($define! d (car (cdr (cdr t))))\n         (list (p (e 7)) (d (e 7))))"
+      env))
+  (list true 7))
+
+(define ken-tests-run! (fn () (refl-test-report ken-suite)))

lib/kernel/tests/eval.sx

@@ -0,0 +1,258 @@
+;; lib/kernel/tests/eval.sx — exercises lib/kernel/eval.sx.
+;;
+;; Phase 2 covers literal evaluation, symbol lookup, and combiner
+;; dispatch (operative vs applicative). Standard-environment operatives
+;; ($if, $define!, $lambda, …) arrive in Phase 4, so tests build a
+;; minimal env on the fly and verify the dispatch contract directly.
+
+(define ke-suite (refl-make-test-suite))
+(define ke-test  (fn (n a e) (refl-test ke-suite n a e)))
+
+;; ── helpers ──────────────────────────────────────────────────────
+
+(define ke-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+(define
+  ke-make-test-env
+  (fn
+    ()
+    (let
+      ((env (kernel-make-env)))
+      (kernel-env-bind!
+        env
+        "+"
+        (kernel-make-primitive-applicative
+          (fn (args) (+ (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "list"
+        (kernel-make-primitive-applicative (fn (args) args)))
+      (kernel-env-bind!
+        env
+        "$quote"
+        (kernel-make-primitive-operative (fn (args dyn-env) (first args))))
+      (kernel-env-bind!
+        env
+        "$if"
+        (kernel-make-primitive-operative
+          (fn
+            (args dyn-env)
+            (if
+              (kernel-eval (first args) dyn-env)
+              (kernel-eval (nth args 1) dyn-env)
+              (kernel-eval (nth args 2) dyn-env)))))
+      env)))
+
+;; ── literal evaluation ───────────────────────────────────────────
+(ke-test "lit: number" (ke-eval-src "42" (kernel-make-env)) 42)
+(ke-test "lit: zero" (ke-eval-src "0" (kernel-make-env)) 0)
+(ke-test "lit: float" (ke-eval-src "3.14" (kernel-make-env)) 3.14)
+(ke-test "lit: true" (ke-eval-src "#t" (kernel-make-env)) true)
+(ke-test "lit: false" (ke-eval-src "#f" (kernel-make-env)) false)
+(ke-test "lit: string" (ke-eval-src "\"hello\"" (kernel-make-env)) "hello")
+(ke-test "lit: empty list" (ke-eval-src "()" (kernel-make-env)) (list))
+
+;; ── symbol lookup ────────────────────────────────────────────────
+(ke-test
+  "sym: bound to number"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "x" 100)
+    (ke-eval-src "x" env))
+  100)
+
+(ke-test
+  "sym: bound to string"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "name" "kernel")
+    (ke-eval-src "name" env))
+  "kernel")
+
+(ke-test
+  "sym: parent-chain lookup"
+  (let
+    ((p (kernel-make-env)))
+    (kernel-env-bind! p "outer" 1)
+    (let
+      ((c (kernel-extend-env p)))
+      (kernel-env-bind! c "inner" 2)
+      (+ (ke-eval-src "outer" c) (ke-eval-src "inner" c))))
+  3)
+
+(ke-test
+  "sym: child shadows parent"
+  (let
+    ((p (kernel-make-env)))
+    (kernel-env-bind! p "x" 1)
+    (let
+      ((c (kernel-extend-env p)))
+      (kernel-env-bind! c "x" 2)
+      (ke-eval-src "x" c)))
+  2)
+
+(ke-test
+  "env-has?: present"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "x" 1)
+    (kernel-env-has? env "x"))
+  true)
+
+(ke-test
+  "env-has?: missing"
+  (kernel-env-has? (kernel-make-env) "nope")
+  false)
+
+;; ── tagged-value predicates ─────────────────────────────────────
+(ke-test
+  "tag: operative?"
+  (kernel-operative? (kernel-make-primitive-operative (fn (a e) nil)))
+  true)
+
+(ke-test
+  "tag: applicative?"
+  (kernel-applicative? (kernel-make-primitive-applicative (fn (a) nil)))
+  true)
+
+(ke-test
+  "tag: combiner? operative"
+  (kernel-combiner? (kernel-make-primitive-operative (fn (a e) nil)))
+  true)
+
+(ke-test
+  "tag: combiner? applicative"
+  (kernel-combiner? (kernel-make-primitive-applicative (fn (a) nil)))
+  true)
+
+(ke-test "tag: combiner? number" (kernel-combiner? 42) false)
+
+(ke-test "tag: number is not operative" (kernel-operative? 42) false)
+
+;; ── wrap / unwrap ────────────────────────────────────────────────
+(ke-test
+  "wrap+unwrap roundtrip"
+  (let
+    ((op (kernel-make-primitive-operative (fn (a e) :sentinel))))
+    (= (kernel-unwrap (kernel-wrap op)) op))
+  true)
+
+(ke-test
+  "wrap produces applicative"
+  (kernel-applicative?
+    (kernel-wrap (kernel-make-primitive-operative (fn (a e) nil))))
+  true)
+
+(ke-test
+  "unwrap of primitive-applicative is operative"
+  (kernel-operative?
+    (kernel-unwrap (kernel-make-primitive-applicative (fn (a) nil))))
+  true)
+
+;; ── combiner dispatch — applicatives evaluate their args ─────────
+(ke-test
+  "applicative: simple call"
+  (ke-eval-src "(+ 2 3)" (ke-make-test-env))
+  5)
+
+(ke-test
+  "applicative: nested"
+  (ke-eval-src "(+ (+ 1 2) (+ 3 4))" (ke-make-test-env))
+  10)
+
+(ke-test
+  "applicative: receives evaluated args"
+  (let
+    ((env (ke-make-test-env)))
+    (kernel-env-bind! env "x" 10)
+    (kernel-env-bind! env "y" 20)
+    (ke-eval-src "(+ x y)" env))
+  30)
+
+(ke-test
+  "applicative: list builds an SX list of values"
+  (let
+    ((env (ke-make-test-env)))
+    (kernel-env-bind! env "a" 1)
+    (kernel-env-bind! env "b" 2)
+    (ke-eval-src "(list a b 99)" env))
+  (list 1 2 99))
+
+;; ── combiner dispatch — operatives DO NOT evaluate their args ───
+(ke-test
+  "operative: $quote returns symbol unevaluated"
+  (ke-eval-src "($quote foo)" (ke-make-test-env))
+  "foo")
+
+(ke-test
+  "operative: $quote returns list unevaluated"
+  (ke-eval-src "($quote (+ 1 2))" (ke-make-test-env))
+  (list "+" 1 2))
+
+(ke-test
+  "operative: $if true branch"
+  (ke-eval-src "($if #t 1 2)" (ke-make-test-env))
+  1)
+
+(ke-test
+  "operative: $if false branch"
+  (ke-eval-src "($if #f 1 2)" (ke-make-test-env))
+  2)
+
+(ke-test
+  "operative: $if doesn't eval untaken branch"
+  (ke-eval-src "($if #t 99 unbound)" (ke-make-test-env))
+  99)
+
+(ke-test
+  "operative: $if takes dynamic env for branches"
+  (let
+    ((env (ke-make-test-env)))
+    (kernel-env-bind! env "x" 7)
+    (ke-eval-src "($if #t x 0)" env))
+  7)
+
+;; ── operative built ON-THE-FLY can inspect raw expressions ──────
+(ke-test
+  "operative: sees raw symbol head"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind!
+      env
+      "head"
+      (kernel-make-primitive-operative (fn (args dyn-env) (first args))))
+    (ke-eval-src "(head (+ 1 2))" env))
+  (list "+" 1 2))
+
+(ke-test
+  "operative: sees dynamic env"
+  (let
+    ((env (kernel-make-env)))
+    (kernel-env-bind! env "x" 999)
+    (kernel-env-bind!
+      env
+      "$probe"
+      (kernel-make-primitive-operative
+        (fn (args dyn-env) (kernel-env-lookup dyn-env "x"))))
+    (ke-eval-src "($probe ignored)" env))
+  999)
+
+;; ── error cases ──────────────────────────────────────────────────
+(ke-test
+  "error: unbound symbol"
+  (guard
+    (e (true :raised))
+    (kernel-eval (kernel-parse "nope") (kernel-make-env)))
+  :raised)
+
+(ke-test
+  "error: combine non-combiner"
+  (guard
+    (e (true :raised))
+    (let
+      ((env (kernel-make-env)))
+      (kernel-env-bind! env "x" 42)
+      (kernel-eval (kernel-parse "(x 1)") env)))
+  :raised)
+
+(define ke-tests-run! (fn () (refl-test-report ke-suite)))

lib/kernel/tests/hygiene.sx

@@ -0,0 +1,208 @@
+;; lib/kernel/tests/hygiene.sx — exercises Phase 6 hygiene helpers.
+;;
+;; Kernel-on-SX is hygienic by default: $vau/$lambda close over their
+;; static env, and bind their formals (plus any $define!s in the body)
+;; in a CHILD env. The caller's env is only mutated when user code
+;; explicitly threads the env-param through `eval` or `$define-in!`.
+;;
+;; These tests verify the property, plus the Phase 6 helpers ($let and
+;; $define-in!). Shutt's full scope-set hygiene (lifted symbols with
+;; provenance markers) is research-grade and is NOT implemented — see
+;; the plan's reflective-API notes for the proposed approach.
+
+(define kh-suite (refl-make-test-suite))
+(define kh-test  (fn (n a e) (refl-test kh-suite n a e)))
+
+(define kh-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+;; ── Default hygiene: $define! inside operative body stays local ─
+
+(kh-test
+  "hygiene: vau body $define! doesn't escape"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in
+      "($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
+      env)
+    (kh-eval-in "(my-op)" env)
+    (kh-eval-in "x" env))
+  1)
+
+(kh-test
+  "hygiene: vau body $define! visible inside body"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in
+      "($define! my-op ($vau () _ ($sequence ($define! x 999) x)))"
+      env)
+    (kh-eval-in "(my-op)" env))
+  999)
+
+(kh-test
+  "hygiene: lambda body $define! doesn't escape"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! y 50)" env)
+    (kh-eval-in "($define! f ($lambda () ($sequence ($define! y 7) y)))" env)
+    (kh-eval-in "(f)" env)
+    (kh-eval-in "y" env))
+  50)
+
+(kh-test
+  "hygiene: caller's binding visible inside operative"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! caller-x 88)" env)
+    (kh-eval-in "($define! my-op ($vau () _ caller-x))" env)
+    (kh-eval-in "(my-op)" env))
+  88)
+
+;; ── $let — proper hygienic scoping ──────────────────────────────
+
+(kh-test
+  "let: returns body value"
+  (kh-eval-in "($let ((x 5)) (+ x 1))" (kernel-standard-env))
+  6)
+
+(kh-test
+  "let: multiple bindings"
+  (kh-eval-in "($let ((x 3) (y 4)) (+ x y))" (kernel-standard-env))
+  7)
+
+(kh-test
+  "let: bindings shadow outer"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let ((x 99)) x)" env))
+  99)
+
+(kh-test
+  "let: bindings don't leak after"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let ((x 99)) x)" env)
+    (kh-eval-in "x" env))
+  1)
+
+(kh-test
+  "let: parallel — RHS sees outer, not inner"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let ((x 10) (y x)) y)" env))
+  1)
+
+(kh-test
+  "let: nested"
+  (kh-eval-in "($let ((x 1)) ($let ((y 2)) (+ x y)))" (kernel-standard-env))
+  3)
+
+(kh-test
+  "let: error on malformed binding"
+  (guard
+    (e (true :raised))
+    (kh-eval-in "($let ((x)) x)" (kernel-standard-env)))
+  :raised)
+
+(kh-test
+  "let: error on non-symbol name"
+  (guard
+    (e (true :raised))
+    (kh-eval-in "($let ((1 2)) 1)" (kernel-standard-env)))
+  :raised)
+
+;; ── $define-in! — explicit env targeting ────────────────────────
+
+(kh-test
+  "define-in!: binds in chosen env, not dyn-env"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! sandbox (make-environment))" env)
+    (kh-eval-in "($define-in! sandbox z 77)" env)
+    (kernel-env-has? (kh-eval-in "sandbox" env) "z"))
+  true)
+
+(kh-test
+  "define-in!: doesn't pollute caller"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! sandbox (make-environment))" env)
+    (kh-eval-in "($define-in! sandbox z 77)" env)
+    (kernel-env-has? env "z"))
+  false)
+
+(kh-test
+  "define-in!: error on non-env target"
+  (guard
+    (e (true :raised))
+    (let
+      ((env (kernel-standard-env)))
+      (kh-eval-in "($define-in! 42 x 1)" env)))
+  :raised)
+
+;; ── Closure does NOT see post-definition caller binds ───────────
+;; The classic "lexical scope wins over dynamic" test.
+
+(kh-test
+  "lexical: closure sees its own static env"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($define! get-x ($lambda () x))" env)
+    (kh-eval-in "($define! x 999)" env)
+    (kh-eval-in "(get-x)" env))
+  999)
+
+(kh-test
+  "lexical: $let-bound name invisible outside"
+  (guard
+    (e (true :raised))
+    (let
+      ((env (kernel-standard-env)))
+      (kh-eval-in "($let ((private 42)) private)" env)
+      (kh-eval-in "private" env)))
+  :raised)
+
+;; ── Operative + $let: hygiene compose ───────────────────────────
+
+(kh-test
+  "let-inside-vau: temp doesn't escape body"
+  (let
+    ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($define! op ($vau () _ ($let ((x 5)) x)))" env)
+    (kh-eval-in "(op)" env)
+    (kh-eval-in "x" env))
+  1)
+
+;; ── $let* — sequential let ──────────────────────────────────────
+(kh-test "let*: empty bindings"
+  (kh-eval-in "($let* () 42)" (kernel-standard-env)) 42)
+(kh-test "let*: single binding"
+  (kh-eval-in "($let* ((x 5)) (+ x 1))" (kernel-standard-env)) 6)
+(kh-test "let*: later sees earlier"
+  (kh-eval-in "($let* ((x 1) (y (+ x 1)) (z (+ y 1))) z)"
+              (kernel-standard-env)) 3)
+(kh-test "let*: bindings don't leak after"
+  (let ((env (kernel-standard-env)))
+    (kh-eval-in "($define! x 1)" env)
+    (kh-eval-in "($let* ((x 99) (y (+ x 1))) y)" env)
+    (kh-eval-in "x" env)) 1)
+(kh-test "let*: same-name later binding shadows earlier"
+  (kh-eval-in "($let* ((x 1) (x 2)) x)" (kernel-standard-env)) 2)
+(kh-test "let*: multi-expression body"
+  (kh-eval-in "($let* ((x 5)) ($define! double (+ x x)) double)"
+              (kernel-standard-env)) 10)
+(kh-test "let*: error on malformed binding"
+  (guard (e (true :raised))
+    (kh-eval-in "($let* ((x)) x)" (kernel-standard-env)))
+  :raised)
+(kh-test "let: multi-body"
+  (kh-eval-in "($let ((x 5)) ($define! tmp (+ x 1)) tmp)"
+              (kernel-standard-env)) 6)
+
+(define kh-tests-run! (fn () (refl-test-report kh-suite)))

lib/kernel/tests/metacircular.sx

@@ -0,0 +1,150 @@
+;; lib/kernel/tests/metacircular.sx — Kernel-in-Kernel demo.
+;;
+;; Demonstrates reflective completeness: a Kernel program implements
+;; a recognisable subset of Kernel's own evaluation rules and produces
+;; matching values for a battery of test programs.
+;;
+;; This is a SHALLOW metacircular: it dispatches on expression shape
+;; itself (numbers, booleans, lists, symbols), recursively meta-evals
+;; each argument of an applicative call, and delegates only to the
+;; host evaluator for the leaf cases (operatives, symbol lookup). The
+;; point is to show that env-as-value, first-class operatives, and
+;; first-class evaluators all line up — enough so a Kernel program
+;; can itself reason about Kernel programs.
+
+(define kmc-suite (refl-make-test-suite))
+(define kmc-test  (fn (n a e) (refl-test kmc-suite n a e)))
+
+;; Build a Kernel env with m-eval and m-apply defined. The two refer
+;; to each other and to standard primitives, so we use the standard
+;; env as the static-env for both.
+(define
+  kmc-make-env
+  (fn
+    ()
+    (let
+      ((env (kernel-standard-env)))
+      (kernel-eval
+        (kernel-parse
+          "($define! m-eval\n           ($lambda (expr env)\n             ($cond\n               ((number? expr) expr)\n               ((boolean? expr) expr)\n               ((null? expr) expr)\n               ((symbol? expr) (eval expr env))\n               ((list? expr)\n                 ($let ((head-val (m-eval (car expr) env)))\n                   ($cond\n                     ((applicative? head-val)\n                       (apply head-val\n                         (map ($lambda (a) (m-eval a env)) (cdr expr))))\n                     (else (eval expr env)))))\n               (else expr))))")
+        env)
+      env)))
+
+(define
+  kmc-eval
+  (fn
+    (src)
+    (let
+      ((env (kmc-make-env)))
+      (kernel-eval
+        (kernel-parse
+          (str "(m-eval (quote " src ") (get-current-environment))"))
+        env))))
+
+;; ── literals self-evaluate via m-eval ──────────────────────────
+(kmc-test
+  "m-eval: integer literal"
+  (kernel-eval
+    (kernel-parse "(m-eval 42 (get-current-environment))")
+    (kmc-make-env))
+  42)
+
+(kmc-test
+  "m-eval: boolean true"
+  (kernel-eval
+    (kernel-parse "(m-eval #t (get-current-environment))")
+    (kmc-make-env))
+  true)
+
+(kmc-test
+  "m-eval: boolean false"
+  (kernel-eval
+    (kernel-parse "(m-eval #f (get-current-environment))")
+    (kmc-make-env))
+  false)
+
+(kmc-test
+  "m-eval: empty list"
+  (kernel-eval
+    (kernel-parse "(m-eval () (get-current-environment))")
+    (kmc-make-env))
+  (list))
+
+;; ── symbol lookup goes through env ─────────────────────────────
+(kmc-test
+  "m-eval: symbol lookup"
+  (let
+    ((env (kmc-make-env)))
+    (kernel-eval (kernel-parse "($define! shared-x 99)") env)
+    (kernel-eval
+      (kernel-parse "(m-eval ($quote shared-x) (get-current-environment))")
+      env))
+  99)
+
+;; ── applicative calls are dispatched by m-eval recursively ─────
+(kmc-test
+  "m-eval: addition"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (+ 1 2)) (get-current-environment))")
+    (kmc-make-env))
+  3)
+
+(kmc-test
+  "m-eval: nested arithmetic"
+  (kernel-eval
+    (kernel-parse
+      "(m-eval ($quote (+ (* 2 3) (- 10 4))) (get-current-environment))")
+    (kmc-make-env))
+  12)
+
+(kmc-test
+  "m-eval: variadic +"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (+ 1 2 3 4 5)) (get-current-environment))")
+    (kmc-make-env))
+  15)
+
+(kmc-test
+  "m-eval: list construction"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (list 1 2 3)) (get-current-environment))")
+    (kmc-make-env))
+  (list 1 2 3))
+
+(kmc-test "m-eval: cons reverse-style"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (cons 0 (list 1 2))) (get-current-environment))")
+    (kmc-make-env)) (list 0 1 2))
+
+(kmc-test "m-eval: nested apply"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote (apply + (list 10 20 30))) (get-current-environment))")
+    (kmc-make-env)) 60)
+
+;; ── operatives delegate to host eval (transparently for the caller) ─
+(kmc-test
+  "m-eval: $if true branch (via delegation)"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote ($if #t 1 2)) (get-current-environment))")
+    (kmc-make-env))
+  1)
+
+(kmc-test
+  "m-eval: $if false branch"
+  (kernel-eval
+    (kernel-parse "(m-eval ($quote ($if #f 1 2)) (get-current-environment))")
+    (kmc-make-env))
+  2)
+
+;; ── m-eval can call a user-defined lambda ──────────────────────
+(kmc-test
+  "m-eval: user lambda call"
+  (let
+    ((env (kmc-make-env)))
+    (kernel-eval (kernel-parse "($define! sq ($lambda (x) (* x x)))") env)
+    (kernel-eval
+      (kernel-parse "(m-eval ($quote (sq 7)) (get-current-environment))")
+      env))
+  49)
+
+(define kmc-tests-run! (fn () (refl-test-report kmc-suite)))

lib/kernel/tests/parse.sx

@@ -0,0 +1,146 @@
+;; lib/kernel/tests/parse.sx — exercises lib/kernel/parser.sx.
+
+(define knl-suite (refl-make-test-suite))
+(define knl-test  (fn (n a e) (refl-test knl-suite n a e)))
+
+;; ── atoms: numbers ────────────────────────────────────────────────
+(knl-test "num: integer" (kernel-parse "42") 42)
+(knl-test "num: zero" (kernel-parse "0") 0)
+(knl-test "num: negative integer" (kernel-parse "-7") -7)
+(knl-test "num: positive sign" (kernel-parse "+5") 5)
+(knl-test "num: float" (kernel-parse "3.14") 3.14)
+(knl-test "num: negative float" (kernel-parse "-2.5") -2.5)
+(knl-test "num: leading dot" (kernel-parse ".5") 0.5)
+(knl-test "num: exponent" (kernel-parse "1e3") 1000)
+(knl-test "num: exponent with sign" (kernel-parse "2.5e-1") 0.25)
+(knl-test "num: capital E exponent" (kernel-parse "1E2") 100)
+
+;; ── atoms: booleans ───────────────────────────────────────────────
+(knl-test "bool: true" (kernel-parse "#t") true)
+(knl-test "bool: false" (kernel-parse "#f") false)
+
+;; ── atoms: empty list (Kernel nil) ────────────────────────────────
+(knl-test "nil: ()" (kernel-parse "()") (list))
+(knl-test "nil: (= () (list))" (= (kernel-parse "()") (list)) true)
+
+;; ── atoms: symbols ────────────────────────────────────────────────
+(knl-test "sym: word" (kernel-parse "foo") "foo")
+(knl-test "sym: hyphenated" (kernel-parse "foo-bar") "foo-bar")
+(knl-test "sym: dollar-bang" (kernel-parse "$define!") "$define!")
+(knl-test "sym: question" (kernel-parse "null?") "null?")
+(knl-test "sym: lt-eq" (kernel-parse "<=") "<=")
+(knl-test "sym: bare plus" (kernel-parse "+") "+")
+(knl-test "sym: bare minus" (kernel-parse "-") "-")
+(knl-test "sym: plus-letter" (kernel-parse "+a") "+a")
+(knl-test "sym: arrow" (kernel-parse "->") "->")
+(knl-test "sym: dot-prefixed" (kernel-parse ".foo") ".foo")
+
+;; ── atoms: strings ────────────────────────────────────────────────
+(knl-test "str: empty" (kernel-string-value (kernel-parse "\"\"")) "")
+(knl-test
+  "str: hello"
+  (kernel-string-value (kernel-parse "\"hello\""))
+  "hello")
+(knl-test "str: predicate" (kernel-string? (kernel-parse "\"x\"")) true)
+(knl-test "str: not symbol" (kernel-string? (kernel-parse "x")) false)
+(knl-test
+  "str: escape newline"
+  (kernel-string-value (kernel-parse "\"a\\nb\""))
+  "a\nb")
+(knl-test
+  "str: escape tab"
+  (kernel-string-value (kernel-parse "\"a\\tb\""))
+  "a\tb")
+(knl-test
+  "str: escape quote"
+  (kernel-string-value (kernel-parse "\"a\\\"b\""))
+  "a\"b")
+(knl-test
+  "str: escape backslash"
+  (kernel-string-value (kernel-parse "\"a\\\\b\""))
+  "a\\b")
+
+;; ── lists ─────────────────────────────────────────────────────────
+(knl-test "list: flat" (kernel-parse "(a b c)") (list "a" "b" "c"))
+(knl-test
+  "list: nested"
+  (kernel-parse "(a (b c) d)")
+  (list "a" (list "b" "c") "d"))
+(knl-test
+  "list: deeply nested"
+  (kernel-parse "(((x)))")
+  (list (list (list "x"))))
+(knl-test
+  "list: mixed atoms"
+  (kernel-parse "(1 #t foo)")
+  (list 1 true "foo"))
+(knl-test
+  "list: empty inside"
+  (kernel-parse "(a () b)")
+  (list "a" (list) "b"))
+
+;; ── whitespace + comments ─────────────────────────────────────────
+(knl-test "ws: leading" (kernel-parse "   42") 42)
+(knl-test "ws: trailing" (kernel-parse "42   ") 42)
+(knl-test "ws: tabs/newlines" (kernel-parse "\n\t  42 \n") 42)
+(knl-test "comment: line" (kernel-parse "; nope\n42") 42)
+(knl-test "comment: trailing" (kernel-parse "42 ; tail") 42)
+(knl-test
+  "comment: inside list"
+  (kernel-parse "(a ; mid\n  b)")
+  (list "a" "b"))
+
+;; ── parse-all ─────────────────────────────────────────────────────
+(knl-test "all: empty input" (kernel-parse-all "") (list))
+(knl-test "all: only whitespace" (kernel-parse-all "   ") (list))
+(knl-test "all: only comment" (kernel-parse-all "; nope") (list))
+(knl-test
+  "all: three forms"
+  (kernel-parse-all "1 2 3")
+  (list 1 2 3))
+(knl-test
+  "all: mixed"
+  (kernel-parse-all "($if #t 1 2) foo")
+  (list (list "$if" true 1 2) "foo"))
+
+;; ── classic Kernel programs (smoke) ───────────────────────────────
+(knl-test
+  "klisp: vau form"
+  (kernel-parse "($vau (x e) e (eval x e))")
+  (list "$vau" (list "x" "e") "e" (list "eval" "x" "e")))
+(knl-test
+  "klisp: define lambda"
+  (kernel-parse "($define! sq ($lambda (x) (* x x)))")
+  (list "$define!" "sq" (list "$lambda" (list "x") (list "*" "x" "x"))))
+
+;; ── round-trip identity for primitive symbols ─────────────────────
+(knl-test "identity: $vau" (kernel-parse "$vau") "$vau")
+(knl-test "identity: $lambda" (kernel-parse "$lambda") "$lambda")
+(knl-test "identity: wrap" (kernel-parse "wrap") "wrap")
+(knl-test "identity: unwrap" (kernel-parse "unwrap") "unwrap")
+
+;; ── reader macros ─────────────────────────────────────────────────
+(knl-test "reader: 'foo  → ($quote foo)"
+  (kernel-parse "'foo") (list "$quote" "foo"))
+(knl-test "reader: '(a b c)"
+  (kernel-parse "'(a b c)") (list "$quote" (list "a" "b" "c")))
+(knl-test "reader: nested quotes"
+  (kernel-parse "''x")
+  (list "$quote" (list "$quote" "x")))
+(knl-test "reader: ` quasiquote"
+  (kernel-parse "`x") (list "$quasiquote" "x"))
+(knl-test "reader: , unquote"
+  (kernel-parse ",x") (list "$unquote" "x"))
+(knl-test "reader: ,@ unquote-splicing"
+  (kernel-parse ",@x") (list "$unquote-splicing" "x"))
+(knl-test "reader: quasi-mix"
+  (kernel-parse "`(a ,b ,@c)")
+  (list "$quasiquote"
+        (list "a"
+              (list "$unquote" "b")
+              (list "$unquote-splicing" "c"))))
+(knl-test "reader: quote separates from neighbouring atom"
+  (kernel-parse "(a 'b c)")
+  (list "a" (list "$quote" "b") "c"))
+
+(define knl-tests-run! (fn () (refl-test-report knl-suite)))

lib/kernel/tests/standard.sx

@@ -0,0 +1,433 @@
+;; lib/kernel/tests/standard.sx — exercises the Kernel standard env.
+;;
+;; Phase 4 tests verify that the standard env is rich enough to run
+;; classic Kernel programs: factorial via recursion, list operations,
+;; first-class environment manipulation. Each test starts from a fresh
+;; standard env via `(kernel-standard-env)`.
+
+(define ks-suite (refl-make-test-suite))
+(define ks-test  (fn (n a e) (refl-test ks-suite n a e)))
+
+(define
+  ks-eval
+  (fn (src) (kernel-eval (kernel-parse src) (kernel-standard-env))))
+
+(define ks-eval-in (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+(define
+  ks-eval-all
+  (fn (src env) (kernel-eval-program (kernel-parse-all src) env)))
+
+;; ── $if ──────────────────────────────────────────────────────────
+(ks-test "if: true branch" (ks-eval "($if #t 1 2)") 1)
+(ks-test "if: false branch" (ks-eval "($if #f 1 2)") 2)
+(ks-test "if: predicate"
+  (ks-eval "($if (<=? 1 2) ($quote yes) ($quote no))") "yes")
+(ks-test
+  "if: untaken branch not evaluated"
+  (ks-eval "($if #t 42 nope)")
+  42)
+
+;; ── $define! + arithmetic ───────────────────────────────────────
+(ks-test
+  "define!: returns value"
+  (let ((env (kernel-standard-env))) (ks-eval-in "($define! x 5)" env))
+  5)
+
+(ks-test
+  "define!: bound in env"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 5)" env)
+    (ks-eval-in "x" env))
+  5)
+
+(ks-test "arith: +" (ks-eval "(+ 2 3)") 5)
+(ks-test "arith: -" (ks-eval "(- 10 4)") 6)
+(ks-test "arith: *" (ks-eval "(* 6 7)") 42)
+(ks-test "arith: /" (ks-eval "(/ 20 5)") 4)
+(ks-test "cmp: <  true" (ks-eval "(< 1 2)") true)
+(ks-test "cmp: <  false" (ks-eval "(< 2 1)") false)
+(ks-test "cmp: >=" (ks-eval "(>=? 2 2)") true)
+(ks-test "cmp: <=" (ks-eval "(<=? 2 3)") true)
+(ks-test "cmp: =" (ks-eval "(=? 7 7)") true)
+
+;; ── $sequence ────────────────────────────────────────────────────
+(ks-test "sequence: empty" (ks-eval "($sequence)") nil)
+(ks-test "sequence: single" (ks-eval "($sequence 99)") 99)
+(ks-test
+  "sequence: multi-effect"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($sequence ($define! a 1) ($define! b 2) (+ a b))" env))
+  3)
+
+;; ── list primitives ──────────────────────────────────────────────
+(ks-test
+  "list: builds"
+  (ks-eval "(list 1 2 3)")
+  (list 1 2 3))
+(ks-test "list: empty" (ks-eval "(list)") (list))
+(ks-test
+  "cons: prepend"
+  (ks-eval "(cons 0 (list 1 2 3))")
+  (list 0 1 2 3))
+(ks-test "car: head" (ks-eval "(car (list 10 20 30))") 10)
+(ks-test
+  "cdr: tail"
+  (ks-eval "(cdr (list 10 20 30))")
+  (list 20 30))
+(ks-test "length: 3" (ks-eval "(length (list 1 2 3))") 3)
+(ks-test "length: 0" (ks-eval "(length (list))") 0)
+(ks-test "null?: empty" (ks-eval "(null? (list))") true)
+(ks-test "null?: nonempty" (ks-eval "(null? (list 1))") false)
+(ks-test "pair?: empty" (ks-eval "(pair? (list))") false)
+(ks-test "pair?: nonempty" (ks-eval "(pair? (list 1))") true)
+
+;; ── $quote ───────────────────────────────────────────────────────
+(ks-test "quote: symbol" (ks-eval "($quote foo)") "foo")
+(ks-test
+  "quote: list"
+  (ks-eval "($quote (+ 1 2))")
+  (list "+" 1 2))
+
+;; ── boolean / not ────────────────────────────────────────────────
+(ks-test "not: true" (ks-eval "(not #t)") false)
+(ks-test "not: false" (ks-eval "(not #f)") true)
+
+;; ── factorial ────────────────────────────────────────────────────
+(ks-test
+  "factorial: 5!"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
+      env)
+    (ks-eval-in "(factorial 5)" env))
+  120)
+
+(ks-test
+  "factorial: 0! = 1"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
+      env)
+    (ks-eval-in "(factorial 0)" env))
+  1)
+
+(ks-test
+  "factorial: 10!"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! factorial ($lambda (n) ($if (<=? n 1) 1 (* n (factorial (- n 1))))))"
+      env)
+    (ks-eval-in "(factorial 10)" env))
+  3628800)
+
+;; ── recursive list operations ────────────────────────────────────
+(ks-test
+  "sum: recursive over list"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! sum ($lambda (xs) ($if (null? xs) 0 (+ (car xs) (sum (cdr xs))))))"
+      env)
+    (ks-eval-in "(sum (list 1 2 3 4 5))" env))
+  15)
+
+(ks-test
+  "len: recursive count"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! mylen ($lambda (xs) ($if (null? xs) 0 (+ 1 (mylen (cdr xs))))))"
+      env)
+    (ks-eval-in "(mylen (list 1 2 3 4))" env))
+  4)
+
+(ks-test
+  "map-add1: build new list"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! add1-all ($lambda (xs) ($if (null? xs) (list) (cons (+ 1 (car xs)) (add1-all (cdr xs))))))"
+      env)
+    (ks-eval-in "(add1-all (list 10 20 30))" env))
+  (list 11 21 31))
+
+;; ── eval as a first-class applicative ────────────────────────────
+(ks-test
+  "eval: applies to constructed form"
+  (ks-eval "(eval (list ($quote +) 2 3) (get-current-environment))")
+  5)
+
+(ks-test
+  "eval: with a fresh make-environment"
+  (guard
+    (e (true :raised))
+    (ks-eval "(eval ($quote (+ 1 2)) (make-environment))"))
+  :raised)
+
+(ks-test
+  "eval: in extended env sees parent's bindings"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($define! shared 7)" env)
+    (ks-eval-in
+      "(eval ($quote shared) (make-environment (get-current-environment)))"
+      env))
+  7)
+
+;; ── get-current-environment ──────────────────────────────────────
+(ks-test
+  "get-current-environment: returns env"
+  (kernel-env? (ks-eval "(get-current-environment)"))
+  true)
+
+(ks-test
+  "get-current-environment: contains $if"
+  (let
+    ((env (ks-eval "(get-current-environment)")))
+    (kernel-env-has? env "$if"))
+  true)
+
+(ks-test
+  "make-environment: empty"
+  (let ((env (ks-eval "(make-environment)"))) (kernel-env-has? env "$if"))
+  false)
+
+(ks-test
+  "make-environment: child sees parent"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in "($define! marker 123)" env)
+    (let
+      ((child (ks-eval-in "(make-environment (get-current-environment))" env)))
+      (kernel-env-has? child "marker")))
+  true)
+
+;; ── closures and lexical scope ───────────────────────────────────
+(ks-test
+  "closure: captures binding"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! make-adder ($lambda (n) ($lambda (x) (+ x n))))"
+      env)
+    (ks-eval-in "($define! add5 (make-adder 5))" env)
+    (ks-eval-in "(add5 10)" env))
+  15)
+
+(ks-test
+  "closure: nested lookups"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! curry-add ($lambda (a) ($lambda (b) ($lambda (c) (+ a (+ b c))))))"
+      env)
+    (ks-eval-in "(((curry-add 1) 2) 3)" env))
+  6)
+
+;; ── operative defined in standard env can reach $define! ─────────
+(ks-test
+  "custom: define-via-vau"
+  (let
+    ((env (kernel-standard-env)))
+    (ks-eval-in
+      "($define! $let-it ($vau (name expr) e ($sequence ($define! tmp (eval expr e)) (eval (list ($quote $define!) name (list ($quote $quote) tmp)) e) tmp)))"
+      env)
+    (ks-eval-in "($let-it z 77)" env)
+    (ks-eval-in "z" env))
+  77)
+
+;; ── quasiquote ──────────────────────────────────────────────────
+(ks-test "qq: plain atom"      (ks-eval "`hello") "hello")
+(ks-test "qq: plain list"      (ks-eval "`(a b c)") (list "a" "b" "c"))
+(ks-test "qq: unquote splices value"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 42)" env)
+    (ks-eval-in "`(a ,x b)" env)) (list "a" 42 "b"))
+(ks-test "qq: unquote-splicing splices list"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! xs (list 1 2 3))" env)
+    (ks-eval-in "`(a ,@xs b)" env)) (list "a" 1 2 3 "b"))
+(ks-test "qq: unquote-splicing at end"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! xs (list 9 8))" env)
+    (ks-eval-in "`(a b ,@xs)" env)) (list "a" "b" 9 8))
+(ks-test "qq: unquote-splicing at start"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! xs (list 1 2))" env)
+    (ks-eval-in "`(,@xs c)" env)) (list 1 2 "c"))
+(ks-test "qq: nested list with unquote inside"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 5)" env)
+    (ks-eval-in "`(a (b ,x) c)" env))
+  (list "a" (list "b" 5) "c"))
+(ks-test "qq: error on bare unquote-splicing into non-list"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! x 42)" env)
+    (guard (e (true :raised))
+      (ks-eval-in "`(a ,@x b)" env)))
+  :raised)
+
+;; ── $cond / $when / $unless ─────────────────────────────────────
+(ks-test "cond: first match"
+  (ks-eval "($cond (#f 1) (#t 2) (#t 3))") 2)
+(ks-test "cond: else fallback"
+  (ks-eval "($cond (#f 1) (else 99))") 99)
+(ks-test "cond: no match returns nil"
+  (ks-eval "($cond (#f 1) (#f 2))") nil)
+(ks-test "cond: empty clauses returns nil"
+  (ks-eval "($cond)") nil)
+(ks-test "cond: multi-expr body"
+  (ks-eval "($cond (#t 1 2 3))") 3)
+(ks-test "cond: doesn't evaluate untaken clauses"
+  ;; If the second clause's test were evaluated, the unbound `nope` would error.
+  (ks-eval "($cond (#t 7) (nope ignored))") 7)
+(ks-test "cond: predicate evaluation"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! n 5)" env)
+    (ks-eval-in "($cond ((< n 0) ($quote negative)) ((= n 0) ($quote zero)) (else ($quote positive)))" env))
+  "positive")
+
+(ks-test "when: true runs body"
+  (ks-eval "($when #t 1 2 3)") 3)
+(ks-test "when: false returns nil"
+  (ks-eval "($when #f 1 2 3)") nil)
+(ks-test "when: skips body when false"
+  (ks-eval "($when #f nope)") nil)
+
+(ks-test "unless: false runs body"
+  (ks-eval "($unless #f 99)") 99)
+(ks-test "unless: true returns nil"
+  (ks-eval "($unless #t 99)") nil)
+(ks-test "unless: skips body when true"
+  (ks-eval "($unless #t nope)") nil)
+
+;; ── $and? / $or? short-circuit ──────────────────────────────────
+(ks-test "and: empty returns true"   (ks-eval "($and?)") true)
+(ks-test "and: single returns value" (ks-eval "($and? 42)") 42)
+(ks-test "and: all true returns last"
+  (ks-eval "($and? 1 2 3)") 3)
+(ks-test "and: first false short-circuits"
+  (ks-eval "($and? #f nope)") false)
+(ks-test "and: false in middle short-circuits"
+  (ks-eval "($and? 1 #f nope)") false)
+(ks-test "or: empty returns false"  (ks-eval "($or?)") false)
+(ks-test "or: single returns value" (ks-eval "($or? 42)") 42)
+(ks-test "or: first truthy short-circuits"
+  (ks-eval "($or? 99 nope)") 99)
+(ks-test "or: all false returns last"
+  (ks-eval "($or? #f #f #f)") false)
+(ks-test "or: middle truthy"
+  (ks-eval "($or? #f 42 nope)") 42)
+
+;; ── variadic arithmetic ─────────────────────────────────────────
+(ks-test "+: zero args = 0"    (ks-eval "(+)") 0)
+(ks-test "+: one arg = arg"    (ks-eval "(+ 7)") 7)
+(ks-test "+: two args"         (ks-eval "(+ 3 4)") 7)
+(ks-test "+: five args"        (ks-eval "(+ 1 2 3 4 5)") 15)
+
+(ks-test "*: zero args = 1"    (ks-eval "(*)") 1)
+(ks-test "*: one arg"          (ks-eval "(* 7)") 7)
+(ks-test "*: four args"        (ks-eval "(* 1 2 3 4)") 24)
+
+(ks-test "-: one arg negates"  (ks-eval "(- 10)") -10)
+(ks-test "-: two args"         (ks-eval "(- 10 3)") 7)
+(ks-test "-: four args fold"   (ks-eval "(- 100 1 2 3)") 94)
+
+(ks-test "/: two args"         (ks-eval "(/ 20 5)") 4)
+(ks-test "/: three args fold"  (ks-eval "(/ 100 2 5)") 10)
+
+;; ── variadic chained comparison ─────────────────────────────────
+(ks-test "<: chained ascending"  (ks-eval "(< 1 2 3 4 5)") true)
+(ks-test "<: not strict"          (ks-eval "(< 1 2 2 3)") false)
+(ks-test "<: anti-monotonic"      (ks-eval "(< 5 3)") false)
+(ks-test ">: chained descending" (ks-eval "(> 5 4 3 2 1)") true)
+(ks-test "<=? ascending equals"   (ks-eval "(<=? 1 1 2 3 3)") true)
+(ks-test "<=? violation"          (ks-eval "(<=? 1 2 1)") false)
+(ks-test ">=? descending equals" (ks-eval "(>=? 3 3 2 1)") true)
+
+;; ── list combinators ────────────────────────────────────────────
+(ks-test "map: square"
+  (ks-eval "(map ($lambda (x) (* x x)) (list 1 2 3 4))")
+  (list 1 4 9 16))
+(ks-test "map: empty list"
+  (ks-eval "(map ($lambda (x) x) (list))") (list))
+(ks-test "map: identity preserves"
+  (ks-eval "(map ($lambda (x) x) (list 1 2 3))") (list 1 2 3))
+(ks-test "map: with closure over outer"
+  (let ((env (kernel-standard-env)))
+    (ks-eval-in "($define! k 10)" env)
+    (ks-eval-in "(map ($lambda (x) (+ x k)) (list 1 2 3))" env))
+  (list 11 12 13))
+
+(ks-test "filter: positives"
+  (ks-eval "(filter ($lambda (x) (< 0 x)) (list -2 -1 0 1 2))")
+  (list 1 2))
+(ks-test "filter: empty result"
+  (ks-eval "(filter ($lambda (x) #f) (list 1 2 3))") (list))
+(ks-test "filter: all match"
+  (ks-eval "(filter ($lambda (x) #t) (list 1 2 3))") (list 1 2 3))
+
+(ks-test "reduce: sum"
+  (ks-eval "(reduce ($lambda (a b) (+ a b)) 0 (list 1 2 3 4 5))") 15)
+(ks-test "reduce: product"
+  (ks-eval "(reduce ($lambda (a b) (* a b)) 1 (list 1 2 3 4))") 24)
+(ks-test "reduce: empty returns init"
+  (ks-eval "(reduce ($lambda (a b) (+ a b)) 42 (list))") 42)
+(ks-test "reduce: build list"
+  (ks-eval "(reduce ($lambda (acc x) (cons x acc)) () (list 1 2 3))")
+  (list 3 2 1))
+
+;; ── apply ────────────────────────────────────────────────────────
+(ks-test "apply: + over list"
+  (ks-eval "(apply + (list 1 2 3 4 5))") 15)
+(ks-test "apply: lambda"
+  (ks-eval "(apply ($lambda (a b c) (* a (+ b c))) (list 2 3 4))") 14)
+(ks-test "apply: list identity"
+  (ks-eval "(apply list (list 1 2 3))") (list 1 2 3))
+(ks-test "apply: empty args list"
+  (ks-eval "(apply + (list))") 0)
+(ks-test "apply: single arg list"
+  (ks-eval "(apply ($lambda (x) (* x 10)) (list 7))") 70)
+(ks-test "apply: built via map+apply"
+  ;; (apply + (map ($lambda (x) (* x x)) (list 1 2 3))) → 1+4+9 = 14
+  (ks-eval
+    "(apply + (map ($lambda (x) (* x x)) (list 1 2 3)))") 14)
+(ks-test "apply: error on non-list args"
+  (guard (e (true :raised))
+    (ks-eval "(apply + 5)"))
+  :raised)
+
+;; ── append / reverse ────────────────────────────────────────────
+(ks-test "append: two lists"
+  (ks-eval "(append (list 1 2) (list 3 4))") (list 1 2 3 4))
+(ks-test "append: three lists"
+  (ks-eval "(append (list 1) (list 2) (list 3))") (list 1 2 3))
+(ks-test "append: empty list"
+  (ks-eval "(append)") (list))
+(ks-test "append: one list"
+  (ks-eval "(append (list 1 2 3))") (list 1 2 3))
+(ks-test "append: empty + nonempty"
+  (ks-eval "(append (list) (list 1 2))") (list 1 2))
+(ks-test "append: nonempty + empty"
+  (ks-eval "(append (list 1 2) (list))") (list 1 2))
+(ks-test "append: error on non-list"
+  (guard (e (true :raised))
+    (ks-eval "(append (list 1) 5)"))
+  :raised)
+
+(ks-test "reverse: four elements"
+  (ks-eval "(reverse (list 1 2 3 4))") (list 4 3 2 1))
+(ks-test "reverse: empty"
+  (ks-eval "(reverse (list))") (list))
+(ks-test "reverse: single"
+  (ks-eval "(reverse (list 99))") (list 99))
+(ks-test "reverse: double reverse is identity"
+  (ks-eval "(reverse (reverse (list 1 2 3)))") (list 1 2 3))
+
+(define ks-tests-run! (fn () (refl-test-report ks-suite)))

lib/kernel/tests/vau.sx

@@ -0,0 +1,297 @@
+;; lib/kernel/tests/vau.sx — exercises lib/kernel/runtime.sx.
+;;
+;; Verifies the Phase 3 promise: user-defined operatives and applicatives
+;; constructible from inside the language. Tests build a Kernel
+;; base-env, bind a few helper applicatives (+, *, list, =, $if), and
+;; run programs that construct and use custom combiners.
+
+(define kv-suite (refl-make-test-suite))
+(define kv-test  (fn (n a e) (refl-test kv-suite n a e)))
+
+(define kv-eval-src (fn (src env) (kernel-eval (kernel-parse src) env)))
+
+(define
+  kv-make-env
+  (fn
+    ()
+    (let
+      ((env (kernel-base-env)))
+      (kernel-env-bind!
+        env
+        "+"
+        (kernel-make-primitive-applicative
+          (fn (args) (+ (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "*"
+        (kernel-make-primitive-applicative
+          (fn (args) (* (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "-"
+        (kernel-make-primitive-applicative
+          (fn (args) (- (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "="
+        (kernel-make-primitive-applicative
+          (fn (args) (= (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "list"
+        (kernel-make-primitive-applicative (fn (args) args)))
+      (kernel-env-bind!
+        env
+        "cons"
+        (kernel-make-primitive-applicative
+          (fn (args) (cons (first args) (nth args 1)))))
+      (kernel-env-bind!
+        env
+        "$quote"
+        (kernel-make-primitive-operative (fn (args dyn-env) (first args))))
+      (kernel-env-bind!
+        env
+        "$if"
+        (kernel-make-primitive-operative
+          (fn
+            (args dyn-env)
+            (if
+              (kernel-eval (first args) dyn-env)
+              (kernel-eval (nth args 1) dyn-env)
+              (kernel-eval (nth args 2) dyn-env)))))
+      env)))
+
+;; ── $vau: builds an operative ───────────────────────────────────
+(kv-test
+  "vau: identity returns first arg unevaluated"
+  (kv-eval-src "(($vau (a) _ a) hello)" (kv-make-env))
+  "hello")
+
+(kv-test
+  "vau: returns args as raw expressions"
+  (kv-eval-src "(($vau (a b) _ (list a b)) (+ 1 2) (+ 3 4))" (kv-make-env))
+  (list (list "+" 1 2) (list "+" 3 4)))
+
+(kv-test
+  "vau: env-param is a kernel env"
+  (kernel-env? (kv-eval-src "(($vau () e e))" (kv-make-env)))
+  true)
+
+(kv-test
+  "vau: returns operative"
+  (kernel-operative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
+  true)
+
+(kv-test
+  "vau: returns operative not applicative"
+  (kernel-applicative? (kv-eval-src "($vau (x) _ x)" (kv-make-env)))
+  false)
+
+(kv-test
+  "vau: zero-arg body"
+  (kv-eval-src "(($vau () _ 42))" (kv-make-env))
+  42)
+
+(kv-test
+  "vau: static-env closure captured"
+  (let
+    ((outer (kv-make-env)))
+    (kernel-env-bind! outer "captured" 17)
+    (let
+      ((op (kv-eval-src "($vau () _ captured)" outer))
+        (caller (kv-make-env)))
+      (kernel-env-bind! caller "captured" 99)
+      (kernel-combine op (list) caller)))
+  17)
+
+(kv-test
+  "vau: env-param exposes caller's dynamic env"
+  (let
+    ((outer (kv-make-env)))
+    (kernel-env-bind! outer "x" 1)
+    (let
+      ((op (kv-eval-src "($vau () e e)" outer)) (caller (kv-make-env)))
+      (kernel-env-bind! caller "x" 2)
+      (let
+        ((e-val (kernel-combine op (list) caller)))
+        (kernel-env-lookup e-val "x"))))
+  2)
+
+;; ── $lambda: applicatives evaluate their args ───────────────────
+(kv-test
+  "lambda: identity"
+  (kv-eval-src "(($lambda (x) x) 42)" (kv-make-env))
+  42)
+
+(kv-test
+  "lambda: addition"
+  (kv-eval-src "(($lambda (x y) (+ x y)) 3 4)" (kv-make-env))
+  7)
+
+(kv-test
+  "lambda: args are evaluated before bind"
+  (kv-eval-src "(($lambda (x) x) (+ 2 3))" (kv-make-env))
+  5)
+
+(kv-test
+  "lambda: zero args"
+  (kv-eval-src "(($lambda () 99))" (kv-make-env))
+  99)
+
+(kv-test
+  "lambda: returns applicative"
+  (kernel-applicative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
+  true)
+
+(kv-test
+  "lambda: returns applicative not operative"
+  (kernel-operative? (kv-eval-src "($lambda (x) x)" (kv-make-env)))
+  false)
+
+(kv-test
+  "lambda: higher-order"
+  (kv-eval-src "(($lambda (f) (f 10)) ($lambda (x) (+ x 1)))" (kv-make-env))
+  11)
+
+;; ── wrap / unwrap as user-callable applicatives ─────────────────
+
+(kv-test
+  "wrap: makes applicative from operative"
+  (kernel-applicative? (kv-eval-src "(wrap ($vau (x) _ x))" (kv-make-env)))
+  true)
+
+(kv-test
+  "wrap: result evaluates its arg"
+  (kv-eval-src "((wrap ($vau (x) _ x)) (+ 1 2))" (kv-make-env))
+  3)
+
+(kv-test
+  "unwrap: extracts operative from applicative"
+  (kernel-operative? (kv-eval-src "(unwrap ($lambda (x) x))" (kv-make-env)))
+  true)
+
+(kv-test
+  "wrap/unwrap roundtrip preserves identity"
+  (kv-eval-src
+    "(($lambda (op) (= op (unwrap (wrap op)))) ($vau (x) _ x))"
+    (kv-make-env))
+  true)
+
+;; ── operative? / applicative? as user-visible predicates ────────
+
+(kv-test
+  "operative? on vau result"
+  (kv-eval-src "(operative? ($vau (x) _ x))" (kv-make-env))
+  true)
+
+(kv-test
+  "operative? on lambda result"
+  (kv-eval-src "(operative? ($lambda (x) x))" (kv-make-env))
+  false)
+
+(kv-test
+  "applicative? on lambda result"
+  (kv-eval-src "(applicative? ($lambda (x) x))" (kv-make-env))
+  true)
+
+(kv-test
+  "applicative? on vau result"
+  (kv-eval-src "(applicative? ($vau (x) _ x))" (kv-make-env))
+  false)
+
+(kv-test
+  "operative? on number"
+  (kv-eval-src "(operative? 42)" (kv-make-env))
+  false)
+
+;; ── Build BOTH layers from user code ────────────────────────────
+;; The headline Phase 3 test: defining an operative on top of an
+;; applicative defined on top of a vau.
+
+(kv-test
+  "custom: applicative + operative compose"
+  (let
+    ((env (kv-make-env)))
+    (kernel-env-bind! env "square" (kv-eval-src "($lambda (x) (* x x))" env))
+    (kv-eval-src "(square 4)" env))
+  16)
+
+(kv-test "custom: operative captures argument syntax"
+  ;; ($capture x) returns the raw expression `x`, regardless of value.
+  (let ((env (kv-make-env)))
+    (kernel-env-bind! env "$capture"
+      (kv-eval-src "($vau (form) _ form)" env))
+    (kv-eval-src "($capture (+ 1 2))" env))
+  (list "+" 1 2))
+
+(kv-test "custom: applicative re-wraps an operative"
+  ;; Build a captured operative, then wrap it into an applicative that
+  ;; evaluates args before re-entry. This exercises wrap+$vau composed.
+  (let ((env (kv-make-env)))
+    (kernel-env-bind! env "id-app"
+      (kv-eval-src "(wrap ($vau (x) _ x))" env))
+    (kv-eval-src "(id-app (+ 10 20))" env))
+  30)
+
+;; ── Error cases ──────────────────────────────────────────────────
+
+(kv-test
+  "vau: rejects non-list formals"
+  (guard (e (true :raised)) (kv-eval-src "($vau x _ x)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: rejects non-symbol formal"
+  (guard (e (true :raised)) (kv-eval-src "($vau (1) _ x)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: rejects non-symbol env-param"
+  (guard (e (true :raised)) (kv-eval-src "($vau (x) 7 x)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: too few args at call site"
+  (guard
+    (e (true :raised))
+    (kv-eval-src "(($vau (x y) _ x) 1)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "vau: too many args at call site"
+  (guard
+    (e (true :raised))
+    (kv-eval-src "(($vau (x) _ x) 1 2)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "wrap: rejects non-operative"
+  (guard (e (true :raised)) (kv-eval-src "(wrap 42)" (kv-make-env)))
+  :raised)
+
+(kv-test
+  "unwrap: rejects non-applicative"
+  (guard (e (true :raised)) (kv-eval-src "(unwrap 42)" (kv-make-env)))
+  :raised)
+
+;; ── Multi-expression body (implicit $sequence) ──────────────────
+
+(kv-test "lambda: two body forms — value of last"
+  (kv-eval-src "(($lambda (n) (+ n 1) (+ n 10)) 5)" (kv-make-env)) 15)
+
+(kv-test "lambda: three body forms"
+  (kv-eval-src "(($lambda (n) n (+ n 1) (+ n 2)) 10)" (kv-make-env)) 12)
+
+(kv-test "vau: two body forms"
+  (kv-eval-src "(($vau (a b) _ a (list a b)) 7 8)" (kv-make-env))
+  (list 7 8))
+
+(kv-test "lambda: $define! in early body visible in later body"
+  (kv-eval-src
+    "(($lambda (n) ($define! double (+ n n)) double) 6)"
+    (kv-make-env)) 12)
+
+(kv-test "lambda: zero-arg multi-body"
+  (kv-eval-src "(($lambda () 1 2 3))" (kv-make-env)) 3)
+
+(define kv-tests-run! (fn () (refl-test-report kv-suite)))

lib/lua/conformance.py

@@ -0,0 +1,348 @@
+#!/usr/bin/env python3
+"""lua-conformance — run the PUC-Rio Lua 5.1 test suite against Lua-on-SX.
+
+Walks lib/lua/lua-tests/*.lua, evaluates each via `lua-eval-ast` on a
+long-lived sx_server.exe subprocess, classifies pass/fail/timeout per file,
+and writes lib/lua/scoreboard.{json,md}.
+
+Modelled on lib/js/test262-runner.py but much simpler: each Lua test file is
+its own unit (they're self-contained assertion scripts; they pass if they
+complete without raising). No harness stub, no frontmatter, no worker pool.
+
+Usage:
+    python3 lib/lua/conformance.py
+    python3 lib/lua/conformance.py --filter locals
+    python3 lib/lua/conformance.py --per-test-timeout 3 -v
+"""
+from __future__ import annotations
+
+import argparse
+import json
+import os
+import re
+import select
+import subprocess
+import sys
+import time
+from collections import Counter
+from pathlib import Path
+
+REPO = Path(__file__).resolve().parents[2]
+SX_SERVER_PRIMARY = REPO / "hosts" / "ocaml" / "_build" / "default" / "bin" / "sx_server.exe"
+SX_SERVER_FALLBACK = Path("/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe")
+TESTS_DIR = REPO / "lib" / "lua" / "lua-tests"
+
+DEFAULT_TIMEOUT = 8.0
+
+# Files that require facilities we don't (and won't soon) support.
+# Still classified as skip rather than fail so the scoreboard stays honest.
+HARDCODED_SKIP = {
+    "all.lua":        "driver uses dofile to chain other tests",
+    "api.lua":        "requires testC (C debug library)",
+    "checktable.lua": "internal debug helpers",
+    "code.lua":       "bytecode inspection via debug library",
+    "db.lua":         "debug library",
+    "files.lua":      "io library",
+    "gc.lua":         "collectgarbage / finalisers",
+    "main.lua":       "standalone interpreter driver",
+}
+
+RX_OK_INLINE = re.compile(r"^\(ok (\d+) (.*)\)\s*$")
+RX_OK_LEN = re.compile(r"^\(ok-len (\d+) \d+\)\s*$")
+RX_ERR = re.compile(r"^\(error (\d+) (.*)\)\s*$")
+
+
+def pick_sx_server() -> Path:
+    if SX_SERVER_PRIMARY.exists():
+        return SX_SERVER_PRIMARY
+    return SX_SERVER_FALLBACK
+
+
+def sx_escape_nested(s: str) -> str:
+    """Two-level escape: (eval "(lua-eval-ast \"<src>\")").
+
+    Outer literal is consumed by `eval` then the inner literal by `lua-eval-ast`.
+    """
+    inner = (
+        s.replace("\\", "\\\\")
+        .replace('"', '\\"')
+        .replace("\n", "\\n")
+        .replace("\r", "\\r")
+        .replace("\t", "\\t")
+    )
+    return inner.replace("\\", "\\\\").replace('"', '\\"')
+
+
+def classify_error(msg: str) -> str:
+    m = msg.lower()
+    sym = re.search(r"undefined symbol:\s*\\?\"?([^\"\s)]+)", msg, re.I)
+    if sym:
+        return f"undefined symbol: {sym.group(1).strip(chr(34))}"
+    if "undefined symbol" in m:
+        return "undefined symbol"
+    if "lua: arith" in m:
+        return "arith type error"
+    if "lua-transpile" in m:
+        return "transpile: unsupported node"
+    if "lua-parse" in m:
+        return "parse error"
+    if "lua-tokenize" in m:
+        return "tokenize error"
+    if "unknown node" in m:
+        return "unknown AST node"
+    if "not yet supported" in m:
+        return "not yet supported"
+    if "nth: index out" in m or "nth:" in m:
+        return "nth index error"
+    if "timeout" in m:
+        return "timeout"
+    # Strip SX-side wrapping and trim
+    trimmed = msg.strip('"').strip()
+    return f"other: {trimmed[:80]}"
+
+
+class Session:
+    def __init__(self, sx_server: Path, timeout: float):
+        self.sx_server = sx_server
+        self.timeout = timeout
+        self.proc: subprocess.Popen | None = None
+        self._buf = b""
+        self._fd = -1
+
+    def start(self) -> None:
+        self.proc = subprocess.Popen(
+            [str(self.sx_server)],
+            stdin=subprocess.PIPE,
+            stdout=subprocess.PIPE,
+            stderr=subprocess.DEVNULL,
+            cwd=str(REPO),
+            bufsize=0,
+        )
+        self._fd = self.proc.stdout.fileno()
+        self._buf = b""
+        os.set_blocking(self._fd, False)
+        self._wait_for("(ready)", timeout=15.0)
+        self._run(1, '(load "lib/lua/tokenizer.sx")', 60)
+        self._run(2, '(load "lib/lua/parser.sx")', 60)
+        self._run(3, '(load "lib/lua/runtime.sx")', 60)
+        self._run(4, '(load "lib/lua/transpile.sx")', 60)
+
+    def stop(self) -> None:
+        if self.proc is None:
+            return
+        try:
+            self.proc.stdin.close()
+        except Exception:
+            pass
+        try:
+            self.proc.terminate()
+            self.proc.wait(timeout=3)
+        except Exception:
+            try:
+                self.proc.kill()
+            except Exception:
+                pass
+        self.proc = None
+
+    def _readline(self, timeout: float) -> str | None:
+        deadline = time.monotonic() + timeout
+        while True:
+            nl = self._buf.find(b"\n")
+            if nl >= 0:
+                line = self._buf[: nl + 1]
+                self._buf = self._buf[nl + 1 :]
+                return line.decode("utf-8", errors="replace")
+            remaining = deadline - time.monotonic()
+            if remaining <= 0:
+                raise TimeoutError("readline timeout")
+            try:
+                rlist, _, _ = select.select([self._fd], [], [], remaining)
+            except (OSError, ValueError):
+                return None
+            if not rlist:
+                raise TimeoutError("readline timeout")
+            try:
+                chunk = os.read(self._fd, 65536)
+            except (BlockingIOError, InterruptedError):
+                continue
+            except OSError:
+                return None
+            if not chunk:
+                if self._buf:
+                    rv = self._buf.decode("utf-8", errors="replace")
+                    self._buf = b""
+                    return rv
+                return None
+            self._buf += chunk
+
+    def _wait_for(self, token: str, timeout: float) -> None:
+        start = time.monotonic()
+        while time.monotonic() - start < timeout:
+            line = self._readline(timeout - (time.monotonic() - start))
+            if line is None:
+                raise RuntimeError("sx_server closed stdout before ready")
+            if token in line:
+                return
+        raise TimeoutError(f"timeout waiting for {token}")
+
+    def _run(self, epoch: int, cmd: str, timeout: float):
+        payload = f"(epoch {epoch})\n{cmd}\n".encode("utf-8")
+        try:
+            self.proc.stdin.write(payload)
+            self.proc.stdin.flush()
+        except (BrokenPipeError, OSError):
+            raise RuntimeError("sx_server stdin closed")
+        deadline = time.monotonic() + timeout
+        while time.monotonic() < deadline:
+            remaining = deadline - time.monotonic()
+            if remaining <= 0:
+                raise TimeoutError(f"epoch {epoch} timeout")
+            line = self._readline(remaining)
+            if line is None:
+                raise RuntimeError("sx_server closed stdout mid-epoch")
+            m = RX_OK_INLINE.match(line)
+            if m and int(m.group(1)) == epoch:
+                return "ok", m.group(2)
+            m = RX_OK_LEN.match(line)
+            if m and int(m.group(1)) == epoch:
+                val = self._readline(deadline - time.monotonic()) or ""
+                return "ok", val.rstrip("\n")
+            m = RX_ERR.match(line)
+            if m and int(m.group(1)) == epoch:
+                return "error", m.group(2)
+        raise TimeoutError(f"epoch {epoch} timeout")
+
+    def run_lua(self, epoch: int, src: str):
+        escaped = sx_escape_nested(src)
+        cmd = f'(eval "(lua-eval-ast \\"{escaped}\\")")'
+        return self._run(epoch, cmd, self.timeout)
+
+
+def main() -> int:
+    ap = argparse.ArgumentParser()
+    ap.add_argument("--per-test-timeout", type=float, default=DEFAULT_TIMEOUT)
+    ap.add_argument("--filter", type=str, default=None,
+                    help="only run tests whose filename contains this substring")
+    ap.add_argument("-v", "--verbose", action="store_true")
+    ap.add_argument("--no-scoreboard", action="store_true",
+                    help="do not write scoreboard.{json,md}")
+    args = ap.parse_args()
+
+    sx_server = pick_sx_server()
+    if not sx_server.exists():
+        print(f"ERROR: sx_server not found at {sx_server}", file=sys.stderr)
+        return 1
+    if not TESTS_DIR.exists():
+        print(f"ERROR: no tests dir at {TESTS_DIR}", file=sys.stderr)
+        return 1
+
+    tests = sorted(TESTS_DIR.glob("*.lua"))
+    if args.filter:
+        tests = [p for p in tests if args.filter in p.name]
+    if not tests:
+        print("No tests matched.", file=sys.stderr)
+        return 1
+
+    print(f"Running {len(tests)} Lua test file(s)…", file=sys.stderr)
+    session = Session(sx_server, args.per_test_timeout)
+    session.start()
+
+    results = []
+    failure_modes: Counter = Counter()
+
+    try:
+        for i, path in enumerate(tests, start=1):
+            name = path.name
+            skip_reason = HARDCODED_SKIP.get(name)
+            if skip_reason:
+                results.append({"name": name, "status": "skip", "reason": skip_reason, "ms": 0})
+                if args.verbose:
+                    print(f"  - {name}: SKIP ({skip_reason})")
+                continue
+
+            try:
+                src = path.read_text(encoding="utf-8")
+            except UnicodeDecodeError:
+                src = path.read_text(encoding="latin-1")
+            t0 = time.monotonic()
+            try:
+                kind, payload = session.run_lua(100 + i, src)
+                ms = int((time.monotonic() - t0) * 1000)
+                if kind == "ok":
+                    results.append({"name": name, "status": "pass", "reason": "", "ms": ms})
+                    if args.verbose:
+                        print(f"  + {name}: PASS ({ms}ms)")
+                else:
+                    reason = classify_error(payload)
+                    failure_modes[reason] += 1
+                    results.append({"name": name, "status": "fail", "reason": reason, "ms": ms})
+                    if args.verbose:
+                        print(f"  - {name}: FAIL — {reason}")
+            except TimeoutError:
+                ms = int((time.monotonic() - t0) * 1000)
+                failure_modes["timeout"] += 1
+                results.append({"name": name, "status": "timeout", "reason": "per-test timeout",
+                                "ms": ms})
+                if args.verbose:
+                    print(f"  - {name}: TIMEOUT ({ms}ms)")
+                # Restart after a timeout to shed any stuck state.
+                session.stop()
+                session.start()
+    finally:
+        session.stop()
+
+    n_pass = sum(1 for r in results if r["status"] == "pass")
+    n_fail = sum(1 for r in results if r["status"] == "fail")
+    n_timeout = sum(1 for r in results if r["status"] == "timeout")
+    n_skip = sum(1 for r in results if r["status"] == "skip")
+    n_total = len(results)
+    n_runnable = n_total - n_skip
+    pct = (n_pass / n_runnable * 100.0) if n_runnable else 0.0
+
+    print()
+    print(f"Lua-on-SX conformance: {n_pass}/{n_runnable} runnable pass ({pct:.1f}%)  "
+          f"fail={n_fail} timeout={n_timeout} skip={n_skip} total={n_total}")
+    if failure_modes:
+        print("Top failure modes:")
+        for mode, count in failure_modes.most_common(10):
+            print(f"  {count}x  {mode}")
+
+    if not args.no_scoreboard:
+        sb = {
+            "totals": {
+                "pass": n_pass, "fail": n_fail, "timeout": n_timeout,
+                "skip": n_skip, "total": n_total, "runnable": n_runnable,
+                "pass_rate": round(pct, 1),
+            },
+            "top_failure_modes": failure_modes.most_common(20),
+            "results": results,
+        }
+        (REPO / "lib" / "lua" / "scoreboard.json").write_text(
+            json.dumps(sb, indent=2), encoding="utf-8"
+        )
+        md = [
+            "# Lua-on-SX conformance scoreboard",
+            "",
+            f"**Pass rate:** {n_pass}/{n_runnable} runnable ({pct:.1f}%)",
+            f"fail={n_fail} timeout={n_timeout} skip={n_skip} total={n_total}",
+            "",
+            "## Top failure modes",
+            "",
+        ]
+        for mode, count in failure_modes.most_common(10):
+            md.append(f"- **{count}x** {mode}")
+        md.extend(["", "## Per-test results", "",
+                   "| Test | Status | Reason | ms |",
+                   "|---|---|---|---:|"])
+        for r in results:
+            reason = r["reason"] or "-"
+            md.append(f"| {r['name']} | {r['status']} | {reason} | {r['ms']} |")
+        (REPO / "lib" / "lua" / "scoreboard.md").write_text(
+            "\n".join(md) + "\n", encoding="utf-8"
+        )
+
+    return 0 if (n_fail == 0 and n_timeout == 0) else 1
+
+
+if __name__ == "__main__":
+    sys.exit(main())

lib/lua/conformance.sh

@@ -0,0 +1,13 @@
+#!/usr/bin/env bash
+# Lua-on-SX conformance runner — walks lib/lua/lua-tests/*.lua, runs each via
+# `lua-eval-ast` on a long-lived sx_server.exe subprocess, classifies
+# pass/fail/timeout, and writes lib/lua/scoreboard.{json,md}.
+#
+# Usage:
+#   bash lib/lua/conformance.sh               # full suite
+#   bash lib/lua/conformance.sh --filter sort # filter by filename substring
+#   bash lib/lua/conformance.sh -v            # per-file verbose
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+exec python3 lib/lua/conformance.py "$@"