blogimport: published-posts source contract + blog-side draft (76/76)

source.sx refactored to a single published-posts batch query returning full rows
(incl. lexical) — the existing post-by-id/slug DTO lacks lexical (sx_content/html
only), so the canonical lexical->blocks path needs a dedicated migration provider.
backfill-ids! now filters client-side (no extra query).

drafts/published-posts.sx + drafts/README.md: paste-ready blog-app change (defquery +
SqlBlogService.list_published_posts returning rows incl. raw lexical). README updated.
source 21/21; total 76/76.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>

hosts/ocaml/bin/dune

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

hosts/ocaml/bin/integration_tests.ml

@@ -263,7 +263,7 @@ let make_integration_env () =
 
   (* Type predicates — needed by adapter-sx.sx *)
   bind "callable?" (fun args ->
-    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
+    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true | _ -> Bool false);
   bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
   bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
   bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);

hosts/ocaml/bin/mcp_tree.ml

@@ -477,7 +477,7 @@ let setup_env () =
   bind "number?" (fun args -> match args with
     | [Number _] -> Bool true | _ -> Bool false);
   bind "callable?" (fun args -> match args with
-    | [NativeFn _ | Lambda _ | Component _ | Island _] -> Bool true | _ -> Bool false);
+    | [NativeFn _ | Lambda _ | Component _ | Island _ | VmClosure _] -> Bool true | _ -> Bool false);
   bind "empty?" (fun args -> match args with
     | [List []] | [ListRef { contents = [] }] -> Bool true
     | [Nil] -> Bool true | _ -> Bool false);

hosts/ocaml/bin/repro_jit_resume.ml

@@ -0,0 +1,202 @@
+(* Surgical repro for the serving-JIT OP_PERFORM/resume stack misalignment.
+   Mirrors what register_jit_hook's resolve_loop does: call_closure, catch
+   VmSuspended, resolve IO (return Nil), resume_vm — looping on re-suspend.
+   No CEK evaluator needed for the direct/multi-frame/reuse paths. *)
+
+open Sx_types
+
+let req_dict () =
+  let h = Hashtbl.create 1 in
+  Hashtbl.replace h "op" (String "noop");
+  Dict h
+
+(* Mirror the serving hook's resolve loop exactly. *)
+let drive cl =
+  let globals = cl.vm_closure_env |> ignore; cl.vm_env_ref in
+  let rec resolve_loop req vm =
+    let _ = req in
+    (try Sx_vm.resume_vm vm Nil
+     with Sx_vm.VmSuspended (r2, v2) -> resolve_loop r2 v2)
+  in
+  try Sx_vm.call_closure cl [] globals
+  with Sx_vm.VmSuspended (req, vm) -> resolve_loop req vm
+
+let mk_code ~locals ~bc ~consts = {
+  vc_arity = 0; vc_rest_arity = -1; vc_locals = locals;
+  vc_bytecode = Array.of_list bc;
+  vc_constants = Array.of_list consts;
+  vc_bytecode_list = None; vc_constants_list = None;
+}
+
+let mk_cl ?(name="tf") ?(env=Hashtbl.create 64) code =
+  { vm_code = code; vm_upvalues = [||]; vm_name = Some name;
+    vm_env_ref = env; vm_closure_env = None }
+
+let report label v =
+  Printf.printf "%-28s => %s\n%!" label (Sx_runtime.value_to_str v)
+
+let run label f =
+  (try report label (f ())
+   with
+   | Eval_error m -> Printf.printf "%-28s => ERROR: %s\n%!" label m
+   | e -> Printf.printf "%-28s => EXN: %s\n%!" label (Printexc.to_string e))
+
+(* opcodes *)
+let _const i = [1; i land 0xff; (i lsr 8) land 0xff]
+let _perform = [112]
+let _pop = [5]
+let _call_prim idx argc = [52; idx land 0xff; (idx lsr 8) land 0xff; argc]
+let _call argc = [48; argc]
+let _return = [50]
+
+let () =
+  (* Serving mode: a synchronous IO resolver is installed (mirrors
+     sx_server's http setup). Our mock resolves every request to Nil. *)
+  Sx_types._cek_io_resolver := Some (fun _req _ -> Nil);
+
+  (* Case 1: direct OP_PERFORM then a list prim in the SAME frame.
+     (do (perform {..}) (rest (list 1 2 3)))  =>  (2 3) *)
+  run "1.direct perform→rest" (fun () ->
+    let consts = [ req_dict (); List [Number 1.; Number 2.; Number 3.]; String "rest" ] in
+    let bc = _const 0 @ _perform @ _pop @ _const 1 @ _call_prim 2 1 @ _return in
+    drive (mk_cl (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 2: direct perform then map (2-arg prim).
+     (do (perform {..}) (map inc (list 1 2 3)))  — needs a fn; use a NativeFn const *)
+  run "2.direct perform→map" (fun () ->
+    let inc = NativeFn ("inc1", function [Number n] -> Number (n +. 1.) | _ -> Nil) in
+    let consts = [ req_dict (); inc; List [Number 1.; Number 2.; Number 3.]; String "map" ] in
+    (* push fn, push list, CALL_PRIM map 2 *)
+    let bc = _const 0 @ _perform @ _pop @ _const 1 @ _const 2 @ _call_prim 3 2 @ _return in
+    drive (mk_cl (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 3: multi-frame — outer calls a JIT'd helper that performs, THEN outer maps.
+     helper: (do (perform {..}) 99)
+     outer:  (do (helper) (map inc (list 1 2 3))) *)
+  run "3.multiframe perform→map" (fun () ->
+    let env = Hashtbl.create 64 in
+    let helper_code = mk_code ~locals:0
+      ~bc:(_const 0 @ _perform @ _pop @ _const 1 @ _return)
+      ~consts:[ req_dict (); Number 99. ] in
+    let helper_cl = mk_cl ~name:"helper" ~env helper_code in
+    let inc = NativeFn ("inc1", function [Number n] -> Number (n +. 1.) | _ -> Nil) in
+    let consts = [ VmClosure helper_cl; inc; List [Number 1.; Number 2.; Number 3.]; String "map" ] in
+    (* push helper-closure, CALL 0, POP its result, push inc, push list, CALL_PRIM map 2 *)
+    let bc = _const 0 @ _call 0 @ _pop @ _const 1 @ _const 2 @ _call_prim 3 2 @ _return in
+    drive (mk_cl ~name:"outer" ~env (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 4: map whose CALLBACK performs (reuse_stack path), then a trailing prim.
+     callback: (do (perform {..}) (inc e))   — but callback gets arg e in slot 0
+     outer: (do (map cb (list 1 2 3)) (rest (list 7 8 9)))  *)
+  run "4.map-callback-perform" (fun () ->
+    let env = Hashtbl.create 64 in
+    (* callback arity 1: slot0 = e. body: (perform {..}); (inc e) ; return
+       LOCAL_GET 0 then CALL_PRIM inc... use NativeFn inc via CALL_PRIM *)
+    let cb_code = {
+      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
+      vc_bytecode = Array.of_list (_const 0 @ _perform @ _pop
+                                   @ [16;0] (* LOCAL_GET 0 *)
+                                   @ _call_prim 1 1 @ _return);
+      vc_constants = [| req_dict (); String "inc" |];
+      vc_bytecode_list = None; vc_constants_list = None } in
+    let cb_cl = mk_cl ~name:"cb" ~env cb_code in
+    let consts = [ VmClosure cb_cl; List [Number 1.; Number 2.; Number 3.]; String "map";
+                   List [Number 7.; Number 8.; Number 9.]; String "rest" ] in
+    (* push cb, push list, CALL_PRIM map 2, POP, push list2, CALL_PRIM rest 1, RETURN *)
+    let bc = _const 0 @ _const 1 @ _call_prim 2 2 @ _pop @ _const 3 @ _call_prim 4 1 @ _return in
+    drive (mk_cl ~name:"outer4" ~env (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 5: THE HOST CASE — perform via an INTERPRETED helper (pending_cek path),
+     then a list prim. helper is a Lambda (l_compiled = jit_failed) whose body
+     performs; vm_call routes it through cek_call_or_suspend → pending_cek.
+       helper: (perform {..})  [interpreted via CEK]
+       outer:  (do (helper) (rest (list 1 2 3)))  => (2 3) *)
+  run "5.pending_cek perform→rest" (fun () ->
+    let env = Sx_types.make_env () in
+    let helper = Lambda {
+      l_params = []; l_body = List [Symbol "perform"; req_dict ()];
+      l_closure = env; l_name = Some "kvread";
+      l_compiled = Some Sx_vm.jit_failed_sentinel; l_call_count = 0;
+      l_uid = Sx_types.next_lambda_uid () } in
+    let consts = [ helper; List [Number 1.; Number 2.; Number 3.]; String "rest" ] in
+    (* push helper, CALL 0, POP, push list, CALL_PRIM rest 1, RETURN *)
+    let bc = _const 0 @ _call 0 @ _pop @ _const 1 @ _call_prim 2 1 @ _return in
+    drive (mk_cl ~name:"outer5" ~env:(Hashtbl.create 64) (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 6: pending_cek perform → MAP (2-arg), the exact host shape. *)
+  run "6.pending_cek perform→map" (fun () ->
+    let env = Sx_types.make_env () in
+    let helper = Lambda {
+      l_params = []; l_body = List [Symbol "perform"; req_dict ()];
+      l_closure = env; l_name = Some "kvread";
+      l_compiled = Some Sx_vm.jit_failed_sentinel; l_call_count = 0;
+      l_uid = Sx_types.next_lambda_uid () } in
+    let inc = NativeFn ("inc1", function [Number n] -> Number (n +. 1.) | _ -> Nil) in
+    let consts = [ helper; inc; List [Number 1.; Number 2.; Number 3.]; String "map" ] in
+    (* push helper, CALL 0, POP, push inc, push list, CALL_PRIM map 2, RETURN *)
+    let bc = _const 0 @ _call 0 @ _pop @ _const 1 @ _const 2 @ _call_prim 3 2 @ _return in
+    drive (mk_cl ~name:"outer6" ~env:(Hashtbl.create 64) (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 7: THE HOST SHAPE — map whose callback calls an INTERPRETED helper
+     that performs (kv read via persist helper inside a map), THEN a trailing
+     prim. callback(e): (do (kvread) e)  — kvread suspends via pending_cek.
+     outer: (do (map cb (list 1 2 3)) (drop (list 5 6 7 8) 2)) => (7 8) *)
+  run "7.HOST: map[cb→helper perform]→drop" (fun () ->
+    let genv = Sx_types.make_env () in
+    let helper = Lambda {
+      l_params = []; l_body = List [Symbol "perform"; req_dict ()];
+      l_closure = genv; l_name = Some "kvread";
+      l_compiled = Some Sx_vm.jit_failed_sentinel; l_call_count = 0;
+      l_uid = Sx_types.next_lambda_uid () } in
+    let env = Hashtbl.create 64 in
+    (* cb(e): push helper, CALL 0, POP, LOCAL_GET 0, RETURN *)
+    let cb_code = {
+      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
+      vc_bytecode = Array.of_list (_const 0 @ _call 0 @ _pop @ [16;0] @ _return);
+      vc_constants = [| helper |]; vc_bytecode_list=None; vc_constants_list=None } in
+    let cb_cl = mk_cl ~name:"cb7" ~env cb_code in
+    let consts = [ VmClosure cb_cl; List [Number 1.; Number 2.; Number 3.]; String "map";
+                   List [Number 5.; Number 6.; Number 7.; Number 8.]; Number 2.; String "drop" ] in
+    (* push cb, push list, CALL_PRIM map 2, POP, push list2, push 2, CALL_PRIM drop 2, RETURN *)
+    let bc = _const 0 @ _const 1 @ _call_prim 2 2 @ _pop
+             @ _const 3 @ _const 4 @ _call_prim 5 2 @ _return in
+    drive (mk_cl ~name:"outer7" ~env (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 8: reduce whose callback performs. (reduce + 0 (list 1 2 3)) with a
+     perform in the reducer => 6 *)
+  run "8.reduce[acc→perform]" (fun () ->
+    let env = Hashtbl.create 64 in
+    (* reducer(acc e): (do (perform {..}) (+ acc e)). slots: 0=acc 1=e *)
+    let rd_code = {
+      vc_arity = 2; vc_rest_arity = -1; vc_locals = 2;
+      vc_bytecode = Array.of_list (_const 0 @ _perform @ _pop
+                                   @ [16;0] @ [16;1] @ _call_prim 1 2 @ _return);
+      vc_constants = [| req_dict (); String "+" |];
+      vc_bytecode_list=None; vc_constants_list=None } in
+    let rd_cl = mk_cl ~name:"rd" ~env rd_code in
+    let consts = [ VmClosure rd_cl; Number 0.; List [Number 1.; Number 2.; Number 3.]; String "reduce" ] in
+    (* push reducer, push 0, push list, CALL_PRIM reduce 3, RETURN *)
+    let bc = _const 0 @ _const 1 @ _const 2 @ _call_prim 3 3 @ _return in
+    drive (mk_cl ~name:"outer8" ~env (mk_code ~locals:0 ~bc ~consts)));
+
+  (* Case 9: nested map — outer map callback runs an inner map whose callback
+     performs. outer over (list 1 2), inner over (list 10 20) performing.
+     cb_outer(x): (map cb_inner (list 10 20)) ; cb_inner(y): (do (perform) y)
+     => ((10 20) (10 20)) *)
+  run "9.nested map[inner→perform]" (fun () ->
+    let env = Hashtbl.create 64 in
+    let inner_code = {
+      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
+      vc_bytecode = Array.of_list (_const 0 @ _perform @ _pop @ [16;0] @ _return);
+      vc_constants = [| req_dict () |]; vc_bytecode_list=None; vc_constants_list=None } in
+    let inner_cl = mk_cl ~name:"cbin" ~env inner_code in
+    (* outer cb(x): push inner_cl, push (10 20), CALL_PRIM map 2, RETURN *)
+    let outer_cb_code = {
+      vc_arity = 1; vc_rest_arity = -1; vc_locals = 1;
+      vc_bytecode = Array.of_list (_const 0 @ _const 1 @ _call_prim 2 2 @ _return);
+      vc_constants = [| VmClosure inner_cl; List [Number 10.; Number 20.]; String "map" |];
+      vc_bytecode_list=None; vc_constants_list=None } in
+    let outer_cb_cl = mk_cl ~name:"cbout" ~env outer_cb_code in
+    let consts = [ VmClosure outer_cb_cl; List [Number 1.; Number 2.]; String "map" ] in
+    let bc = _const 0 @ _const 1 @ _call_prim 2 2 @ _return in
+    drive (mk_cl ~name:"outer9" ~env (mk_code ~locals:0 ~bc ~consts)))

hosts/ocaml/bin/run_tests.ml

@@ -595,7 +595,7 @@ let make_test_env () =
   (* regex-find-all now provided by sx_primitives.ml *)
   bind "callable?" (fun args ->
     match args with
-    | [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true
+    | [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true
     | _ -> Bool false);
   bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
   bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));

hosts/ocaml/bin/sx_server.ml

@@ -1097,7 +1097,11 @@ let setup_introspection env =
   bind "component?" (fun args ->
     match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
   bind "callable?" (fun args ->
-    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
+    (* VmClosure must count as callable: a JIT-compiled higher-order function
+       returns its inner closure as a VmClosure, and downstream code (e.g.
+       scheme-apply's `(callable? proc)` guard) must recognize it — it is
+       invocable via the normal call path. *)
+    match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] | [VmClosure _] -> Bool true | _ -> Bool false);
   bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
   bind "continuation?" (fun args ->
     match args with [Continuation _] -> Bool true | [_] -> Bool false | _ -> Bool false);
@@ -1468,6 +1472,22 @@ let sx_render_to_html expr env =
 
 let _jit_warned : (string, bool) Hashtbl.t = Hashtbl.create 16
 
+(* Bisection aid: env-var-driven JIT filter. Lets us narrow which named
+   lambda the VM miscompiles without rebuilding.
+   SX_JIT_DENY=name1,name2  — never JIT these (substring match on exact name).
+   SX_JIT_ONLY=name1,name2  — JIT ONLY these (exact name); skip all others. *)
+let _jit_deny_set =
+  match Sys.getenv_opt "SX_JIT_DENY" with
+  | None | Some "" -> []
+  | Some s -> String.split_on_char ',' s |> List.map String.trim
+let _jit_only_set =
+  match Sys.getenv_opt "SX_JIT_ONLY" with
+  | None | Some "" -> []
+  | Some s -> String.split_on_char ',' s |> List.map String.trim
+let _jit_name_allowed name =
+  (not (List.mem name _jit_deny_set))
+  && (match _jit_only_set with [] -> true | only -> List.mem name only)
+
 let rec make_vm_suspend_marker request saved_vm =
   let d = Hashtbl.create 3 in
   Hashtbl.replace d "__vm_suspended" (Bool true);
@@ -1486,6 +1506,8 @@ let rec make_vm_suspend_marker request saved_vm =
 let register_jit_hook env =
   Sx_runtime._jit_try_call_fn := Some (fun f args ->
     match f with
+    | Lambda l when (match l.l_name with Some n -> not (_jit_name_allowed n) | None -> false) ->
+      None  (* bisection filter excluded this name *)
     | Lambda l ->
       (match l.l_compiled with
        | Some cl when not (Sx_vm.is_jit_failed cl) ->
@@ -1502,7 +1524,23 @@ let register_jit_hook env =
                let rec resolve_loop req vm =
                  let result = resolver req (Nil) in
                  (try Some (Sx_vm.resume_vm vm result)
-                  with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2)
+                  with
+                  | Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2
+                  | e ->
+                    (* (B) Resume raised mid-execution. resolve_loop runs inside
+                       the VmSuspended handler, so without catching here the
+                       error escapes to the http handler (→ 500). Recover THIS
+                       call on the CEK instead: mark jit_failed and return None
+                       so the interpreter re-runs it (idempotent for the host's
+                       durable reads). Self-heals on the first hit, not a retry. *)
+                    let fn_name = match l.l_name with Some n -> n | None -> "?" in
+                    if not (Hashtbl.mem _jit_warned fn_name) then begin
+                      Hashtbl.replace _jit_warned fn_name true;
+                      Printf.eprintf "[jit] %s resume fallback to CEK: %s\n%!"
+                        fn_name (Printexc.to_string e)
+                    end;
+                    l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
+                    None)
                in
                resolve_loop request saved_vm
              | None -> Some (make_vm_suspend_marker request saved_vm))
@@ -1535,7 +1573,16 @@ let register_jit_hook env =
                    let rec resolve_loop req vm =
                      let result = resolver req (Nil) in
                      (try Some (Sx_vm.resume_vm vm result)
-                      with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2)
+                      with
+                      | Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2
+                      | e ->
+                        (* (B) See note above — recover a failed resume on the
+                           CEK instead of escaping to the handler (→ 500). *)
+                        Printf.eprintf "[jit] %s resume fallback to CEK: %s\n%!"
+                          fn_name (Printexc.to_string e);
+                        Hashtbl.replace _jit_warned fn_name true;
+                        l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
+                        None)
                    in
                    resolve_loop request saved_vm
                  | None -> Some (make_vm_suspend_marker request saved_vm))
@@ -4854,6 +4901,38 @@ let () =
   else begin
     (* Normal persistent server mode *)
     let env = make_server_env () in
+    (* JIT in the epoch serving mode is OPT-IN via SX_SERVING_JIT=1.
+       Default OFF: this mode is the shared command channel used by every
+       loop's conformance runner, and enabling JIT globally regresses
+       continuation-based guest interpreters (Scheme/Erlang/Prolog/CL: their
+       eval/dispatch cores capture call/cc continuations the stack VM can't
+       escape, and deep AST recursion can miscompile into a non-terminating
+       loop). Guests that are safe declare their interpret-only namespace with
+       `(jit-exclude! "<ns>-*")`; until every guest is validated, the safe
+       default is no JIT here. Opt in (SX_SERVING_JIT=1) for validated
+       workloads — e.g. the content/Smalltalk page server. *)
+    (match Sys.getenv_opt "SX_SERVING_JIT" with
+     | Some ("1" | "true" | "yes" | "on") ->
+       (* Load the SX bytecode compiler (lib/compiler.sx) as `compile` — the
+          native Sx_compiler.compile is an incomplete stub (arity-0 bytecode,
+          params as GLOBAL_GET). http/cli/site modes already load it. *)
+       (_import_env := Some env;
+        let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
+          try Sys.getenv "SX_ROOT" with Not_found ->
+          if Sys.file_exists "/app/spec" then "/app" else Sys.getcwd () in
+        let lib_base = try Sys.getenv "SX_LIB_DIR" with Not_found ->
+          project_dir ^ "/lib" in
+        let compiler_path = lib_base ^ "/compiler.sx" in
+        let compiler_path =
+          if Sys.file_exists compiler_path then compiler_path
+          else if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
+          else compiler_path in
+        try load_library_file compiler_path; rebind_host_extensions env
+        with exn ->
+          Printf.eprintf "[sx-server] WARNING: failed to load compiler.sx for JIT (%s) — JIT disabled\n%!"
+            (Printexc.to_string exn));
+       register_jit_hook env
+     | _ -> ());
     send "(ready)";
     (* Main command loop *)
     try

hosts/ocaml/lib/sx_primitives.ml

@@ -218,7 +218,14 @@ let () =
       Number (List.fold_left (fun acc a -> acc *. as_number a) 1.0 args));
   register "/" (fun args ->
     match args with
-    | [Integer a; Integer b] -> make_rat a b
+    (* (/ int int): exact when divisible → integer, else inexact float.
+       Matches spec ("inexact float") + JS host (backward-compatible) +
+       test-numeric-tower ((/ 6 2)=3, (/ 1 4)=0.25, (/ 5 2)=2.5). Exact
+       rationals come ONLY from literals / make-rational, so a rational
+       OPERAND keeps the result exact (cases below) — but two integers do
+       NOT silently produce a rational (that diverged from the JS host). *)
+    | [Integer a; Integer b] when b <> 0 && a mod b = 0 -> Integer (a / b)
+    | [Integer a; Integer b] -> Number (float_of_int a /. float_of_int b)
     | [Rational(an,ad); Integer b] -> make_rat an (ad * b)
     | [Integer a; Rational(bn,bd)] -> make_rat (a * bd) bn
     | [Rational(an,ad); Rational(bn,bd)] -> rat_div (an, ad) (bn, bd)
@@ -397,6 +404,7 @@ let () =
   register "exact?" (fun args ->
     match args with
     | [Integer _] -> Bool true
+    | [Rational _] -> Bool true   (* rationals are exact *)
     | [Number _] -> Bool false
     | [_] -> Bool false
     | _ -> raise (Eval_error "exact?: 1 arg"));
@@ -833,7 +841,7 @@ let () =
     match args with [a] -> Bool (is_nil a) | _ -> raise (Eval_error "nil?: 1 arg"));
   register "number?" (fun args ->
     match args with
-    | [Integer _] | [Number _] -> Bool true
+    | [Integer _] | [Number _] | [Rational _] -> Bool true
     | [_] -> Bool false
     | _ -> raise (Eval_error "number?: 1 arg"));
   register "integer?" (fun args ->
@@ -4168,6 +4176,38 @@ let () =
     ) Sx_types.jit_cache_queue;
     Queue.clear Sx_types.jit_cache_queue;
     Nil);
+  register "jit-exclude!" (fun args ->
+    (* Mark function names as interpret-only (never JIT-compiled). A guest
+       interpreter calls this for its continuation-using dispatch core.
+       Accepts string/symbol names; a trailing "*" makes it a namespace prefix
+       (e.g. "er-*" excludes every function whose name starts with "er-") —
+       the robust way to declare a whole guest interpreter core. *)
+    List.iter (fun a ->
+      match a with
+      | String n | Symbol n ->
+        let len = String.length n in
+        if len > 0 && n.[len - 1] = '*' then begin
+          let prefix = String.sub n 0 (len - 1) in
+          if not (List.mem prefix !Sx_types.jit_excluded_prefixes) then
+            Sx_types.jit_excluded_prefixes := prefix :: !Sx_types.jit_excluded_prefixes
+        end else
+          Hashtbl.replace Sx_types.jit_excluded n ()
+      | _ -> ()) args;
+    Nil);
+  register "jit-excluded?" (fun args ->
+    match args with
+    | [String n] | [Symbol n] -> Bool (Sx_types.jit_name_excluded n)
+    | _ -> Bool false);
+  register "jit-exclude-callers-of!" (fun args ->
+    (* Register call/cc-establishing forms (e.g. cl-restart-case). Any function
+       whose bytecode references one of these is itself interpret-only — JIT
+       would force the form into a nested cek-run where its continuation can't
+       escape. A guest declares its condition-system / escaping forms here. *)
+    List.iter (fun a ->
+      match a with
+      | String n | Symbol n -> Hashtbl.replace Sx_types.jit_excluded_caller_names n ()
+      | _ -> ()) args;
+    Nil);
   register "jit-reset-counters!" (fun _args ->
     Sx_types.jit_compiled_count := 0;
     Sx_types.jit_skipped_count := 0;

hosts/ocaml/lib/sx_runtime.ml

@@ -17,11 +17,19 @@ let rec _fast_eq a b =
   | Number x, Number y -> x = y
   | Integer x, Number y -> float_of_int x = y
   | Number x, Integer y -> x = float_of_int y
+  (* Exact rationals — must match the "=" primitive (safe_eq). Cross-multiply
+     for rational/rational; coerce for rational/int and rational/float. *)
+  | Rational (an, ad), Rational (bn, bd) -> an * bd = bn * ad
+  | Rational (n, d), Integer y -> n = y * d
+  | Integer x, Rational (n, d) -> x * d = n
+  | Rational (n, d), Number y -> float_of_int n /. float_of_int d = y
+  | Number x, Rational (n, d) -> x = float_of_int n /. float_of_int d
   | Bool x, Bool y -> x = y
   | Nil, Nil -> true
   | Symbol x, Symbol y -> x = y
   | Keyword x, Keyword y -> x = y
-  | List la, List lb ->
+  | (List la | ListRef { contents = la }),
+    (List lb | ListRef { contents = lb }) ->
     (try List.for_all2 _fast_eq la lb with Invalid_argument _ -> false)
   | _ -> false
 

hosts/ocaml/lib/sx_types.ml

@@ -470,6 +470,52 @@ let jit_compiled_count = ref 0
 let jit_skipped_count = ref 0
 let jit_threshold_skipped_count = ref 0
 
+(** Runtime, data-driven JIT exclusion set. Names added here are never
+    JIT-compiled — they run on the CEK interpreter instead.
+
+    This is how a guest interpreter declares its *interpret-only* functions:
+    those that capture or invoke first-class continuations (e.g. Smalltalk's
+    [call/cc]-based non-local return [^expr], or block escape). The stack VM
+    cannot transfer control through a CEK continuation, so a JIT-compiled
+    frame on the OCaml/VM stack between a [call/cc] and its [(k v)] invocation
+    would either fail at runtime or (worse) re-run with duplicated side
+    effects. Marking the dispatch core interpret-only keeps those functions on
+    the CEK while pure helpers still JIT.
+
+    Populated from SX via the [jit-exclude!] primitive (see sx_primitives).
+    Consulted in [Sx_vm.jit_compile_lambda], so it covers BOTH JIT entry
+    points: the CEK call hook and the in-VM tiered-compilation path. *)
+let jit_excluded : (string, unit) Hashtbl.t = Hashtbl.create 64
+
+(** Namespace-prefix exclusions. A guest interpreter declares its whole
+    function namespace interpret-only with one entry (e.g. ["er-"], ["scm-"]),
+    which is far more robust than enumerating every function — a name-list
+    misses functions in extra files (the erlang VM dispatcher, etc.) and
+    silently regresses. Set via [jit-exclude!] with a trailing ["*"]
+    (e.g. [(jit-exclude! "er-*")]). Checked via [jit_name_excluded]. *)
+let jit_excluded_prefixes : string list ref = ref []
+
+(** True if [name] is excluded from JIT — by exact name or by namespace prefix. *)
+let jit_name_excluded name =
+  Hashtbl.mem jit_excluded name
+  || List.exists (fun p ->
+       String.length name >= String.length p
+       && String.sub name 0 (String.length p) = p) !jit_excluded_prefixes
+
+(** Names of functions that ESTABLISH an escaping continuation via call/cc
+    (e.g. Common-Lisp's [cl-restart-case] / [cl-handler-case] — the condition
+    system). Any SX function that *calls* one of these is itself unsafe to JIT:
+    JIT-compiling the caller forces the call/cc-wrapping form to run in a nested
+    cek-run, where invoking the captured continuation runs-to-completion-and-
+    returns instead of escaping — so a restart/non-local exit silently fails
+    and the body falls through (observed as result accumulation / no-abort).
+
+    These callers are NOT a fixed namespace (they are arbitrary user/test code),
+    so they cannot be prefix-excluded. Instead a guest declares its escaping
+    forms here (via [jit-exclude-callers-of!]) and [jit_compile_lambda] skips
+    any function whose constant pool references one of them. *)
+let jit_excluded_caller_names : (string, unit) Hashtbl.t = Hashtbl.create 16
+
 (** {2 JIT cache LRU eviction — Phase 2}
 
     Once a lambda crosses the threshold, its [l_compiled] slot is filled.

hosts/ocaml/lib/sx_vm.ml

@@ -336,30 +336,51 @@ and call_closure_reuse cl args =
     push_closure_frame vm cl args;
     let saved_frames = List.tl vm.frames in
     vm.frames <- [List.hd vm.frames];
-    (try run vm
-     with
-     | VmSuspended _ as e ->
-       (* IO suspension: save the caller's continuation on the reuse stack.
-          DON'T merge frames — that corrupts the frame chain with nested
-          closures. On resume, restore_reuse in resume_vm processes these
-          in innermost-first order after the callback finishes. *)
-       vm.reuse_stack <- (saved_frames, saved_sp) :: vm.reuse_stack;
-       raise e
-     | e ->
-       vm.frames <- saved_frames;
-       vm.sp <- saved_sp;
-       raise e);
-    vm.frames <- saved_frames;
-    (* Snapshot/restore sp around the popped result.
-       OP_RETURN normally leaves sp = saved_sp + 1, but the bytecode-exhausted
-       path (or a callee that returns a closure whose own RETURN leaves extra
-       stack residue) can leave sp inconsistent. Read the result at the
-       expected slot and reset sp explicitly so the parent frame's
-       intermediate values are not corrupted. *)
     let result =
-      if vm.sp > saved_sp then vm.stack.(vm.sp - 1)
+      (try run vm;
-      else Nil
+        (* Normal completion: result sits at the top of the stack.
+           OP_RETURN normally leaves sp = saved_sp + 1, but the
+           bytecode-exhausted path (or a callee that returns a closure whose
+           own RETURN leaves extra stack residue) can leave sp inconsistent.
+           Read the result at the expected slot. *)
+        if vm.sp > saved_sp then vm.stack.(vm.sp - 1) else Nil
+       with
+       | VmSuspended (req, _) as e ->
+         (match !Sx_types._cek_io_resolver with
+          | Some resolver ->
+            (* Serving path: a `perform` fired inside this HO-primitive
+               callback (map/filter/reduce/for-each/…). The primitive's native
+               OCaml loop sits between us and the resume point, so we CANNOT
+               unwind it and resume later (the loop state would be lost and the
+               remaining elements dropped — corrupting the stack so the next
+               CALL_PRIM sees wrong args). Instead resolve the callback's IO
+               inline and run it to completion right here, returning its value
+               to the native loop exactly as a non-suspending callback would.
+               reuse_stack is isolated so an outer suspension's saved
+               continuations aren't consumed by this nested resume. *)
+            let saved_reuse = vm.reuse_stack in
+            vm.reuse_stack <- [];
+            let rec settle req =
+              let r = resolver req Nil in
+              (try resume_vm vm r
+               with VmSuspended (req2, _) -> settle req2)
+            in
+            let cb = settle req in
+            vm.reuse_stack <- saved_reuse;
+            cb
+          | None ->
+            (* CEK-driven path (no synchronous resolver): preserve the existing
+               behaviour — save the caller's continuation on the reuse stack and
+               re-raise so resume_vm restores it after the callback finishes.
+               DON'T merge frames — that corrupts the frame chain. *)
+            vm.reuse_stack <- (saved_frames, saved_sp) :: vm.reuse_stack;
+            raise e)
+       | e ->
+         vm.frames <- saved_frames;
+         vm.sp <- saved_sp;
+         raise e)
     in
+    vm.frames <- saved_frames;
     vm.sp <- saved_sp;
     result
   | None ->
@@ -808,14 +829,31 @@ and run vm =
           let b = pop vm and a = pop vm in
           push vm (match a, b with
             | Integer x, Integer y when y <> 0 && x mod y = 0 -> Integer (x / y)
-            | Integer x, Integer y -> Number (float_of_int x /. float_of_int y)
+            (* Non-divisible Integer/Integer + any Rational operand delegate to
+               the "/" primitive (single source of truth): (/ 5 2)=2.5 float,
+               (/ 1/2 2)=1/4 rational. Keeping the VM in lockstep with the
+               primitive avoids diverging from the CEK interpreter. *)
             | Number x, Number y -> Number (x /. y)
             | Integer x, Number y -> Number (float_of_int x /. y)
             | Number x, Integer y -> Number (x /. float_of_int y)
             | _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
         | 164 (* OP_EQ *) ->
           let b = pop vm and a = pop vm in
-          push vm (Bool (Sx_runtime._fast_eq a b))
+          (* Trivial scalar cases inline; everything else (Rational, Dict,
+             Record, Vector, ListRef, nested lists) delegates to the "="
+             primitive so VM equality matches CEK exactly. _fast_eq is a
+             stripped-down subset and must not be the source of truth here. *)
+          push vm (match a, b with
+            | Integer x, Integer y -> Bool (x = y)
+            | Number x, Number y -> Bool (x = y)
+            | Integer x, Number y -> Bool (float_of_int x = y)
+            | Number x, Integer y -> Bool (x = float_of_int y)
+            | String x, String y -> Bool (x = y)
+            | Bool x, Bool y -> Bool (x = y)
+            | Symbol x, Symbol y -> Bool (x = y)
+            | Keyword x, Keyword y -> Bool (x = y)
+            | Nil, Nil -> Bool true
+            | _ -> (Hashtbl.find Sx_primitives.primitives "=") [a; b])
         | 165 (* OP_LT *) ->
           let b = pop vm and a = pop vm in
           push vm (match a, b with
@@ -921,7 +959,17 @@ and run vm =
 
     After the callback finishes, restores any call_closure_reuse
     continuations saved on vm.reuse_stack (innermost first). *)
-let resume_vm vm result =
+and resume_vm vm result =
+  (* The resumed execution runs on [vm]; HO primitives (map/filter/…) called
+     during the resume reach for [!_active_vm] to run their callbacks on the
+     same stack. call_closure restored [_active_vm] to the *caller* when the
+     original VmSuspended unwound through it, so without re-asserting it here
+     the resumed run's callbacks land on the wrong VM (or allocate a fresh
+     one), corrupting the stack. Mirror call_closure's save/set/restore. *)
+  let prev_active = !_active_vm in
+  _active_vm := Some vm;
+  let restore () = _active_vm := prev_active in
+  (try
   (match vm.pending_cek with
    | Some cek_state ->
      vm.pending_cek <- None;
@@ -993,7 +1041,9 @@ let resume_vm vm result =
   let pending = List.rev vm.reuse_stack in
   vm.reuse_stack <- [];
   restore_reuse pending;
-  pop vm
+  let r = pop vm in
+  restore (); r
+  with e -> restore (); raise e)
 
 (** Execute a compiled module (top-level bytecode). *)
 let execute_module code globals =
@@ -1072,7 +1122,7 @@ let _jit_is_broken_name n =
     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 bytecode_find_opcode (pred : int -> bool) (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 *)
@@ -1085,7 +1135,7 @@ let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
   let found = ref false in
   while not !found && !ip < len do
     let op = bc.(!ip) in
-    if op >= 200 then found := true
+    if pred op then found := true
     else begin
       ip := !ip + 1;
       let extra = match op with
@@ -1112,6 +1162,49 @@ let bytecode_uses_extension_opcodes (bc : int array) (consts : value array) =
   done;
   !found
 
+let bytecode_uses_extension_opcodes bc consts =
+  bytecode_find_opcode (fun op -> op >= 200) bc consts
+
+(** True if [code] — or any closure nested in its constant pool — installs an
+    exception handler (OP_PUSH_HANDLER = 35), i.e. contains a `guard` /
+    `handler-bind` / dream-catch form. The VM's PUSH_HANDLER only intercepts a
+    VM-level RAISE (opcode 37); it does NOT catch the OCaml [Eval_error] that
+    the `error` primitive throws from inside a CALL/CALL_PRIM in a callee
+    frame. So a JIT-compiled guard silently fails to catch thrown errors (they
+    escape across the JIT frame).
+
+    The scan is RECURSIVE: a curried higher-order function (e.g. Dream's
+    `dream-catch-with = (fn (on-error) (fn (next) (fn (req) (guard ...))))`)
+    has no PUSH_HANDLER in its own body — the guard lives in a nested
+    `OP_CLOSURE` whose code sits in the constant pool. JIT-compiling the outer
+    function would mint that inner guard as a VmClosure with the broken VM
+    handler. Descending into nested closure codes catches this, so the whole
+    closure family runs on the CEK (whose guard catches correctly). Covers
+    dream-catch-with, host wrap-errors, and every guard user centrally. *)
+let rec code_uses_handler code =
+  bytecode_find_opcode (fun op -> op = 35) code.vc_bytecode code.vc_constants
+  || Array.exists (fun c ->
+       match c with
+       | Dict d when Hashtbl.mem d "bytecode" || Hashtbl.mem d "vc-bytecode" ->
+         (try code_uses_handler (code_from_value c) with _ -> false)
+       | _ -> false) code.vc_constants
+
+(** True if [code] — or any nested closure code — references (in its constant
+    pool, as a GLOBAL_GET/CALL name) a function registered in
+    [Sx_types.jit_excluded_caller_names] (a call/cc-establishing form like
+    Common-Lisp's cl-restart-case/cl-handler-case). Such a caller must run on
+    the CEK so the continuation captured inside the called form can escape.
+    The constant-pool string IS the referenced symbol name, so membership is a
+    direct lookup; recurse into nested closure codes. Skipped entirely (no
+    Hashtbl walk) when no escaping forms are registered. *)
+let rec code_refs_escaping_caller code =
+  Array.exists (fun c ->
+    match c with
+    | String s -> Hashtbl.mem Sx_types.jit_excluded_caller_names s
+    | Dict d when Hashtbl.mem d "bytecode" || Hashtbl.mem d "vc-bytecode" ->
+      (try code_refs_escaping_caller (code_from_value c) with _ -> false)
+    | _ -> false) code.vc_constants
+
 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 (
@@ -1127,6 +1220,13 @@ let jit_compile_lambda (l : lambda) globals =
     None
   ) else if _jit_is_broken_name fn_name then (
     None
+  ) else if Sx_types.jit_name_excluded fn_name then (
+    (* Guest-declared interpret-only function (continuation-using dispatch
+       core, or a whole namespace via prefix). Run on the CEK; the stack VM
+       can't escape through a CEK continuation and may miscompile deep AST
+       recursion into a non-terminating loop. See Sx_types.jit_excluded /
+       jit_excluded_prefixes. *)
+    None
   ) else
   try
     _jit_compiling := true;
@@ -1183,6 +1283,20 @@ let jit_compile_lambda (l : lambda) globals =
             Printf.eprintf "[jit] SKIP %s: bytecode uses extension opcodes (interpret-only in v1)\n%!"
               fn_name;
             None
+          end else if code_uses_handler code then begin
+            (* guard / handler-bind (possibly in a nested closure): VM
+               PUSH_HANDLER doesn't catch the `error` primitive's OCaml
+               exception across frames — run on the CEK. *)
+            Printf.eprintf "[jit] SKIP %s: installs an exception handler (guard) — interpret-only\n%!"
+              fn_name;
+            None
+          end else if Hashtbl.length Sx_types.jit_excluded_caller_names > 0
+                      && code_refs_escaping_caller code then begin
+            (* Calls a call/cc-establishing form (e.g. cl-restart-case): must
+               run on the CEK so the captured continuation can escape. *)
+            Printf.eprintf "[jit] SKIP %s: calls a call/cc-establishing form — interpret-only\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 }

lib/artdag/conformance.sh

@@ -13,7 +13,7 @@ if [ ! -x "$SX_SERVER" ]; then
   exit 1
 fi
 
-SUITES=(dag analyze plan execute optimize fed cost serialize stats fault)
+SUITES=(dag analyze plan execute optimize fed cost serialize stats fault post maude-optimize schedule)
 
 OUT_JSON="lib/artdag/scoreboard.json"
 OUT_MD="lib/artdag/scoreboard.md"
@@ -23,6 +23,49 @@ run_suite() {
   local file="lib/artdag/tests/${suite}.sx"
   local TMP
   TMP=$(mktemp)
+  local MAUDE_LOADS=""
+  local BRIDGE_LOAD=""
+  local MK_LOADS=""
+  local SCHED_LOAD=""
+  if [ "$suite" = "schedule" ]; then
+    MK_LOADS='(load "lib/guest/match.sx")
+(load "lib/minikanren/unify.sx")
+(load "lib/minikanren/stream.sx")
+(load "lib/minikanren/goals.sx")
+(load "lib/minikanren/fresh.sx")
+(load "lib/minikanren/conde.sx")
+(load "lib/minikanren/run.sx")
+(load "lib/minikanren/relations.sx")
+(load "lib/minikanren/project.sx")
+(load "lib/minikanren/diseq.sx")
+(load "lib/minikanren/intarith.sx")
+(load "lib/minikanren/matche.sx")
+(load "lib/minikanren/defrel.sx")
+(load "lib/minikanren/nafc.sx")
+(load "lib/minikanren/fd.sx")
+(load "lib/minikanren/clpfd.sx")'
+    SCHED_LOAD='(load "lib/artdag/schedule.sx")'
+  fi
+  if [ "$suite" = "maude-optimize" ]; then
+    MAUDE_LOADS='(load "lib/guest/lex.sx")
+(load "lib/guest/pratt.sx")
+(load "lib/maude/term.sx")
+(load "lib/maude/parser.sx")
+(load "lib/maude/sorts.sx")
+(load "lib/maude/reduce.sx")
+(load "lib/maude/matching.sx")
+(load "lib/maude/conditional.sx")
+(load "lib/maude/fire.sx")
+(load "lib/maude/confluence.sx")
+(load "lib/maude/rewrite.sx")
+(load "lib/maude/searchpath.sx")
+(load "lib/maude/strategy.sx")
+(load "lib/maude/meta.sx")
+(load "lib/maude/pretty.sx")
+(load "lib/maude/run.sx")'
+    BRIDGE_LOAD='(load "lib/artdag/maude-bridge.sx")
+(load "lib/artdag/optimize-rules.sx")'
+  fi
   cat > "$TMP" << EPOCHS
 (epoch 1)
 (load "spec/stdlib.sx")
@@ -41,6 +84,8 @@ run_suite() {
 (load "lib/persist/log.sx")
 (load "lib/persist/kv.sx")
 (load "lib/persist/api.sx")
+${MAUDE_LOADS}
+${MK_LOADS}
 (load "lib/artdag/dag.sx")
 (load "lib/artdag/analyze.sx")
 (load "lib/artdag/plan.sx")
@@ -51,7 +96,10 @@ run_suite() {
 (load "lib/artdag/serialize.sx")
 (load "lib/artdag/stats.sx")
 (load "lib/artdag/fault.sx")
+(load "lib/artdag/post.sx")
 (load "lib/artdag/api.sx")
+${BRIDGE_LOAD}
+${SCHED_LOAD}
 (epoch 2)
 (eval "(define artdag-test-pass 0)")
 (eval "(define artdag-test-fail 0)")

lib/artdag/maude-bridge.sx

@@ -0,0 +1,118 @@
+; lib/artdag/maude-bridge.sx — adapter between an artdag effect DAG and maude terms.
+; A node {:op :inputs :params :commutative} <-> a maude (mau/app op (args...)).
+; Inputs become argument subterms (recursively from the DAG). A trailing
+; "artdag:meta" subterm carries the params (a write-to-string token) and the
+; commutativity flag, so the encoding is lossless and dag->term->dag is the
+; identity on canonical (content-id) form. Commutative ops map to maude AC
+; operators in the optimizer module, so input order is irrelevant there —
+; mirroring the content-id's order-insensitivity for commutative nodes.
+;
+; maude (lib/maude) is a READ-ONLY consumed substrate: mau/app, mau/const,
+; mau/op, mau/args, mau/app? are its term constructors/accessors.
+
+; ---- list helpers (no host last/but-last) ----
+
+(define
+  artdag/mb-last
+  (fn
+    (xs)
+    (if (empty? (rest xs)) (first xs) (artdag/mb-last (rest xs)))))
+
+(define
+  artdag/mb-but-last
+  (fn
+    (xs)
+    (if
+      (empty? (rest xs))
+      (list)
+      (cons (first xs) (artdag/mb-but-last (rest xs))))))
+
+; ---- params <-> token ----
+; params are keyword-keyed dicts; write-to-string/read round-trips them
+; (key order may differ but the dicts compare structurally equal).
+
+(define artdag/mb-meta-op "artdag:meta")
+
+(define artdag/params->token (fn (params) (write-to-string params)))
+
+(define artdag/token->params (fn (token) (read (open-input-string token))))
+
+(define
+  artdag/mb-meta-term
+  (fn
+    (params commutative)
+    (mau/app
+      artdag/mb-meta-op
+      (list
+        (mau/const (artdag/params->token params))
+        (mau/const (if commutative "c" "n"))))))
+
+(define
+  artdag/mb-meta-term?
+  (fn (t) (and (mau/app? t) (= (mau/op t) artdag/mb-meta-op))))
+
+; ---- dag -> term ----
+
+(define
+  artdag/node->term
+  (fn
+    (node input-terms)
+    (mau/app
+      (artdag/node-op node)
+      (concat
+        input-terms
+        (list
+          (artdag/mb-meta-term
+            (artdag/node-params node)
+            (get node :commutative)))))))
+
+(define
+  artdag/dag->term
+  (fn
+    (dag id)
+    (let
+      ((node (artdag/dag-get dag id)))
+      (artdag/node->term
+        node
+        (map (fn (in) (artdag/dag->term dag in)) (artdag/node-inputs node))))))
+
+; ---- term -> dag ----
+; build-entries with synthesized local names; artdag/build recomputes content-ids
+; (which are name-independent), so the reconstructed dag is identical on canonical
+; form. Shared subterms re-collapse to one node/id during build's dedup.
+
+(define artdag/term-meta (fn (t) (artdag/mb-last (mau/args t))))
+
+(define artdag/term-input-terms (fn (t) (artdag/mb-but-last (mau/args t))))
+
+(define
+  artdag/term-params
+  (fn
+    (t)
+    (artdag/token->params (mau/op (first (mau/args (artdag/term-meta t)))))))
+
+(define
+  artdag/term-commutative
+  (fn
+    (t)
+    (= "c" (mau/op (nth (mau/args (artdag/term-meta t)) 1)))))
+
+(define
+  artdag/term->build
+  (fn
+    (t counter acc)
+    (let
+      ((built (reduce (fn (st child) (let ((r (artdag/term->build child (get st :counter) (get st :acc)))) {:counter (get r :counter) :acc (get r :acc) :names (concat (get st :names) (list (get r :name)))})) {:counter counter :acc acc :names (list)} (artdag/term-input-terms t))))
+      (let ((my-name (str "mb" (get built :counter)))) {:name my-name :counter (+ (get built :counter) 1) :acc (concat (get built :acc) (list (list my-name (mau/op t) (get built :names) (artdag/term-params t) (artdag/term-commutative t))))}))))
+
+(define
+  artdag/term->entries
+  (fn (t) (get (artdag/term->build t 0 (list)) :acc)))
+
+(define artdag/term->dag (fn (t) (artdag/build (artdag/term->entries t))))
+
+; ---- round-trip convenience ----
+
+(define
+  artdag/mb-roundtrip
+  (fn (dag id) (artdag/term->dag (artdag/dag->term dag id))))

lib/artdag/optimize-rules.sx

@@ -0,0 +1,213 @@
+; lib/artdag/optimize-rules.sx — Phase 7: optimisation laws as a confluent maude module.
+; The optimised effect pipeline IS the normal form of the rule set, so confluence
+; (mau/confluent?) is exactly content-id stability: every rewrite order reaches the
+; same normal form. Media ops (blur/bright/id/over) are the opaque-op model from
+; lib/maude/tests/effects.sx — the engine reasons about the pipeline algebra, never
+; pixels. The radius algebra is an AC operator with identity 0 (unary 1s): Peano
+; successor rules (s M + N = s(M+N), 0 + N = N) are NOT confluent here (the symbolic
+; critical pairs M + 0 and (A+B)+C vs A+(B+C) stick), whereas [assoc comm id: 0]
+; joins them via canonical form. maude (lib/maude) is a READ-ONLY consumed substrate:
+; mau/parse-module, mau/creduce, mau/creduce->str, mau/ccanon, mau/confluent?,
+; mau/non-joinable-pairs, mau/cp->str, mau/app/const/op/args/app?.
+
+(define
+  artdag/opt-module-src
+  (str
+    "fmod ARTDAGOPT is\n"
+    "  sorts Img Num .\n"
+    "  op 0 : -> Num .\n"
+    "  op 1 : -> Num .\n"
+    "  op _+_ : Num Num -> Num [assoc comm id: 0] .\n"
+    "  op blur : Img Num -> Img .\n"
+    "  op bright : Img Num -> Img .\n"
+    "  op id : Img -> Img .\n"
+    "  op over : Img Img -> Img [comm] .\n"
+    "  vars I J : Img .\n"
+    "  vars M N : Num .\n"
+    "  eq id(I) = I .\n"
+    "  eq blur(I, 0) = I .\n"
+    "  eq bright(I, 0) = I .\n"
+    "  eq blur(blur(I, M), N) = blur(I, M + N) .\n"
+    "  eq bright(bright(I, M), N) = bright(I, M + N) .\n"
+    "  eq over(I, I) = I .\n"
+    "endfm"))
+
+(define artdag/opt-module (mau/parse-module artdag/opt-module-src))
+
+; ops whose last term arg is the radius (Num); other args are image inputs.
+(define artdag/opt-radius-ops (list "blur" "bright"))
+; commutative ops (mirror the content-id's order-insensitivity).
+(define artdag/opt-comm-ops (list "over"))
+
+; ---- reduce a surface pipeline (source string) to its optimised normal form ----
+
+(define
+  artdag/opt-reduce-term
+  (fn (src) (mau/creduce-term artdag/opt-module src)))
+
+(define
+  artdag/opt-normal-form
+  (fn (src) (mau/creduce->str artdag/opt-module src)))
+
+(define artdag/opt-canon (fn (src) (mau/ccanon artdag/opt-module src)))
+
+; two surface pipelines optimise to the same pipeline (=> same content id) iff
+; their normal forms coincide.
+(define
+  artdag/opt-same-form?
+  (fn (a b) (= (artdag/opt-normal-form a) (artdag/opt-normal-form b))))
+
+; ---- confluence / content-id stability (consume lib/maude/confluence.sx) ----
+
+(define artdag/opt-confluent? (fn () (mau/confluent? artdag/opt-module)))
+
+(define
+  artdag/opt-non-joinable
+  (fn () (mau/non-joinable-pairs artdag/opt-module)))
+
+(define
+  artdag/opt-non-joinable->strs
+  (fn
+    ()
+    (map
+      (fn (cp) (mau/cp->str artdag/opt-module cp))
+      (artdag/opt-non-joinable))))
+
+; ---- radius <-> unary Num term ----
+
+(define
+  artdag/num->unary
+  (fn
+    (n)
+    (if
+      (<= n 0)
+      (mau/const "0")
+      (reduce
+        (fn (acc i) (mau/app "_+_" (list acc (mau/const "1"))))
+        (mau/const "1")
+        (range 1 n)))))
+
+(define
+  artdag/unary->num
+  (fn
+    (t)
+    (let
+      ((op (mau/op t)))
+      (cond
+        ((= op "1") 1)
+        ((= op "_+_")
+          (reduce
+            (fn (a x) (+ a (artdag/unary->num x)))
+            0
+            (mau/args t)))
+        (else 0)))))
+
+; ---- dag cone -> opt-term ----
+; leaves -> nullary const (op name); a :radius node -> op(inputs..., unary radius);
+; any other op -> op(inputs...). over (commutative) maps to the module's comm op.
+
+(define
+  artdag/dag->opt-term
+  (fn
+    (dag id)
+    (let
+      ((node (artdag/dag-get dag id)))
+      (let
+        ((op (artdag/node-op node))
+          (ins
+            (map
+              (fn (i) (artdag/dag->opt-term dag i))
+              (artdag/node-inputs node)))
+          (params (artdag/node-params node)))
+        (if
+          (empty? ins)
+          (mau/const op)
+          (if
+            (artdag/member? op artdag/opt-radius-ops)
+            (mau/app
+              op
+              (concat ins (list (artdag/num->unary (get params :radius)))))
+            (mau/app op ins)))))))
+
+; ---- opt-term -> build entries (synthesized names; build recomputes content-ids) ----
+
+(define
+  artdag/opt-last
+  (fn
+    (xs)
+    (if (empty? (rest xs)) (first xs) (artdag/opt-last (rest xs)))))
+
+(define
+  artdag/opt-but-last
+  (fn
+    (xs)
+    (if
+      (empty? (rest xs))
+      (list)
+      (cons (first xs) (artdag/opt-but-last (rest xs))))))
+
+(define
+  artdag/opt-term->build
+  (fn
+    (t counter acc)
+    (if
+      (not (mau/app? t))
+      (let ((nm (str "ob" counter))) {:name nm :acc (concat acc (list (list nm (mau/op t) (list) {}))) :counter (+ counter 1)})
+      (let
+        ((op (mau/op t))
+          (radius? (artdag/member? (mau/op t) artdag/opt-radius-ops)))
+        (let
+          ((in-terms (if radius? (artdag/opt-but-last (mau/args t)) (mau/args t)))
+            (params (if radius? {:radius (artdag/unary->num (artdag/opt-last (mau/args t)))} {}))
+            (comm? (artdag/member? op artdag/opt-comm-ops)))
+          (let
+            ((built (reduce (fn (st ct) (let ((r (artdag/opt-term->build ct (get st :counter) (get st :acc)))) {:acc (get r :acc) :counter (get r :counter) :names (concat (get st :names) (list (get r :name)))})) {:acc acc :counter counter :names (list)} in-terms)))
+            (let ((nm (str "ob" (get built :counter)))) {:name nm :acc (concat (get built :acc) (list (list nm op (get built :names) params comm?))) :counter (+ (get built :counter) 1)})))))))
+
+(define
+  artdag/opt-term->entries
+  (fn (t) (get (artdag/opt-term->build t 0 (list)) :acc)))
+
+; ---- optimise a DAG via maude: encode -> creduce -> decode -> rebuild ----
+; result-preserving: the optimised DAG executes to the same result as the original.
+(define
+  artdag/opt-reduce
+  (fn
+    (dag id)
+    (artdag/build
+      (artdag/opt-term->entries
+        (mau/creduce artdag/opt-module (artdag/dag->opt-term dag id))))))
+
+; content-id of the optimised sink (the head of the reduced term's rebuilt DAG).
+(define
+  artdag/opt-reduce-sink
+  (fn
+    (dag id)
+    (let
+      ((o (artdag/opt-reduce dag id)))
+      (artdag/opt-last (artdag/dag-order o)))))
+
+; ---- cost-directed: the maude-optimised cone never costs more than the original ----
+; compares the original output cone (dce to id) against the maude-reduced DAG under an
+; injected cost-fn (op params). Monotone per-node costs => optimisation is never a
+; pessimisation: fewer nodes (DCE/dedup) and fused ops (one blur(M+N) for two blurs).
+
+(define
+  artdag/opt-improvement
+  (fn
+    (dag id cost-fn)
+    (let
+      ((orig (artdag/dce dag (list id))) (opt (artdag/opt-reduce dag id)))
+      {:before (artdag/total-work orig cost-fn)
+        :after (artdag/total-work opt cost-fn)
+        :before-path (artdag/critical-path orig cost-fn)
+        :after-path (artdag/critical-path opt cost-fn)
+        :optimized opt})))
+
+(define
+  artdag/opt-cheaper?
+  (fn
+    (dag id cost-fn)
+    (let
+      ((imp (artdag/opt-improvement dag id cost-fn)))
+      (<= (get imp :after) (get imp :before)))))

lib/artdag/post.sx

@@ -0,0 +1,68 @@
+; lib/artdag/post.sx — project an artdag job to/from a feed "post object", so a job
+; can ride as the :object of a feed activity ({:actor :verb :object :at :tags}) per the
+; host loop. A post object is content-addressed and self-verifying:
+;   {:type "artdag/job" :id <content-id of the output node> :wire <dag->wire>}
+; The :id IS the post/object id (the stable structural digest = natural AP object id);
+; the :wire is the self-describing, write/read-safe payload from serialize.sx whose
+; records each carry their own content-id. The dag<->feed-activity wrapping (actor/verb/
+; at/tags) stays on the host/feed side; this file is only the job<->object projection.
+; Depends on dag.sx + serialize.sx (and execute.sx for post-run).
+
+(define artdag/post-type "artdag/job")
+
+; a job = a dag + the output node (by author name) the post is "about".
+(define artdag/job->post-object (fn (dag output-name) {:id (artdag/dag-id dag output-name) :type artdag/post-type :wire (artdag/dag->wire dag)}))
+
+(define
+  artdag/post-object?
+  (fn
+    (x)
+    (and
+      (= (type-of x) "dict")
+      (= (get x :type) artdag/post-type)
+      (has-key? x :id)
+      (has-key? x :wire))))
+
+(define artdag/post-object-id (fn (post) (get post :id)))
+
+(define artdag/post-object-wire (fn (post) (get post :wire)))
+
+; integrity: the payload's records each verify (id == recomputed content-id) AND the
+; claimed post id is actually produced by the job (present among the wire records).
+(define
+  artdag/post-object-verify
+  (fn
+    (post)
+    (and
+      (artdag/post-object? post)
+      (artdag/wire-verify (get post :wire))
+      (artdag/member?
+        (get post :id)
+        (map (fn (rec) (nth rec 0)) (get post :wire))))))
+
+; decode the payload back into a runnable dag (pure; verify separately, mirroring
+; serialize.sx's wire->dag / wire-verify split).
+(define
+  artdag/post-object->job
+  (fn (post) (artdag/wire->dag (get post :wire))))
+
+; ---- string transport (drop into a feed activity / SXTP body) ----
+
+(define
+  artdag/job->post-string
+  (fn
+    (dag output-name)
+    (write-to-string (artdag/job->post-object dag output-name))))
+
+(define artdag/post-string->object (fn (s) (read (open-input-string s))))
+
+; ---- run a received post: decode -> run -> result at the post id ----
+; the peer recomputes the job (content-addressed, so a warm cache hits everything it
+; already has). Returns the result of the output node the post is about.
+(define
+  artdag/post-run
+  (fn
+    (post runner cache)
+    (artdag/result-of
+      (artdag/run (artdag/post-object->job post) runner cache)
+      (artdag/post-object-id post))))

lib/artdag/schedule.sx

@@ -0,0 +1,139 @@
+; lib/artdag/schedule.sx — relational scheduling on lib/minikanren CLP(FD).
+; Each node gets a slot var in [1..max-slots]; every edge (input->node) imposes
+; `fd-lt slot(input) slot(node)`. `fd-label` searches the finite domains; a solution
+; is a {node-id -> slot} assignment respecting all dependencies. Grouping by slot
+; gives parallel batches (plan.sx's batch shape). Labeling picks smallest slots
+; first, so the FIRST solution is the ASAP leveling — it agrees with plan.sx's greedy
+; Kahn waves; the relational extra is enumerating EVERY valid schedule. The
+; parallelism cap is a cardinality property, enforced by filtering labeled solutions
+; (the FD core handles precedence only). lib/minikanren is a READ-ONLY consumed
+; substrate: make-var, fd-in, fd-lt, fd-label, mk-conj, reify, stream-take, empty-s.
+
+(define
+  artdag/range1
+  (fn (n) (map (fn (i) (+ i 1)) (range 0 n))))
+
+(define
+  artdag/-zip-assoc
+  (fn
+    (ids vals)
+    (reduce
+      (fn (m p) (assoc m (first p) (nth p 1)))
+      {}
+      (zip ids vals))))
+
+; build the constraint goal + the ordered slot vars for a dag over domain 1..maxslots.
+(define
+  artdag/sched-goal-and-vars
+  (fn
+    (dag maxslots)
+    (let
+      ((ids (artdag/dag-order dag)))
+      (let
+        ((vars (map (fn (id) (make-var)) ids)))
+        (let
+          ((id->var (artdag/-zip-assoc ids vars))
+            (dom (artdag/range1 maxslots)))
+          (let
+            ((in-goals (map (fn (v) (fd-in v dom)) vars))
+              (lt-goals
+                (reduce
+                  (fn
+                    (acc id)
+                    (concat
+                      acc
+                      (map
+                        (fn
+                          (inp)
+                          (fd-lt (get id->var inp) (get id->var id)))
+                        (artdag/node-inputs (artdag/dag-get dag id)))))
+                  (list)
+                  ids)))
+            {:goal (apply mk-conj (concat in-goals lt-goals (list (fd-label vars)))) :vars vars :ids ids}))))))
+
+(define
+  artdag/-sched-solutions
+  (fn
+    (g limit)
+    (map
+      (fn (sol) (artdag/-zip-assoc (get g :ids) sol))
+      (map
+        (fn (s) (reify (get g :vars) s))
+        (stream-take limit ((get g :goal) empty-s))))))
+
+; all valid dependency-respecting slot assignments within 1..maxslots.
+(define
+  artdag/schedules
+  (fn
+    (dag maxslots)
+    (artdag/-sched-solutions
+      (artdag/sched-goal-and-vars dag maxslots)
+      -1)))
+
+; one valid assignment (ASAP within the bound), or nil if maxslots is too small.
+(define
+  artdag/schedule
+  (fn
+    (dag maxslots)
+    (let
+      ((ss (artdag/-sched-solutions (artdag/sched-goal-and-vars dag maxslots) 1)))
+      (if (empty? ss) nil (first ss)))))
+
+; ASAP schedule: node-count slots are always sufficient (a linear chain is the worst
+; case), and smallest-first labeling yields the tightest leveling.
+(define
+  artdag/schedule-asap
+  (fn (dag) (artdag/schedule dag (artdag/node-count dag))))
+
+(define
+  artdag/schedule-makespan
+  (fn
+    (assignment)
+    (reduce
+      (fn (m id) (max m (get assignment id)))
+      0
+      (keys assignment))))
+
+; group node-ids by slot (ascending), each batch id-sorted for determinism.
+(define
+  artdag/schedule->batches
+  (fn
+    (dag assignment)
+    (let
+      ((mx (artdag/schedule-makespan assignment)))
+      (filter
+        (fn (b) (not (empty? b)))
+        (map
+          (fn
+            (slot)
+            (artdag/sort-strings
+              (filter
+                (fn (id) (= (get assignment id) slot))
+                (keys assignment))))
+          (artdag/range1 mx))))))
+
+; independent check: every input is scheduled strictly before its consumer.
+(define
+  artdag/schedule-valid?
+  (fn
+    (dag assignment)
+    (every?
+      (fn
+        (id)
+        (every?
+          (fn (inp) (< (get assignment inp) (get assignment id)))
+          (artdag/node-inputs (artdag/dag-get dag id))))
+      (artdag/dag-order dag))))
+
+; schedules whose every slot holds <= cap nodes (parallelism cap as a post-filter).
+(define
+  artdag/schedules-capped
+  (fn
+    (dag maxslots cap)
+    (filter
+      (fn
+        (asn)
+        (every?
+          (fn (b) (<= (len b) cap))
+          (artdag/schedule->batches dag asn)))
+      (artdag/schedules dag maxslots))))

lib/artdag/scoreboard.json

@@ -9,9 +9,12 @@
     "cost": {"pass": 13, "fail": 0},
     "serialize": {"pass": 13, "fail": 0},
     "stats": {"pass": 12, "fail": 0},
-    "fault": {"pass": 14, "fail": 0}
+    "fault": {"pass": 14, "fail": 0},
+    "post": {"pass": 12, "fail": 0},
+    "maude-optimize": {"pass": 40, "fail": 0},
+    "schedule": {"pass": 15, "fail": 0}
   },
-  "total_pass": 158,
+  "total_pass": 225,
   "total_fail": 0,
-  "total": 158
+  "total": 225
 }

lib/artdag/scoreboard.md

@@ -14,4 +14,7 @@ _Generated by `lib/artdag/conformance.sh`_
 | serialize | 13 | 0 | 13 |
 | stats | 12 | 0 | 12 |
 | fault | 14 | 0 | 14 |
-| **Total** | **158** | **0** | **158** |
+| post | 12 | 0 | 12 |
+| maude-optimize | 40 | 0 | 40 |
+| schedule | 15 | 0 | 15 |
+| **Total** | **225** | **0** | **225** |

lib/artdag/tests/maude-optimize.sx

@@ -0,0 +1,345 @@
+; Phase 7 — rule-based optimization via maude-on-sx.
+; Bridge round-trip: dag->term->dag is the identity on canonical (content-id) form.
+
+; ---- linear chain a -> b -> c (b carries params) ----
+
+(define
+  mo-chain
+  (artdag/build
+    (list
+      (list "a" "in" (list) {:v 5})
+      (list "b" "blur" (list "a") {:radius 2})
+      (list "c" "blur" (list "b") {:radius 3}))))
+(define mo-c-id (artdag/dag-id mo-chain "c"))
+(define mo-chain-rt (artdag/mb-roundtrip mo-chain mo-c-id))
+
+(artdag-test
+  "roundtrip: sink id preserved"
+  (artdag/member? mo-c-id (keys (artdag/dag-nodes mo-chain-rt)))
+  true)
+
+(artdag-test
+  "roundtrip: node count preserved"
+  (artdag/node-count mo-chain-rt)
+  3)
+
+(artdag-test
+  "roundtrip: sink op preserved"
+  (artdag/node-op (artdag/dag-get mo-chain-rt mo-c-id))
+  "blur")
+
+(artdag-test
+  "roundtrip: sink params preserved"
+  (artdag/node-params (artdag/dag-get mo-chain-rt mo-c-id))
+  {:radius 3})
+
+(artdag-test
+  "roundtrip: full reconstructed node equals original"
+  (= (artdag/dag-get mo-chain-rt mo-c-id) (artdag/dag-get mo-chain mo-c-id))
+  true)
+
+; ---- term shape ----
+
+(define mo-c-term (artdag/dag->term mo-chain mo-c-id))
+
+(artdag-test "term: sink op is the maude operator" (mau/op mo-c-term) "blur")
+
+(artdag-test
+  "term: params recovered from meta"
+  (artdag/term-params mo-c-term)
+  {:radius 3})
+
+(artdag-test
+  "term: commutative flag recovered (false)"
+  (artdag/term-commutative mo-c-term)
+  false)
+
+(artdag-test
+  "term->entries: one entry per node"
+  (len (artdag/term->entries mo-c-term))
+  3)
+
+; ---- commutative node: order-insensitive id survives round-trip ----
+
+(define
+  mo-comm
+  (artdag/build
+    (list
+      (list "x" "src" (list) {})
+      (list "y" "noise" (list) {})
+      (list "z" "over" (list "x" "y") {} true))))
+(define mo-z-id (artdag/dag-id mo-comm "z"))
+(define mo-comm-rt (artdag/mb-roundtrip mo-comm mo-z-id))
+
+(artdag-test
+  "roundtrip comm: commutative id preserved"
+  (artdag/member? mo-z-id (keys (artdag/dag-nodes mo-comm-rt)))
+  true)
+
+(artdag-test
+  "term comm: commutative flag recovered (true)"
+  (artdag/term-commutative (artdag/dag->term mo-comm mo-z-id))
+  true)
+
+; ---- diamond: shared subgraph re-collapses to one node ----
+
+(define
+  mo-diamond
+  (artdag/build
+    (list
+      (list "a" "src" (list) {})
+      (list "b" "blur" (list "a") {:radius 1})
+      (list "c" "bright" (list "a") {:gain 2})
+      (list "d" "over" (list "b" "c") {} true))))
+(define mo-d-id (artdag/dag-id mo-diamond "d"))
+(define mo-diamond-rt (artdag/mb-roundtrip mo-diamond mo-d-id))
+
+(artdag-test
+  "roundtrip diamond: shared node not duplicated"
+  (artdag/node-count mo-diamond-rt)
+  4)
+
+(artdag-test
+  "roundtrip diamond: sink id preserved"
+  (artdag/member? mo-d-id (keys (artdag/dag-nodes mo-diamond-rt)))
+  true)
+
+(artdag-test
+  "roundtrip diamond: shared src id preserved"
+  (artdag/member?
+    (artdag/dag-id mo-diamond "a")
+    (keys (artdag/dag-nodes mo-diamond-rt)))
+  true)
+
+; ---- optimisation laws as a confluent maude module (optimize-rules.sx) ----
+; The optimised pipeline is the normal form; confluence => stable content id.
+
+(artdag-test "opt module is confluent" (artdag/opt-confluent?) true)
+
+(artdag-test
+  "opt module has no non-joinable critical pairs"
+  (len (artdag/opt-non-joinable))
+  0)
+
+(artdag-test
+  "law: identity elimination"
+  (artdag/opt-normal-form "id(src)")
+  "src")
+
+(artdag-test
+  "law: zero-radius blur is a no-op"
+  (artdag/opt-normal-form "blur(src, 0)")
+  "src")
+
+(artdag-test
+  "law: zero-radius bright is a no-op"
+  (artdag/opt-normal-form "bright(src, 0)")
+  "src")
+
+(artdag-test
+  "law: adjacent blur fusion adds radii"
+  (artdag/opt-normal-form "blur(blur(src, 1), 1)")
+  "blur(src, _+_(1, 1))")
+
+(artdag-test
+  "fusion normal form is rewrite-order stable"
+  (artdag/opt-same-form?
+    "blur(blur(blur(src, 1), 1), 1)"
+    "blur(blur(src, 1 + 1), 1)")
+  true)
+
+(artdag-test
+  "laws compose: id + no-op + fusion"
+  (artdag/opt-normal-form "bright(id(blur(blur(src, 1), 1)), 0)")
+  "blur(src, _+_(1, 1))")
+
+(artdag-test
+  "law: idempotent over dedup (CSE)"
+  (artdag/opt-normal-form "over(blur(src, 1), blur(src, 1))")
+  "blur(src, 1)")
+
+(artdag-test
+  "distinct over operands do not dedup"
+  (artdag/opt-same-form? "over(blur(src, 1), blur(src, 1 + 1))" "blur(src, 1)")
+  false)
+
+(artdag-test
+  "distinct pipelines stay distinct"
+  (artdag/opt-same-form? "blur(src, 1)" "bright(src, 1)")
+  false)
+
+; ---- bridge the normal form back to a runnable DAG (opt-reduce) ----
+; result-preserving: the maude-optimised DAG executes to the same result as the
+; original, with fewer nodes. Runner is a numeric op model (blur/bright additive in
+; radius, id pass-through, over idempotent) so the pipeline algebra holds concretely.
+
+(define
+  mo-eq-runner
+  (artdag/op-table-runner
+    {:src (fn (params inputs) 0)
+      :blur (fn (params inputs) (+ (first inputs) (get params :radius)))
+      :bright (fn (params inputs) (+ (first inputs) (* 100 (get params :radius))))
+      :id (fn (params inputs) (first inputs))
+      :over (fn (params inputs) (if (= (nth inputs 0) (nth inputs 1)) (nth inputs 0) (+ (nth inputs 0) (nth inputs 1))))}))
+
+(define
+  mo-eq-result
+  (fn (dag id) (artdag/result-of (artdag/run dag mo-eq-runner (persist/open)) id)))
+
+(define
+  mo-eq-opt-result
+  (fn
+    (dag id)
+    (let
+      ((o (artdag/opt-reduce dag id)))
+      (artdag/result-of (artdag/run o mo-eq-runner (persist/open)) (artdag/opt-last (artdag/dag-order o))))))
+
+; fixture: blur;blur chain + id + zero-radius bright (all collapse to one blur)
+(define
+  mo-chain5
+  (artdag/build
+    (list
+      (list "s" "src" (list) {})
+      (list "b1" "blur" (list "s") {:radius 1})
+      (list "b2" "blur" (list "b1") {:radius 1})
+      (list "i" "id" (list "b2") {})
+      (list "z" "bright" (list "i") {:radius 0}))))
+(define mo-chain5-id (artdag/dag-id mo-chain5 "z"))
+(define mo-chain5-opt (artdag/opt-reduce mo-chain5 mo-chain5-id))
+(define mo-chain5-sink (artdag/opt-last (artdag/dag-order mo-chain5-opt)))
+
+(artdag-test
+  "opt-reduce: 5-node chain collapses to 2 nodes"
+  (artdag/node-count mo-chain5-opt)
+  2)
+
+(artdag-test
+  "opt-reduce: fused sink op is blur"
+  (artdag/node-op (artdag/dag-get mo-chain5-opt mo-chain5-sink))
+  "blur")
+
+(artdag-test
+  "opt-reduce: fused sink radius is the sum"
+  (artdag/node-params (artdag/dag-get mo-chain5-opt mo-chain5-sink))
+  {:radius 2})
+
+(artdag-test
+  "opt-reduce: result-preserving on chain"
+  (= (mo-eq-result mo-chain5 mo-chain5-id) (mo-eq-opt-result mo-chain5 mo-chain5-id))
+  true)
+
+; fixture: over of identical subpipelines (idempotent dedup)
+(define
+  mo-dedup
+  (artdag/build
+    (list
+      (list "s" "src" (list) {})
+      (list "b" "blur" (list "s") {:radius 2})
+      (list "o" "over" (list "b" "b") {} true))))
+(define mo-dedup-id (artdag/dag-id mo-dedup "o"))
+
+(artdag-test
+  "opt-reduce: over dedup collapses to 2 nodes"
+  (artdag/node-count (artdag/opt-reduce mo-dedup mo-dedup-id))
+  2)
+
+(artdag-test
+  "opt-reduce: result-preserving on dedup"
+  (= (mo-eq-result mo-dedup mo-dedup-id) (mo-eq-opt-result mo-dedup mo-dedup-id))
+  true)
+
+; non-optimisable DAG: opt-reduce is a faithful round-trip (no laws fire)
+(define
+  mo-plain
+  (artdag/build
+    (list
+      (list "s" "src" (list) {})
+      (list "b" "blur" (list "s") {:radius 3}))))
+(define mo-plain-id (artdag/dag-id mo-plain "b"))
+(define mo-plain-opt (artdag/opt-reduce mo-plain mo-plain-id))
+
+(artdag-test
+  "opt-reduce: untouched DAG keeps its node count"
+  (artdag/node-count mo-plain-opt)
+  2)
+
+(artdag-test
+  "opt-reduce: untouched DAG keeps its radius (unary round-trip)"
+  (artdag/node-params
+    (artdag/dag-get mo-plain-opt (artdag/opt-last (artdag/dag-order mo-plain-opt))))
+  {:radius 3})
+
+; ---- cost-directed: optimisation never increases cost ----
+
+(define
+  mo-rcost
+  (fn (op params) (if (= op "blur") (max 1 (get params :radius)) 1)))
+
+(artdag-test
+  "opt-improvement: const-cost total work drops on fused chain"
+  (let ((imp (artdag/opt-improvement mo-chain5 mo-chain5-id artdag/const-cost)))
+    (list (get imp :before) (get imp :after)))
+  (list 5 2))
+
+(artdag-test
+  "opt-improvement: critical path shrinks under const cost"
+  (let ((imp (artdag/opt-improvement mo-chain5 mo-chain5-id artdag/const-cost)))
+    (< (get imp :after-path) (get imp :before-path)))
+  true)
+
+(artdag-test
+  "opt-cheaper?: fused chain is cheaper under radius-weighted cost"
+  (artdag/opt-cheaper? mo-chain5 mo-chain5-id mo-rcost)
+  true)
+
+(artdag-test
+  "opt-cheaper?: over dedup is cheaper"
+  (artdag/opt-cheaper? mo-dedup mo-dedup-id artdag/const-cost)
+  true)
+
+(artdag-test
+  "opt-cheaper?: untouched DAG keeps equal cost (never a pessimisation)"
+  (artdag/opt-cheaper? mo-plain mo-plain-id artdag/const-cost)
+  true)
+
+; ---- the confluence gate is meaningful, not vacuous ----
+; the Peano-arithmetic variant of the same laws is KNOWN non-confluent (M+0 sticks,
+; (A+B)+C vs A+(B+C) don't join). Assert the checker actually catches it, so the
+; green "opt module is confluent" above is real evidence, not a checker that passes
+; everything.
+
+(define
+  mo-peano-module
+  (mau/parse-module
+    (str
+      "fmod ARTDAGPEANO is\n"
+      "  sorts Img Num .\n"
+      "  op src : -> Img .\n"
+      "  op 0 : -> Num .\n"
+      "  op s_ : Num -> Num .\n"
+      "  op _+_ : Num Num -> Num .\n"
+      "  op blur : Img Num -> Img .\n"
+      "  op bright : Img Num -> Img .\n"
+      "  op id : Img -> Img .\n"
+      "  op over : Img Img -> Img [comm] .\n"
+      "  vars I J : Img .\n"
+      "  vars M N : Num .\n"
+      "  eq 0 + N = N .\n"
+      "  eq s M + N = s (M + N) .\n"
+      "  eq id(I) = I .\n"
+      "  eq blur(I, 0) = I .\n"
+      "  eq bright(I, 0) = I .\n"
+      "  eq blur(blur(I, M), N) = blur(I, M + N) .\n"
+      "  eq bright(bright(I, M), N) = bright(I, M + N) .\n"
+      "  eq over(I, I) = I .\n"
+      "endfm")))
+
+(artdag-test
+  "confluence gate is real: Peano variant is flagged non-confluent"
+  (mau/confluent? mo-peano-module)
+  false)
+
+(artdag-test
+  "confluence gate is real: Peano variant names its non-joinable pairs"
+  (> (len (mau/non-joinable-pairs mo-peano-module)) 0)
+  true)

lib/artdag/tests/post.sx

@@ -0,0 +1,111 @@
+; Forward direction — artdag job as a feed "post object" (per the host loop).
+; A job projects to a content-addressed, self-verifying object suitable as a feed
+; activity :object; a peer decodes, verifies and runs it to the same result.
+
+(define po-runner (artdag/op-table-runner {:blur (fn (params inputs) (+ (first inputs) (get params :radius))) :src (fn (params inputs) 0) :over (fn (params inputs) (+ (nth inputs 0) (nth inputs 1)))}))
+
+(define
+  po-job
+  (artdag/build
+    (list
+      (list "s" "src" (list) {})
+      (list "b" "blur" (list "s") {:radius 2})
+      (list "c" "blur" (list "s") {:radius 3})
+      (list "out" "over" (list "b" "c") {} true))))
+(define po-out-id (artdag/dag-id po-job "out"))
+(define po-post (artdag/job->post-object po-job "out"))
+
+(artdag-test
+  "post: is a well-formed post object"
+  (artdag/post-object? po-post)
+  true)
+
+(artdag-test "post: type tag is artdag/job" (get po-post :type) "artdag/job")
+
+(artdag-test
+  "post: post id is the output node's content-id"
+  (artdag/post-object-id po-post)
+  po-out-id)
+
+(artdag-test
+  "post: payload is the whole dag (one record per node)"
+  (len (artdag/post-object-wire po-post))
+  (artdag/node-count po-job))
+
+(artdag-test
+  "post: verifies (ids intact, output present)"
+  (artdag/post-object-verify po-post)
+  true)
+
+; ---- round-trip: decode reconstructs the job by content-id ----
+
+(define po-job2 (artdag/post-object->job po-post))
+
+(artdag-test
+  "post: decoded job contains the output node by content-id"
+  (artdag/member? po-out-id (keys (artdag/dag-nodes po-job2)))
+  true)
+
+(artdag-test
+  "post: decoded job has the same node count"
+  (artdag/node-count po-job2)
+  (artdag/node-count po-job))
+
+; ---- string transport (feed activity / SXTP body) ----
+
+(define po-str (artdag/job->post-string po-job "out"))
+(define po-post2 (artdag/post-string->object po-str))
+
+(artdag-test
+  "post: survives string transport (id preserved)"
+  (artdag/post-object-id po-post2)
+  po-out-id)
+
+(artdag-test
+  "post: transported post still verifies"
+  (artdag/post-object-verify po-post2)
+  true)
+
+; ---- a peer runs the received post to the same result ----
+
+(define
+  po-local-result
+  (artdag/result-of (artdag/run po-job po-runner (persist/open)) po-out-id))
+(define po-peer-result (artdag/post-run po-post2 po-runner (persist/open)))
+
+(artdag-test
+  "post: peer runs the received job to the same result"
+  (= po-peer-result po-local-result)
+  true)
+
+; ---- tamper detection: mutate a param under a stale id ----
+
+(define
+  po-tampered
+  (assoc
+    po-post
+    :wire (map
+      (fn
+        (rec)
+        (if
+          (= (nth rec 1) "blur")
+          (list
+            (nth rec 0)
+            (nth rec 1)
+            (nth rec 2)
+            {:radius 99}
+            (nth rec 4))
+          rec))
+      (artdag/post-object-wire po-post))))
+
+(artdag-test
+  "post: tampered payload fails verification"
+  (artdag/post-object-verify po-tampered)
+  false)
+
+; ---- an id not produced by the job fails verification ----
+
+(artdag-test
+  "post: post id absent from payload fails verification"
+  (artdag/post-object-verify (assoc po-post :id "node:bogus"))
+  false)

lib/artdag/tests/schedule.sx

@@ -0,0 +1,127 @@
+; Phase 3/7 (optional) — relational scheduling on lib/minikanren CLP(FD).
+; Each node gets a slot var; edges impose fd-lt; fd-label searches. The ASAP solution
+; agrees with plan.sx's greedy Kahn waves; enumerating all solutions is the extra.
+
+; ---- linear chain a -> b -> c: exactly one minimal schedule ----
+
+(define
+  sc-chain
+  (artdag/build
+    (list
+      (list "a" "src" (list) {})
+      (list "b" "blur" (list "a") {:radius 1})
+      (list "c" "blur" (list "b") {:radius 2}))))
+(define sc-chain-a (artdag/dag-id sc-chain "a"))
+(define sc-chain-b (artdag/dag-id sc-chain "b"))
+(define sc-chain-c (artdag/dag-id sc-chain "c"))
+(define sc-chain-asap (artdag/schedule-asap sc-chain))
+
+(artdag-test "chain: ASAP schedule exists" (nil? sc-chain-asap) false)
+
+(artdag-test
+  "chain: slots are strictly increasing along the chain"
+  (list
+    (get sc-chain-asap sc-chain-a)
+    (get sc-chain-asap sc-chain-b)
+    (get sc-chain-asap sc-chain-c))
+  (list 1 2 3))
+
+(artdag-test
+  "chain: makespan equals chain length"
+  (artdag/schedule-makespan sc-chain-asap)
+  3)
+
+(artdag-test
+  "chain: exactly one schedule when slots = node count (no slack)"
+  (len (artdag/schedules sc-chain 3))
+  1)
+
+(artdag-test
+  "chain: ASAP batches are one node per slot"
+  (map len (artdag/schedule->batches sc-chain sc-chain-asap))
+  (list 1 1 1))
+
+(artdag-test
+  "chain: ASAP schedule is valid (deps respected)"
+  (artdag/schedule-valid? sc-chain sc-chain-asap)
+  true)
+
+; ---- diamond a -> b,c -> d: b and c are parallel ----
+
+(define
+  sc-dia
+  (artdag/build
+    (list
+      (list "a" "src" (list) {})
+      (list "b" "blur" (list "a") {:radius 1})
+      (list "c" "bright" (list "a") {:radius 1})
+      (list "d" "over" (list "b" "c") {} true))))
+(define sc-dia-asap (artdag/schedule-asap sc-dia))
+
+(artdag-test
+  "diamond: ASAP makespan is 3 (a | b,c | d)"
+  (artdag/schedule-makespan sc-dia-asap)
+  3)
+
+(artdag-test
+  "diamond: ASAP batch sizes are 1,2,1"
+  (map len (artdag/schedule->batches sc-dia sc-dia-asap))
+  (list 1 2 1))
+
+(artdag-test
+  "diamond: FD ASAP batches agree with plan.sx greedy waves"
+  (=
+    (artdag/schedule->batches sc-dia sc-dia-asap)
+    (map artdag/sort-strings (artdag/plan sc-dia 0)))
+  true)
+
+(artdag-test
+  "diamond: every enumerated schedule is valid"
+  (every?
+    (fn (asn) (artdag/schedule-valid? sc-dia asn))
+    (artdag/schedules sc-dia 4))
+  true)
+
+(artdag-test
+  "diamond: b and c share a slot in the ASAP schedule"
+  (=
+    (get sc-dia-asap (artdag/dag-id sc-dia "b"))
+    (get sc-dia-asap (artdag/dag-id sc-dia "c")))
+  true)
+
+; ---- parallelism cap: filter schedules to <= cap nodes per slot ----
+
+(artdag-test
+  "cap 1: the ASAP (b,c parallel) schedule is excluded, serial ones remain"
+  (every?
+    (fn
+      (asn)
+      (every?
+        (fn (b) (<= (len b) 1))
+        (artdag/schedule->batches sc-dia asn)))
+    (artdag/schedules-capped sc-dia 4 1))
+  true)
+
+(artdag-test
+  "cap 1: at least one serial schedule exists within 4 slots"
+  (> (len (artdag/schedules-capped sc-dia 4 1)) 0)
+  true)
+
+(artdag-test
+  "cap 2: admits the parallel ASAP schedule"
+  (if
+    (some
+      (fn (shape) (= shape (list 1 2 1)))
+      (map
+        (fn (asn) (map len (artdag/schedule->batches sc-dia asn)))
+        (artdag/schedules-capped sc-dia 4 2)))
+    true
+    false)
+  true)
+
+; ---- unsatisfiable: too few slots for the chain ----
+
+(artdag-test
+  "chain: no schedule when slots < chain length"
+  (nil? (artdag/schedule sc-chain 2))
+  true)

lib/blogimport/README.md

@@ -0,0 +1,61 @@
+# lib/blogimport — blog Postgres → persist genesis-import + parity verifier
+
+Implements **`plans/migration/data-migration.md`** (the "long-pole nobody had
+started") and the at-rest half of **`slice-01-blog.md` §4** — the data layer of the
+blog read-path migration. Host-ops migration tooling, **not** a domain core: it
+composes the public APIs of content-on-sx (`lib/content`) and persist
+(`lib/persist`). Kept in its own module (not `lib/host`, not `lib/content`) so it
+doesn't collide with the loops that own those.
+
+Status: **machinery complete + live-source wired, 75/75 conformance**
+(lexical 23, import 21, verify 11, source 20).
+
+## What it does
+
+| Module | Role |
+|---|---|
+| `lexical.sx` | `blogimport/lex-blocks doc` — Ghost **lexical** body (as SX dicts) → content-on-sx **block list**, ids deterministic by position (`b0,b1,…`). |
+| `import.sx` | `blogimport/import-post! b post at` — genesis import: convert the post's lexical, commit blocks as ordered `op-insert`s into the `content:<id>` op-log stream, record metadata in a sibling `postmeta:<id>` stream. Idempotent (skip-if-exists). `import-all!` → coverage scoreboard. |
+| `verify.sx` | `blogimport/verify-post b post` — replay the stream → block model, diff vs the row-derived oracle with `=`. `verify-all` → `{:total :ok :mismatched}` coverage. |
+| `source.sx` | **Live source (Q-M4 = internal-data query).** Injected `fetch-fn` transport port; `parse-row` maps a service post-row → importer `post` dict and parses the `:lexical` JSON string (`dream-json-parse`). `backfill! b fetch-fn at` = enumerate → fetch → import; `sync-verify b fetch-fn` = enumerate → fetch → verify. `backfill-ids!` is the explicit-id fallback. |
+
+## What is proven
+
+The verifier holds **`lexical → import → persist → replay → block-model`** equal to
+**`lexical → block-model`** computed directly. I.e. **the genesis import + op-log
+replay is lossless** — "did the backfill corrupt anything" at rest
+(`data-migration.md` §6). The `verify.sx` corruption test confirms a diverging stream
+is *detected*, not silently passed.
+
+## Known limitations / TODO (carry into the plan)
+
+- **Inline formatting is flattened to plain text.** Architecture's content model holds
+  plain-string text (`mk-text id text`); Phase-5 rich inline runs are not merged here.
+  The single swap-point is `lex-inline-text` in `lexical.sx` — return runs there once
+  content-on-sx Phase 5 lands on `architecture`. Bold/italic/links currently collapse
+  to their plain concatenation (drift-proof, == `asText`). (slice-01-blog Q-B1.)
+- **Q-M4 RESOLVED — live source = internal-data query** (`source.sx`), via an injected
+  `fetch-fn` port. The remaining real-world wiring is operational, not design:
+  1. **One blog-side query must be added**: `blog/queries.sx` has fetch-by-id/slug/ids
+     but **no enumeration query**. Add a `published-posts` defquery returning the
+     published ids/slugs (Python `list_posts(status="published")`,
+     `blog/bp/blog/ghost_db.py:102`). Until then, drive `backfill-ids!` with an explicit
+     id list. `source.sx` is mocked against this contract in `tests/source.sx`.
+  2. **Production `fetch-fn`** = the host's HMAC-signed `fetch_data` wrapper
+     (`GET /internal/data/{query}`). That wiring lives in `lib/host` (the host loop's
+     territory); `source.sx` only needs the port injected.
+  3. **Confirm the response field names** of the live `get-post-by-*` data handler
+     against `parse-row`'s contract (`:uuid|:id :slug :title :status :visibility :tags
+     :authors :lexical`); a mismatch is a one-line field fix.
+- **Oracle is the lexical→blocks of the SAME post, not the live Python block model.**
+  This proves round-trip fidelity through persist (no corruption at rest). The "does SX
+  match the *Python render*" half of Q-D2 would additionally diff against the Python
+  side's own block derivation — deferred with the read-path cutover.
+- **Re-import with an improved converter (Q-M5)** is import-once today (skip-if-exists).
+  Superseding prior genesis events (vs truncate+re-import) is future work.
+
+## Run
+
+```bash
+bash lib/blogimport/conformance.sh     # 75/75; writes scoreboard.{json,md}
+```

lib/blogimport/conformance.sh

@@ -0,0 +1,121 @@
+#!/usr/bin/env bash
+# lib/blogimport/conformance.sh — run blog-import suites, emit scoreboard.
+# Mirrors lib/content/conformance.sh: epoch-loaded modules + a bi-test counter.
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
+if [ ! -x "$SX_SERVER" ]; then
+  MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
+  if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
+    SX_SERVER="$MAIN_ROOT/$SX_SERVER"
+  else
+    echo "ERROR: sx_server.exe not found." >&2
+    exit 1
+  fi
+fi
+
+SUITES=(lexical import verify source)
+
+OUT_JSON="lib/blogimport/scoreboard.json"
+OUT_MD="lib/blogimport/scoreboard.md"
+
+run_suite() {
+  local suite=$1
+  local file="lib/blogimport/tests/${suite}.sx"
+  [ -f "$file" ] || { echo "0 0"; return; }
+  local TMP
+  TMP=$(mktemp)
+  cat > "$TMP" << EPOCHS
+(epoch 1)
+(load "lib/smalltalk/tokenizer.sx")
+(load "lib/smalltalk/parser.sx")
+(load "lib/guest/reflective/class-chain.sx")
+(load "lib/smalltalk/runtime.sx")
+(load "lib/guest/reflective/env.sx")
+(load "lib/smalltalk/eval.sx")
+(load "lib/persist/event.sx")
+(load "lib/persist/backend.sx")
+(load "lib/persist/log.sx")
+(load "lib/persist/kv.sx")
+(load "lib/persist/api.sx")
+(load "lib/content/block.sx")
+(load "lib/content/doc.sx")
+(load "lib/content/render.sx")
+(load "lib/content/api.sx")
+(load "lib/content/meta.sx")
+(load "lib/content/section.sx")
+(load "lib/content/callout.sx")
+(load "lib/content/media.sx")
+(load "lib/content/store.sx")
+(load "lib/dream/json.sx")
+(load "lib/blogimport/lexical.sx")
+(load "lib/blogimport/import.sx")
+(load "lib/blogimport/verify.sx")
+(load "lib/blogimport/source.sx")
+(epoch 2)
+(eval "(define bi-test-pass 0)")
+(eval "(define bi-test-fail 0)")
+(eval "(define bi-test-fails (list))")
+(eval "(define bi-test (fn (name got expected) (if (= got expected) (set! bi-test-pass (+ bi-test-pass 1)) (begin (set! bi-test-fail (+ bi-test-fail 1)) (set! bi-test-fails (cons name bi-test-fails))))))")
+(epoch 3)
+(load "${file}")
+(epoch 4)
+(eval "(list bi-test-pass bi-test-fail)")
+EPOCHS
+
+  local OUTPUT
+  OUTPUT=$(timeout 240 "$SX_SERVER" < "$TMP" 2>/dev/null)
+  rm -f "$TMP"
+
+  local LINE
+  LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
+  if [ -z "$LINE" ]; then
+    LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
+            | sed -E 's/^\(ok 4 //; s/\)$//')
+  fi
+
+  local P F
+  P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
+  F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
+  echo "${P:-0} ${F:-0}"
+}
+
+declare -A SUITE_PASS SUITE_FAIL
+TOTAL_PASS=0
+TOTAL_FAIL=0
+
+echo "Running blogimport conformance suite..." >&2
+for s in "${SUITES[@]}"; do
+  read -r p f < <(run_suite "$s")
+  SUITE_PASS[$s]=$p
+  SUITE_FAIL[$s]=$f
+  TOTAL_PASS=$((TOTAL_PASS + p))
+  TOTAL_FAIL=$((TOTAL_FAIL + f))
+  printf "  %-10s %d/%d\n" "$s" "$p" "$((p+f))" >&2
+done
+
+{
+  printf '{\n  "suites": {\n'
+  first=1
+  for s in "${SUITES[@]}"; do
+    if [ $first -eq 0 ]; then printf ',\n'; fi
+    printf '    "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
+    first=0
+  done
+  printf '\n  },\n  "total_pass": %d,\n  "total_fail": %d,\n  "total": %d\n}\n' \
+    "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
+} > "$OUT_JSON"
+
+{
+  printf '# blogimport Conformance Scoreboard\n\n_Generated by `lib/blogimport/conformance.sh`_\n\n'
+  printf '| Suite | Pass | Fail | Total |\n|-------|-----:|-----:|------:|\n'
+  for s in "${SUITES[@]}"; do
+    printf '| %s | %d | %d | %d |\n' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}" "$(( ${SUITE_PASS[$s]} + ${SUITE_FAIL[$s]} ))"
+  done
+  printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
+} > "$OUT_MD"
+
+echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
+[ "$TOTAL_FAIL" -eq 0 ]

lib/blogimport/drafts/README.md

@@ -0,0 +1,88 @@
+# Blog-side draft — the `published-posts` migration query
+
+The one blog-app change needed to make `lib/blogimport`'s live source (Q-M4) real.
+Two parts: an SX **defquery** (`published-posts.sx` in this dir) and a Python
+**provider** it binds to. Both go in the **blog app** (production `blog/` tree); they
+are drafted here so the importer ships with its dependency spelled out. Apply on the
+blog app's branch, not on this migration branch.
+
+## Why a new query (not reuse post-by-id)
+
+`blogimport/source.sx` needs, for every published post: `id, slug, title, status,
+visibility, tags, authors, lexical`. The existing providers
+(`blog/services/__init__.py` `SqlBlogService.get_post_by_*`) return a `PostDTO` whose
+`_post_to_dto` exposes `sx_content`/`html` but **not `lexical`** — and the canonical
+migration path is lexical→blocks (slice-01-blog Q-B1), not sx_content. So a dedicated
+migration provider that returns full rows including the raw lexical body is the
+minimal, honest change. One batch call covers both enumeration (Q-D2 corpus) and
+bodies.
+
+## 1. defquery (→ `blog/queries.sx`)
+
+See `published-posts.sx` in this directory:
+
+```lisp
+(defquery published-posts ()
+  "Enumerate every published, non-page blog post as a full row INCLUDING the raw
+   lexical body — the SX migration corpus (Q-D2). Read-only ..."
+  (service "blog" "list-published-posts"))
+```
+
+Kebab→snake convention (as for `get-post-by-slug` → `get_post_by_slug`) binds
+`"list-published-posts"` to the `SqlBlogService.list_published_posts` method below.
+
+## 2. Python provider (→ `blog/services/__init__.py`, in `SqlBlogService`)
+
+```python
+from sqlalchemy.orm import selectinload  # add to imports
+
+    async def list_published_posts(self, session: AsyncSession) -> list[dict]:
+        """Migration corpus: every published, non-page post as a full row INCLUDING
+        the raw lexical body (Q-D2). Read-only; consumed by the SX blogimport
+        backfill/verify. Mirrors ghost_db.list_posts() base visibility filters."""
+        result = await session.execute(
+            select(Post)
+            .where(
+                Post.deleted_at.is_(None),
+                Post.status == "published",
+                Post.is_page.is_(False),
+            )
+            .options(selectinload(Post.tags), selectinload(Post.authors))
+            .order_by(Post.published_at.desc().nullslast())
+        )
+        return [
+            {
+                "id": p.id,
+                "uuid": p.uuid,
+                "slug": p.slug,
+                "title": p.title,
+                "status": p.status,
+                "visibility": p.visibility,
+                "lexical": p.lexical,
+                "tags": [t.slug for t in p.tags],
+                "authors": [a.slug for a in p.authors],
+            }
+            for p in result.scalars().unique().all()
+        ]
+```
+
+**Confirm before applying:**
+- The relationship names on `Post` (`tags`, `authors`) — check `blog/models/content.py`
+  join tables (`post_tags`, `post_authors`); adjust `selectinload` + the comprehensions
+  if they differ. `.unique()` is needed because the eager joins fan out rows.
+- `Post.uuid` and `Post.lexical` columns exist (`models/content.py` ~lines 61-63).
+- Visibility filters match `ghost_db.list_posts()` (drafts excluded, pages excluded) so
+  the corpus is exactly the published read-path set.
+
+## 3. Verify the contract
+
+After applying, the response shape must match `blogimport/parse-row`
+(`lib/blogimport/source.sx`): keys `:uuid|:id :slug :title :status :visibility :tags
+:authors :lexical`, with `:lexical` a JSON string (parsed via `dream-json-parse`). The
+mock in `lib/blogimport/tests/source.sx` is the executable spec of this contract.
+
+## 4. Then wire the transport (host loop)
+
+`blogimport/backfill!`/`sync-verify` take an injected `fetch-fn`. In production that is
+the host's HMAC `fetch_data` wrapper (`GET /internal/data/published-posts`) — wiring
+that lives in `lib/host`, not here.

lib/blogimport/drafts/published-posts.sx

@@ -0,0 +1,16 @@
+; DRAFT — proposed addition to blog/queries.sx (the blog app's internal-data surface).
+; Resolves the one blog-side gap for Q-M4: blogimport needs to enumerate published
+; posts AND read their raw lexical bodies. The existing post-by-id/slug/ids queries
+; return a PostDTO that carries sx_content/html but NOT lexical, so a dedicated
+; migration query that returns full rows (incl. lexical) is the minimal change.
+;
+; Paste this defquery into blog/queries.sx alongside the others, and add the matching
+; `list_published_posts` provider to SqlBlogService (see drafts/README.md).
+;
+; This file is a DRAFT artifact (not loaded by anything); it is parse-validated only.
+
+(defquery published-posts ()
+  "Enumerate every published, non-page blog post as a full row INCLUDING the raw
+   lexical body — the SX migration corpus (Q-D2). Read-only; used by the blogimport
+   backfill + at-rest verify. Newest-first."
+  (service "blog" "list-published-posts"))

lib/blogimport/import.sx

@@ -0,0 +1,84 @@
+; lib/blogimport/import.sx
+; Genesis import: a blog Post row -> a persist content op-log stream.
+;
+; Per plans/migration/data-migration.md §3-5: for each Post, convert its lexical
+; body to content blocks and commit them as genesis insert ops into the
+; content:<id> stream, idempotently, with post metadata recorded as an event in a
+; sibling stream. The same code runs on mem and durable persist backends (every fn
+; takes the backend `b`, the acl.sx design principle).
+;
+; A `post` is a dict mirroring the blog Post row:
+;   {:id "uuid" :slug "hello" :title "Hello" :status "published"
+;    :visibility "public" :tags (list "a") :authors (list "u1")
+;    :lexical <lexical-doc-as-sx-dict>}
+; Reading real rows (internal-data query vs direct Postgres, Q-M4) is the live-source
+; edge, out of scope here; this drives content/commit! given a `post` dict.
+
+; --- genesis ops: insert each block in document order (deterministic) -----------
+; first block after nil (prepend), each subsequent after the previous block's id,
+; reproducing source order so re-import yields the same sequence (data-migration §5).
+(define
+  blogimport/genesis-ops
+  (fn (blocks)
+    (let ((ids (map blk-id blocks)))
+      (map-indexed
+        (fn (i blk) (op-insert blk (if (= i 0) nil (nth ids (- i 1)))))
+        blocks))))
+
+; --- post metadata (title/slug/status/visibility/tags/authors) ------------------
+(define
+  blogimport/post-meta
+  (fn (post)
+    {:title (or (get post :title) "")
+     :slug (or (get post :slug) "")
+     :status (or (get post :status) "")
+     :visibility (or (get post :visibility) "")
+     :tags (or (get post :tags) (list))
+     :authors (or (get post :authors) (list))}))
+
+; metadata is not a content op, so it rides a sibling event stream postmeta:<id>;
+; latest event wins (LWW). Replayable + durable like the block op-log.
+(define blogimport/meta-stream (fn (id) (str "postmeta:" id)))
+
+(define
+  blogimport/commit-meta!
+  (fn (b id meta at)
+    (persist/append b (blogimport/meta-stream id) "post-meta" at meta)))
+
+(define
+  blogimport/load-meta
+  (fn (b id)
+    (let ((evs (persist/read b (blogimport/meta-stream id))))
+      (if (= (len evs) 0) nil (persist/event-data (nth evs (- (len evs) 1)))))))
+
+; --- idempotency: a stream already holding events is already imported -----------
+; (host-persist guarantees monotonic seq but NOT dedupe — skip-if-exists is the
+; importer's dedupe, so re-running the backfill never double-imports. data-migration
+; §5.) Re-import with an improved converter (Q-M5) is future work — superseding,
+; not duplicating; this build is import-once.
+(define
+  blogimport/imported?
+  (fn (b id) (> (content/version-count b id) 0)))
+
+; --- import one post ------------------------------------------------------------
+(define
+  blogimport/import-post!
+  (fn (b post at)
+    (let ((id (get post :id)))
+      (if
+        (blogimport/imported? b id)
+        {:id id :imported false :reason "exists"}
+        (let ((blocks (blogimport/lex-blocks (get post :lexical))))
+          (begin
+            (content/commit-all! b id (blogimport/genesis-ops blocks) at)
+            (blogimport/commit-meta! b id (blogimport/post-meta post) at)
+            {:id id :imported true :blocks (len blocks)}))))))
+
+; --- import many: coverage scoreboard -------------------------------------------
+(define
+  blogimport/import-all!
+  (fn (b posts at)
+    (let ((results (map (fn (p) (blogimport/import-post! b p at)) posts)))
+      {:total (len results)
+       :imported (len (filter (fn (r) (get r :imported)) results))
+       :skipped (len (filter (fn (r) (not (get r :imported))) results))})))

lib/blogimport/lexical.sx

@@ -0,0 +1,129 @@
+; lib/blogimport/lexical.sx
+; Lexical (Ghost editor JSON, as SX dicts) -> content-on-sx block list.
+;
+; The blog migration's lexical->blocks converter. Lives on the blog/migration
+; side (NOT lib/content, NOT lib/host) per plans/migration/data-migration.md §7.
+;
+; Input shape: a lexical document is an SX dict mirroring the JSON 1:1, e.g.
+;   {:root {:children (list
+;      {:type "heading" :tag "h2" :children (list {:type "text" :text "Hi"})}
+;      {:type "paragraph" :children (list
+;          {:type "text" :text "plain "}
+;          {:type "text" :text "bold" :format 1}
+;          {:type "link" :url "/x" :children (list {:type "text" :text "here"})})})}}
+;
+; Block ids are assigned deterministically by top-level position ("b0","b1",...)
+; so a re-import yields the SAME block sequence (data-migration.md §5 ordering rule).
+;
+; INLINE FORMATTING: architecture's content model holds PLAIN-STRING text
+; (mk-text id text). Phase-5 rich inline runs are not merged here yet, so inline
+; nodes are flattened to their plain concatenation (== asText, drift-proof). The
+; single swap-point for the runs upgrade is `lex-inline-text` below — when
+; content-on-sx Phase 5 lands on architecture, return runs there instead of a
+; string. (slice-01-blog.md Q-B1; "prove the machinery first, then swap".)
+
+; Inline format bitmask (lexical): bold=1 italic=2 strikethrough=4 underline=8
+; code=16 subscript=32 superscript=64. Decoding the bitmask into mark keywords is
+; deferred to the Phase-5 runs upgrade (no bitwise prim on architecture, and the
+; active path flattens to plain text anyway). The :format field is read at the
+; swap-point `lex-inline-text` when runs land.
+
+; --- inline node -> plain text --------------------------------------------------
+(define
+  lex-inline-node-text
+  (fn (node)
+    (let ((t (get node :type)))
+      (cond
+        ((equal? t "text") (or (get node :text) ""))
+        ((equal? t "linebreak") "\n")
+        ((equal? t "tab") "\t")
+        ((equal? t "link") (lex-inline-text (or (get node :children) (list))))
+        ((equal? t "autolink") (lex-inline-text (or (get node :children) (list))))
+        ((equal? t "at-link") (lex-inline-text (or (get node :children) (list))))
+        ((equal? t "code-highlight") (or (get node :text) ""))
+        (else "")))))
+
+; flatten a list of inline nodes to one plain string.
+; *** Phase-5 swap-point: return a runs list here once mk-text accepts runs. ***
+(define
+  lex-inline-text
+  (fn (children)
+    (reduce
+      (fn (acc n) (str acc (lex-inline-node-text n)))
+      ""
+      children)))
+
+; --- helpers --------------------------------------------------------------------
+(define
+  lex-heading-level
+  (fn (tag)
+    (cond
+      ((equal? tag "h1") 1)
+      ((equal? tag "h2") 2)
+      ((equal? tag "h3") 3)
+      ((equal? tag "h4") 4)
+      ((equal? tag "h5") 5)
+      ((equal? tag "h6") 6)
+      (else 2))))
+
+(define
+  lex-listitem-text
+  (fn (item)
+    (lex-inline-text (or (get item :children) (list)))))
+
+; --- one lexical block node -> a content block (id assigned by caller) ----------
+(define
+  lex-block
+  (fn (node id)
+    (let ((t (get node :type)))
+      (cond
+        ((equal? t "paragraph")
+          (mk-text id (lex-inline-text (or (get node :children) (list)))))
+        ((equal? t "extended-text")
+          (mk-text id (lex-inline-text (or (get node :children) (list)))))
+        ((equal? t "heading")
+          (mk-heading id (lex-heading-level (get node :tag))
+            (lex-inline-text (or (get node :children) (list)))))
+        ((equal? t "extended-heading")
+          (mk-heading id (lex-heading-level (get node :tag))
+            (lex-inline-text (or (get node :children) (list)))))
+        ((equal? t "quote")
+          (mk-quote id "" (lex-inline-text (or (get node :children) (list)))))
+        ((equal? t "extended-quote")
+          (mk-quote id "" (lex-inline-text (or (get node :children) (list)))))
+        ((equal? t "codeblock")
+          (mk-code id (or (get node :language) "") (or (get node :code) "")))
+        ((equal? t "list")
+          (mk-list id
+            (equal? (get node :listType) "number")
+            (map lex-listitem-text (or (get node :children) (list)))))
+        ((equal? t "horizontalrule") (mk-divider id))
+        ((equal? t "image")
+          (mk-image id (or (get node :src) "") (or (get node :alt) "")))
+        ((equal? t "callout")
+          (mk-callout id (or (get node :backgroundColor) "grey")
+            (lex-inline-text (or (get node :children) (list)))))
+        ((equal? t "video") (mk-media id "video" (or (get node :src) "")))
+        ((equal? t "audio") (mk-media id "audio" (or (get node :src) "")))
+        ((equal? t "embed") (mk-embed id (or (get node :url) "") "embed"))
+        ((equal? t "bookmark") (mk-embed id (or (get node :url) "") "bookmark"))
+        ; unknown/unsupported card: route to a generic embed tagged by type so
+        ; nothing is silently dropped (provider records the original node type).
+        (else (mk-embed id "" (or t "unknown")))))))
+
+; --- doc -> top-level children list ---------------------------------------------
+(define
+  lex-doc-children
+  (fn (doc)
+    (cond
+      ((not (equal? (get doc :root) nil)) (or (get (get doc :root) :children) (list)))
+      ((not (equal? (get doc :children) nil)) (get doc :children))
+      (else (list)))))
+
+; --- doc -> content block list (deterministic ids by position) ------------------
+(define
+  blogimport/lex-blocks
+  (fn (doc)
+    (map-indexed
+      (fn (i node) (lex-block node (str "b" i)))
+      (lex-doc-children doc))))

lib/blogimport/scoreboard.json

@@ -0,0 +1,11 @@
+{
+  "suites": {
+    "lexical": {"pass": 23, "fail": 0},
+    "import": {"pass": 21, "fail": 0},
+    "verify": {"pass": 11, "fail": 0},
+    "source": {"pass": 21, "fail": 0}
+  },
+  "total_pass": 76,
+  "total_fail": 0,
+  "total": 76
+}

lib/blogimport/scoreboard.md

@@ -0,0 +1,11 @@
+# blogimport Conformance Scoreboard
+
+_Generated by `lib/blogimport/conformance.sh`_
+
+| Suite | Pass | Fail | Total |
+|-------|-----:|-----:|------:|
+| lexical | 23 | 0 | 23 |
+| import | 21 | 0 | 21 |
+| verify | 11 | 0 | 11 |
+| source | 21 | 0 | 21 |
+| **Total** | **76** | **0** | **76** |

lib/blogimport/source.sx

@@ -0,0 +1,84 @@
+; lib/blogimport/source.sx
+; Live source adapter — Q-M4 RESOLVED: import via the blog INTERNAL-DATA QUERY
+; surface (decoupled), not direct Postgres. Reuses the existing query contracts
+; (blog/queries.sx: post-by-id/post-by-slug/posts-by-ids) and keeps the importer in
+; the SX/host world (plans/migration/data-migration.md §7 recommended default).
+;
+; TRANSPORT SEAM (hexagonal, like every other subsystem): a `fetch-fn` port is
+; INJECTED. Contract:
+;     (fetch-fn query-name params-dict) -> response-data
+; In production `fetch-fn` is the host's HMAC-signed fetch_data wrapper
+; (GET /internal/data/{query}); in tests it's a mock. The importer never knows how
+; the bytes arrive.
+;
+; RESPONSE CONTRACT (one published-post row), the blog `get-post-by-*` data handler:
+;   {:uuid|:id  :slug :title :status :visibility :tags :authors :lexical}
+;   :lexical is the Ghost body as a JSON STRING (the Post.lexical DB column) — parsed
+;   here with dream-json-parse into the SX dict shape blogimport/lex-blocks expects.
+;   (If a handler returns :lexical already-structured, it is used as-is.)
+;
+; REQUIRED BLOG-SIDE ADDITION (the one gap — draft in drafts/published-posts.sx):
+; the migration needs a `published-posts` query that returns full published-post ROWS
+; INCLUDING the raw `:lexical` body. The existing post-by-id/slug providers return a
+; PostDTO that carries sx_content/html but NOT lexical (blog/services/__init__.py
+; _post_to_dto), so they cannot feed the canonical lexical->blocks converter. One new
+; provider (Python list_published_posts over list_posts(status="published"),
+; blog/bp/blog/ghost_db.py:102) covers both enumeration AND bodies in one batch call.
+; Mocked here against that contract; see drafts/ for the paste-ready blog-side change.
+
+(define blogimport/dep-json-parse dream-json-parse)
+
+; --- lexical field -> SX dict (string from DB column, or already structured) -----
+(define
+  blogimport/parse-lexical
+  (fn (lx)
+    (cond
+      ((equal? lx nil) {:root {:children (list)}})
+      ((string? lx) (blogimport/dep-json-parse lx))
+      (else lx))))
+
+; --- service post-row -> importer `post` dict -----------------------------------
+(define
+  blogimport/parse-row
+  (fn (row)
+    {:id (or (get row :uuid) (get row :id))
+     :slug (or (get row :slug) "")
+     :title (or (get row :title) "")
+     :status (or (get row :status) "")
+     :visibility (or (get row :visibility) "")
+     :tags (or (get row :tags) (list))
+     :authors (or (get row :authors) (list))
+     :lexical (blogimport/parse-lexical (get row :lexical))}))
+
+; --- the published-post rows from the live source (one batch query) -------------
+(define
+  blogimport/source-rows
+  (fn (fetch-fn) (fetch-fn "published-posts" {})))
+
+; --- all published posts as importer `post` dicts -------------------------------
+(define
+  blogimport/source-posts
+  (fn (fetch-fn) (map blogimport/parse-row (blogimport/source-rows fetch-fn))))
+
+; --- end-to-end drivers ---------------------------------------------------------
+; backfill = enumerate+fetch -> genesis-import (idempotent). Re-runnable as the
+; one-way DB->persist sync (data-migration.md Strategy 1).
+(define
+  blogimport/backfill!
+  (fn (b fetch-fn at)
+    (blogimport/import-all! b (blogimport/source-posts fetch-fn) at)))
+
+; partial backfill: client-side filter to a subset of ids (no extra blog query).
+(define
+  blogimport/backfill-ids!
+  (fn (b fetch-fn ids at)
+    (blogimport/import-all!
+      b
+      (filter (fn (p) (contains? ids (get p :id))) (blogimport/source-posts fetch-fn))
+      at)))
+
+; sync-verify = fetch -> shadow-diff the persisted streams at rest.
+(define
+  blogimport/sync-verify
+  (fn (b fetch-fn)
+    (blogimport/verify-all b (blogimport/source-posts fetch-fn))))

lib/blogimport/tests/import.sx

@@ -0,0 +1,62 @@
+; lib/blogimport/tests/import.sx — genesis import + idempotency
+(st-bootstrap-classes!)
+(content-bootstrap-blocks!)
+(content-bootstrap-doc!)
+(content-bootstrap-callout!)
+(content-bootstrap-media!)
+
+(define
+  p1
+  {:id "post-1" :slug "hello" :title "Hello" :status "published"
+   :visibility "public" :tags (list "news") :authors (list "u1")
+   :lexical {:root {:children (list
+     {:type "heading" :tag "h1" :children (list {:type "text" :text "Hello"})}
+     {:type "paragraph" :children (list {:type "text" :text "world"})})}}})
+
+(define
+  p2
+  {:id "post-2" :slug "two" :title "Two" :status "published"
+   :lexical {:children (list
+     {:type "paragraph" :children (list {:type "text" :text "second"})})}})
+
+; ---- genesis-ops ordering ----
+(define ops1 (blogimport/genesis-ops (blogimport/lex-blocks (get p1 :lexical))))
+(bi-test "genesis op kinds" (map (fn (o) (get o :op)) ops1) (list "insert" "insert"))
+(bi-test "genesis first after nil" (get (nth ops1 0) :after) nil)
+(bi-test "genesis second after first id" (get (nth ops1 1) :after) "b0")
+
+; ---- import one ----
+(define B (persist/open))
+(define r1 (blogimport/import-post! B p1 10))
+(bi-test "import imported flag" (get r1 :imported) true)
+(bi-test "import block count" (get r1 :blocks) 2)
+(bi-test "stream version-count" (content/version-count B "post-1") 2)
+(bi-test "head ids" (doc-ids (content/head B "post-1")) (list "b0" "b1"))
+(bi-test "head body text"
+  (str (blk-send (doc-find (content/head B "post-1") "b1") "text")) "world")
+(bi-test "head heading level"
+  (blk-send (doc-find (content/head B "post-1") "b0") "level") 1)
+
+; ---- metadata round-trip ----
+(bi-test "meta round-trip" (blogimport/load-meta B "post-1") (blogimport/post-meta p1))
+(bi-test "meta title" (get (blogimport/load-meta B "post-1") :title) "Hello")
+(bi-test "meta tags" (get (blogimport/load-meta B "post-1") :tags) (list "news"))
+
+; ---- idempotent re-import (skip-if-exists, no duplication) ----
+(define r1b (blogimport/import-post! B p1 99))
+(bi-test "reimport skipped" (get r1b :imported) false)
+(bi-test "reimport reason" (get r1b :reason) "exists")
+(bi-test "version-count unchanged after reimport" (content/version-count B "post-1") 2)
+(bi-test "head ids unchanged after reimport"
+  (doc-ids (content/head B "post-1")) (list "b0" "b1"))
+
+; ---- import-all! coverage scoreboard ----
+(define B2 (persist/open))
+(define cov1 (blogimport/import-all! B2 (list p1 p2) 5))
+(bi-test "import-all total" (get cov1 :total) 2)
+(bi-test "import-all imported" (get cov1 :imported) 2)
+(bi-test "import-all skipped" (get cov1 :skipped) 0)
+; re-run is fully idempotent
+(define cov2 (blogimport/import-all! B2 (list p1 p2) 6))
+(bi-test "import-all rerun imported" (get cov2 :imported) 0)
+(bi-test "import-all rerun skipped" (get cov2 :skipped) 2)

lib/blogimport/tests/lexical.sx

@@ -0,0 +1,92 @@
+; lib/blogimport/tests/lexical.sx — lexical -> content block converter
+(st-bootstrap-classes!)
+(content-bootstrap-blocks!)
+(content-bootstrap-doc!)
+(content-bootstrap-callout!)
+(content-bootstrap-media!)
+
+; ---- a representative lexical document (Ghost editor JSON, as SX dicts) ----
+(define
+  doc
+  {:root {:children (list
+    {:type "heading" :tag "h2" :children (list {:type "text" :text "Title"})}
+    {:type "paragraph" :children (list
+      {:type "text" :text "plain "}
+      {:type "text" :text "bold" :format 1}
+      {:type "text" :text " then "}
+      {:type "link" :url "/x" :children (list {:type "text" :text "a link"})})}
+    {:type "quote" :children (list {:type "text" :text "wise words"})}
+    {:type "list" :listType "number" :children (list
+      {:type "listitem" :children (list {:type "text" :text "one"})}
+      {:type "listitem" :children (list {:type "text" :text "two"})})}
+    {:type "codeblock" :language "python" :code "print(1)"}
+    {:type "horizontalrule"}
+    {:type "image" :src "/c.png" :alt "a cat"}
+    {:type "callout" :backgroundColor "blue" :children (list {:type "text" :text "note!"})}
+    {:type "twitter" :url "https://t/x"})}})
+
+(define blocks (blogimport/lex-blocks doc))
+
+; ---- structure ----
+(bi-test "block count" (len blocks) 9)
+(bi-test "ids by position" (map blk-id blocks)
+  (list "b0" "b1" "b2" "b3" "b4" "b5" "b6" "b7" "b8"))
+(bi-test "types in order" (map blk-type blocks)
+  (list "heading" "text" "quote" "list" "code" "divider" "image" "callout" "embed"))
+
+; ---- heading ----
+(bi-test "heading level" (blk-send (nth blocks 0) "level") 2)
+(bi-test "heading text" (str (blk-send (nth blocks 0) "text")) "Title")
+
+; ---- paragraph with inline bold + link, flattened to plain concatenation ----
+(bi-test "paragraph flattened text"
+  (str (blk-send (nth blocks 1) "text")) "plain bold then a link")
+
+; ---- quote ----
+(bi-test "quote text" (str (blk-send (nth blocks 2) "text")) "wise words")
+
+; ---- ordered list with items ----
+(bi-test "list ordered" (blk-send (nth blocks 3) "ordered") true)
+(bi-test "list items" (blk-send (nth blocks 3) "items") (list "one" "two"))
+
+; ---- code block ----
+(bi-test "code language" (str (blk-send (nth blocks 4) "language")) "python")
+(bi-test "code text" (str (blk-send (nth blocks 4) "text")) "print(1)")
+
+; ---- image ----
+(bi-test "image src" (str (blk-send (nth blocks 6) "src")) "/c.png")
+(bi-test "image alt" (str (blk-send (nth blocks 6) "alt")) "a cat")
+
+; ---- callout ----
+(bi-test "callout kind" (str (blk-send (nth blocks 7) "kind")) "blue")
+(bi-test "callout text" (str (blk-send (nth blocks 7) "text")) "note!")
+
+; ---- unknown card routed to embed, provider records original type ----
+(bi-test "unknown -> embed provider" (str (blk-send (nth blocks 8) "provider")) "twitter")
+
+; ---- heading level mapping ----
+(bi-test "h1 level" (lex-heading-level "h1") 1)
+(bi-test "h4 level" (lex-heading-level "h4") 4)
+(bi-test "unknown tag default" (lex-heading-level "hx") 2)
+
+; ---- bullet list ----
+(define
+  bdoc
+  {:children (list {:type "list" :listType "bullet" :children (list
+    {:type "listitem" :children (list {:type "text" :text "x"})})})})
+(bi-test "bullet not ordered" (blk-send (nth (blogimport/lex-blocks bdoc) 0) "ordered") false)
+
+; ---- empty doc ----
+(bi-test "empty doc -> no blocks" (len (blogimport/lex-blocks {:root {:children (list)}})) 0)
+
+; ---- bare-children doc (no :root wrapper) ----
+(bi-test "bare children doc"
+  (map blk-type (blogimport/lex-blocks {:children (list {:type "paragraph" :children (list {:type "text" :text "hi"})})}))
+  (list "text"))
+
+; ---- linebreak/tab in inline flattening ----
+(bi-test "linebreak flatten"
+  (str (blk-send (nth (blogimport/lex-blocks
+    {:children (list {:type "paragraph" :children (list
+      {:type "text" :text "a"} {:type "linebreak"} {:type "text" :text "b"})})}) 0) "text"))
+  "a\nb")

lib/blogimport/tests/source.sx

@@ -0,0 +1,80 @@
+; lib/blogimport/tests/source.sx — live-source adapter (Q-M4 internal-data query)
+(st-bootstrap-classes!)
+(content-bootstrap-blocks!)
+(content-bootstrap-doc!)
+(content-bootstrap-callout!)
+(content-bootstrap-media!)
+
+; ---- canned service rows (lexical arrives as a JSON STRING, the DB column) ----
+(define
+  lex1
+  "{\"root\":{\"children\":[{\"type\":\"heading\",\"tag\":\"h2\",\"children\":[{\"type\":\"text\",\"text\":\"Live\"}]},{\"type\":\"paragraph\",\"children\":[{\"type\":\"text\",\"text\":\"from db\"}]}]}}")
+(define
+  row1
+  {:uuid "post-1" :slug "live" :title "Live" :status "published"
+   :visibility "public" :tags (list "x") :authors (list "u") :lexical lex1})
+(define
+  row2
+  {:uuid "post-2" :slug "two" :title "Two" :status "published"
+   :lexical "{\"children\":[{\"type\":\"paragraph\",\"children\":[{\"type\":\"text\",\"text\":\"second\"}]}]}"})
+
+; ---- mock transport: (fetch-fn query params) -> response ----
+; the `published-posts` migration query returns full rows (incl. lexical) in one batch.
+(define
+  mock-fetch
+  (fn (query params)
+    (cond
+      ((equal? query "published-posts") (list row1 row2))
+      (else nil))))
+
+; ---- parse-row maps fields + parses the lexical JSON string ----
+(define post1 (blogimport/parse-row row1))
+(bi-test "parse-row id from uuid" (get post1 :id) "post-1")
+(bi-test "parse-row title" (get post1 :title) "Live")
+(bi-test "parse-row tags" (get post1 :tags) (list "x"))
+(bi-test "parse-row lexical parsed to blocks"
+  (map blk-type (blogimport/lex-blocks (get post1 :lexical))) (list "heading" "text"))
+
+; ---- id fallback (:id when no :uuid) + structured (non-string) lexical ----
+(define
+  post3
+  (blogimport/parse-row
+    {:id "post-3" :slug "s3"
+     :lexical {:children (list {:type "paragraph" :children (list {:type "text" :text "x"})})}}))
+(bi-test "parse-row id fallback" (get post3 :id) "post-3")
+(bi-test "parse-row structured lexical used as-is"
+  (map blk-type (blogimport/lex-blocks (get post3 :lexical))) (list "text"))
+
+; ---- source-rows / source-posts ----
+(bi-test "source-rows count" (len (blogimport/source-rows mock-fetch)) 2)
+(bi-test "source-posts ids"
+  (map (fn (p) (get p :id)) (blogimport/source-posts mock-fetch))
+  (list "post-1" "post-2"))
+
+; ---- end-to-end backfill from the live source ----
+(define B (persist/open))
+(define cov (blogimport/backfill! B mock-fetch 10))
+(bi-test "backfill total" (get cov :total) 2)
+(bi-test "backfill imported" (get cov :imported) 2)
+(bi-test "backfill post-1 version-count" (content/version-count B "post-1") 2)
+(bi-test "backfill post-1 head ids" (doc-ids (content/head B "post-1")) (list "b0" "b1"))
+(bi-test "backfill post-1 body text"
+  (str (blk-send (doc-find (content/head B "post-1") "b1") "text")) "from db")
+(bi-test "backfill meta title" (get (blogimport/load-meta B "post-1") :title) "Live")
+
+; ---- backfill is idempotent (one-way sync re-run) ----
+(define cov2 (blogimport/backfill! B mock-fetch 11))
+(bi-test "backfill rerun skipped" (get cov2 :skipped) 2)
+
+; ---- sync-verify: persisted streams match the live-source oracle ----
+(define sv (blogimport/sync-verify B mock-fetch))
+(bi-test "sync-verify total" (get sv :total) 2)
+(bi-test "sync-verify ok" (get sv :ok) 2)
+(bi-test "sync-verify no mismatch" (get sv :mismatched) (list))
+
+; ---- partial backfill: client-side id filter (no extra blog query) ----
+(define B2 (persist/open))
+(define covx (blogimport/backfill-ids! B2 mock-fetch (list "post-2") 10))
+(bi-test "backfill-ids imported" (get covx :imported) 1)
+(bi-test "backfill-ids post-2 ids" (doc-ids (content/head B2 "post-2")) (list "b0"))
+(bi-test "backfill-ids other not imported" (content/version-count B2 "post-1") 0)

lib/blogimport/tests/verify.sx

@@ -0,0 +1,57 @@
+; lib/blogimport/tests/verify.sx — shadow-diff at rest (round-trip parity)
+(st-bootstrap-classes!)
+(content-bootstrap-blocks!)
+(content-bootstrap-doc!)
+(content-bootstrap-callout!)
+(content-bootstrap-media!)
+
+(define
+  p1
+  {:id "post-1" :slug "hello" :title "Hello" :status "published"
+   :visibility "public" :tags (list "news") :authors (list "u1")
+   :lexical {:root {:children (list
+     {:type "heading" :tag "h2" :children (list {:type "text" :text "Title"})}
+     {:type "paragraph" :children (list
+       {:type "text" :text "plain "}
+       {:type "text" :text "bold" :format 1})}
+     {:type "list" :listType "number" :children (list
+       {:type "listitem" :children (list {:type "text" :text "one"})}
+       {:type "listitem" :children (list {:type "text" :text "two"})})}
+     {:type "image" :src "/c.png" :alt "cat"})}}})
+
+(define
+  px
+  {:id "post-x" :slug "ghost" :title "Ghost" :status "published"
+   :lexical {:children (list {:type "paragraph" :children (list {:type "text" :text "never imported"})})}})
+
+; ---- happy path: replayed == oracle ----
+(define B (persist/open))
+(blogimport/import-post! B p1 10)
+(define v1 (blogimport/verify-post B p1))
+(bi-test "verify ok" (get v1 :ok) true)
+(bi-test "verify block-ok" (get v1 :block-ok) true)
+(bi-test "verify meta-ok" (get v1 :meta-ok) true)
+
+; ---- oracle block model is what we expect (inline bold flattened) ----
+(define orc (blogimport/oracle p1))
+(bi-test "oracle types"
+  (get (get orc :blocks) :types) (list "heading" "text" "list" "image"))
+(bi-test "oracle contents"
+  (get (get orc :blocks) :contents) (list "Title" "plain bold" (list "one" "two") "/c.png"))
+
+; ---- corruption is DETECTED (op-log diverges from oracle) ----
+(content/commit! B "post-1" (op-update "b1" "text" "CORRUPTED") 100)
+(define v2 (blogimport/verify-post B p1))
+(bi-test "verify detects corruption" (get v2 :ok) false)
+(bi-test "verify corruption is block-level" (get v2 :block-ok) false)
+
+; ---- an un-imported post fails verification (empty replay vs non-empty oracle) ----
+(bi-test "unimported not ok" (get (blogimport/verify-post B px) :ok) false)
+
+; ---- verify-all coverage scoreboard ----
+(define B3 (persist/open))
+(blogimport/import-post! B3 p1 10)
+(define cov (blogimport/verify-all B3 (list p1 px)))
+(bi-test "verify-all total" (get cov :total) 2)
+(bi-test "verify-all ok count" (get cov :ok) 1)
+(bi-test "verify-all mismatched" (get cov :mismatched) (list "post-x"))

lib/blogimport/verify.sx

@@ -0,0 +1,73 @@
+; lib/blogimport/verify.sx
+; Shadow-diff at rest (plans/migration/data-migration.md §6, slice-01-blog.md §4).
+;
+; After backfill, replay each content:<id> stream -> materialized doc -> block
+; model, and diff against the row-derived oracle (lexical->blocks computed directly).
+; Structural compare with `=` (not equal?). This proves the genesis import + op-log
+; replay is LOSSLESS — "did the backfill corrupt anything" at rest.
+;
+; The oracle here is the in-memory lexical->blocks of the SAME post, so the property
+; verified is round-trip fidelity through persist. Cross-checking against the LIVE
+; Python block model (the "does SX match Python" half of Q-D2) is a later wiring
+; step that needs the Python oracle via the internal-data query (Q-M4) — flagged,
+; not built. The diff plumbing here is the twin that step reuses.
+
+; --- salient content per block (normalized; same on both sides) -----------------
+; ids are deterministic + identical on both sides, so they are kept (not stripped).
+(define
+  blogimport/blk-content
+  (fn (b)
+    (let ((t (blk-type b)))
+      (cond
+        ((equal? t "image") (str (blk-send b "src")))
+        ((equal? t "media") (str (blk-send b "src")))
+        ((equal? t "embed") (str (blk-send b "url")))
+        ((equal? t "list") (blk-send b "items"))
+        ((equal? t "divider") "")
+        (else (str (blk-send b "text")))))))
+
+; --- block model of a block list ------------------------------------------------
+(define
+  blogimport/blocks-model
+  (fn (blocks)
+    {:ids (map blk-id blocks)
+     :types (map blk-type blocks)
+     :contents (map blogimport/blk-content blocks)}))
+
+; --- oracle: lexical->blocks computed directly from the post (no persist) --------
+(define
+  blogimport/oracle
+  (fn (post)
+    {:blocks (blogimport/blocks-model (blogimport/lex-blocks (get post :lexical)))
+     :meta (blogimport/post-meta post)}))
+
+; --- replayed: from the persisted stream ----------------------------------------
+(define
+  blogimport/replayed
+  (fn (b id)
+    {:blocks (blogimport/blocks-model (content/blocks (content/head b id)))
+     :meta (blogimport/load-meta b id)}))
+
+; --- verify one post: replayed must equal oracle --------------------------------
+(define
+  blogimport/verify-post
+  (fn (b post)
+    (let ((id (get post :id)))
+      (let ((orc (blogimport/oracle post))
+            (rep (blogimport/replayed b id)))
+        (let ((block-ok (= (get orc :blocks) (get rep :blocks)))
+              (meta-ok (= (get orc :meta) (get rep :meta))))
+          {:id id
+           :ok (and block-ok meta-ok)
+           :block-ok block-ok
+           :meta-ok meta-ok})))))
+
+; --- verify many: coverage scoreboard -------------------------------------------
+(define
+  blogimport/verify-all
+  (fn (b posts)
+    (let ((results (map (fn (p) (blogimport/verify-post b p)) posts)))
+      {:total (len results)
+       :ok (len (filter (fn (r) (get r :ok)) results))
+       :mismatched (map (fn (r) (get r :id))
+                     (filter (fn (r) (not (get r :ok))) results))})))

lib/common-lisp/runtime.sx

@@ -757,4 +757,24 @@
                    "format-arguments" args))))
       (cl-restart-case
         (fn () (cl-signal-obj obj cl-handler-stack))
-        (list "continue" (list) (fn () nil))))))
+        (list "continue" (list) (fn () nil))))))
+;; ── JIT interpret-only boundary ───────────────────────────────────────────
+;; The Common-Lisp evaluator implements block/return-from, catch/throw, and
+;; the condition system via non-local control (host continuations); under JIT
+;; a compiled frame can't transfer control through a CEK continuation. Exclude
+;; the cl-/clos- namespaces from JIT. See Sx_types.jit_excluded_prefixes.
+(jit-exclude! "cl-*" "clos-*")
+
+;; cl-restart-case / cl-handler-case / cl-handler-bind wrap their body in
+;; call/cc (restarts + non-local handler exit). Any function that CALLS one of
+;; these (e.g. SX fixtures driving the condition system: parse-recover,
+;; interactive-debugger) must also be interpret-only: JIT'ing such a caller
+;; forces the call/cc form into a nested cek-run where the captured
+;; continuation runs-to-completion-and-returns instead of escaping, so a
+;; restart fails to abort and the body falls through (accumulation/no-abort).
+(jit-exclude-callers-of! "cl-restart-case" "cl-handler-case" "cl-handler-bind")
+;; Also the INVOKE side: cl-invoke-restart / cl-invoke-debugger / cl-signal
+;; trigger the continuation escape; a JIT'd caller can't let the escape
+;; propagate out of its frame (e.g. make-policy-debugger building a debugger
+;; hook that invokes a restart). Mark their callers interpret-only too.
+(jit-exclude-callers-of! "cl-invoke-restart" "cl-invoke-debugger" "cl-signal" "cl-error-with-debugger")

lib/compiler.sx

@@ -783,11 +783,7 @@
                 (rest-clauses
                   (if (> (len flat-args) 2) (slice flat-args 2) (list))))
               (if
-                (or
+                (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) (and (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else"))) (= test true))
-                  (and
-                    (= (type-of test) "keyword")
-                    (= (keyword-name test) "else"))
-                  (= test true))
                 (compile-expr em body scope tail?)
                 (do
                   (compile-expr em test scope false)
@@ -828,11 +824,7 @@
               (rest-clauses
                 (if (> (len clauses) 2) (slice clauses 2) (list))))
             (if
-              (or
+              (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) (and (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else"))) (= test true))
-                (and
-                  (= (type-of test) "keyword")
-                  (= (keyword-name test) "else"))
-                (= test true))
               (do (emit-op em 5) (compile-expr em body scope tail?))
               (do
                 (emit-op em 6)
@@ -1172,11 +1164,7 @@
               (test (first clause))
               (body (rest clause)))
             (if
-              (or
+              (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) (and (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else"))) (= test true))
-                (and
-                  (= (type-of test) "keyword")
-                  (= (keyword-name test) "else"))
-                (= test true))
               (compile-begin em body scope tail?)
               (do
                 (compile-expr em test scope false)

lib/content/api.sx

@@ -25,8 +25,13 @@
 (define content/append doc-append)
 (define content/blocks doc-blocks)
 (define content/count doc-count)
-(define content/find doc-find)
+;; find / has? are TREE-WIDE by id (descend into sections) — so the facade reads
-(define content/has? doc-has?)
+;; back any block content/edit can update or delete. content/find-top / has-top?
+;; keep the top-level-only lookup for callers that mean the ordered sequence.
+(define content/find doc-find-deep)
+(define content/has? doc-has-deep?)
+(define content/find-top doc-find)
+(define content/has-top? doc-has?)
 (define content/ids doc-ids)
 (define content/types doc-types)
 

lib/content/doc.sx

@@ -5,14 +5,19 @@
 ;; and returns a NEW document — the input is never mutated, so any version is the
 ;; head of an op stream (replay-friendly for persist + CRDT merge).
 ;;
-;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
+;; By-id ops (update/delete) and by-id lookup (doc-find-deep/doc-has-deep?) are
-;; ergonomic API; they default nil and do not affect block operations.
+;; TREE-WIDE: they descend into any block carrying a `children` list (i.e.
+;; sections), since ids are unique across the tree. This keeps the persist
+;; op-log, content/edit and content/find correct for nested documents.
+;; insert/move are positional and act at the top level.
+;;
+;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx.
 ;;
 ;; Op shapes (data, not objects — they are the persist event payload):
-;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend
+;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend (top level)
-;;   {:op "update" :id <id> :field <name> :value <v>}
+;;   {:op "update" :id <id> :field <name> :value <v>}   ; tree-wide by id
-;;   {:op "move"   :id <id> :index <n>}
+;;   {:op "move"   :id <id> :index <n>}                 ; top level
-;;   {:op "delete" :id <id>}
+;;   {:op "delete" :id <id>}                            ; tree-wide by id
 
 (define
   content-bootstrap-doc!
@@ -76,17 +81,58 @@
           (first blocks)
           (ct-insert-at (rest blocks) (- i 1) x))))))
 
+;; tree-wide remove by id: drop matches at this level, recurse into children
+;; (blocks carrying a `children` list, i.e. sections).
 (define
   ct-remove-id
   (fn
     (blocks id)
-    (filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
+    (map
+      (fn
+        (b)
+        (let
+          ((ch (st-iv-get b "children")))
+          (if (list? ch) (st-iv-set! b "children" (ct-remove-id ch id)) b)))
+      (filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))
 
+;; tree-wide replace by id: apply f to the match wherever it sits in the tree.
 (define
   ct-replace-id
   (fn
     (blocks id f)
-    (map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
+    (map
+      (fn
+        (b)
+        (if
+          (= (blk-id b) id)
+          (f b)
+          (let
+            ((ch (st-iv-get b "children")))
+            (if
+              (list? ch)
+              (st-iv-set! b "children" (ct-replace-id ch id f))
+              b))))
+      blocks)))
+
+;; tree-wide find by id: first block matching id anywhere in the tree, or nil.
+;; Descends into any `children` list, mirroring ct-replace-id/ct-remove-id.
+(define
+  ct-find-id
+  (fn
+    (blocks id)
+    (if
+      (= (len blocks) 0)
+      nil
+      (let
+        ((b (first blocks)))
+        (if
+          (= (blk-id b) id)
+          b
+          (let
+            ((ch (st-iv-get b "children")))
+            (let
+              ((nested (if (list? ch) (ct-find-id ch id) nil)))
+              (if (= nested nil) (ct-find-id (rest blocks) id) nested))))))))
 
 ;; ── query ──
 (define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
@@ -103,6 +149,14 @@
   doc-has?
   (fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
 
+;; tree-wide lookup by id — reads a nested block by the same id content/edit can
+;; update/delete (no section.sx dependency; uses the generic children descent).
+(define doc-find-deep (fn (doc id) (ct-find-id (doc-blocks doc) id)))
+
+(define
+  doc-has-deep?
+  (fn (doc id) (if (= (doc-find-deep doc id) nil) false true)))
+
 ;; ── structural edits (each returns a new document) ──
 (define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
 

lib/content/find-replace.sx

@@ -1,10 +1,17 @@
-;; content-on-sx — global find/replace across text-bearing blocks.
+;; content-on-sx — global find/replace across every text-bearing field.
 ;;
-;; Replaces every occurrence of `from` with `to` in the text field of text /
+;; Replaces every occurrence of `from` with `to` in the text-bearing fields of
-;; heading / code / quote blocks, tree-wide (via the transform layer). For
+;; a document, tree-wide (via the transform layer):
-;; renaming a term throughout a document. Immutable; case-sensitive.
+;;   - the `text` of text / heading / code / quote / callout blocks
+;;   - the `alt` of image blocks
+;;   - each item of list blocks
+;;   - every header and cell of table blocks
+;; This is exactly the set asText / stats / summary draw prose from, so a rename
+;; via content/find-replace and a word count over asText stay consistent.
+;; Immutable; case-sensitive.
 ;;
-;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks).
+;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks),
+;; table.sx (CtTable ivars).
 
 (define
   fr-in?
@@ -15,17 +22,54 @@
       ((= (first xs) x) true)
       (else (fr-in? x (rest xs))))))
 
+(define fr-rep (fn (s from to) (replace (str s) from to)))
+
+;; Blocks whose prose content find/replace rewrites (matches asText's set).
 (define
   fr-has-text?
-  (fn (b) (fr-in? (blk-type b) (list "text" "heading" "code" "quote"))))
+  (fn
+    (b)
+    (fr-in?
+      (blk-type b)
+      (list "text" "heading" "code" "quote" "callout" "image" "list" "table"))))
+
+;; Per-type field rewrite. Each branch returns a new (copy-on-write) block.
+(define
+  fr-rewrite
+  (fn
+    (b from to)
+    (let
+      ((t (blk-type b)))
+      (cond
+        ((= t "image")
+          (blk-set b "alt" (fr-rep (blk-get b "alt") from to)))
+        ((= t "list")
+          (let
+            ((items (blk-get b "items")))
+            (if
+              (list? items)
+              (blk-set b "items" (map (fn (it) (fr-rep it from to)) items))
+              b)))
+        ((= t "table")
+          (let
+            ((hs (blk-get b "headers")) (rs (blk-get b "rows")))
+            (let
+              ((b1 (if (list? hs) (blk-set b "headers" (map (fn (h) (fr-rep h from to)) hs)) b)))
+              (if
+                (list? rs)
+                (blk-set
+                  b1
+                  "rows"
+                  (map
+                    (fn
+                      (r)
+                      (if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
+                    rs))
+                b1))))
+        (else (blk-set b "text" (fr-rep (blk-get b "text") from to)))))))
 
 (define
   content/find-replace
   (fn
     (doc from to)
-    (content/map-blocks
+    (content/map-blocks doc fr-has-text? (fn (b) (fr-rewrite b from to)))))
-      doc
-      fr-has-text?
-      (fn
-        (b)
-        (blk-set b "text" (replace (str (blk-get b "text")) from to))))))

lib/content/query.sx

@@ -1,10 +1,10 @@
 ;; content-on-sx — block query + table of contents.
 ;;
 ;; Collect blocks across the whole tree (descending into sections) by predicate
-;; or type, and derive a table of contents from headings. Tree detection is
+;; or type, search them by prose, and derive a table of contents from headings.
-;; inline (class + st-iv-get) so this needs no section.sx.
+;; Tree detection is inline (class + st-iv-get) so this needs no section.sx.
 ;;
-;; Requires (loaded by harness): block.sx, doc.sx.
+;; Requires (loaded by harness): block.sx, doc.sx, text.sx (asText for search).
 
 (define
   qry-section?
@@ -45,6 +45,30 @@
   content/select-ids
   (fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
 
+;; Blocks (tree-wide, excluding section containers) whose own prose contains
+;; `term`. "Prose" is (asText b), so search covers exactly what every block
+;; exposes as text — text/heading/code/quote/callout text, image alt, list
+;; items, table headers+cells — with no separate field list to drift from
+;; asText / find-replace / stats. Case-sensitive substring match.
+(define
+  content/search-text
+  (fn
+    (doc term)
+    (content/select
+      doc
+      (fn
+        (b)
+        (and
+          (not (qry-section? b))
+          (>= (index-of (asText b) term) 0))))))
+
+;; Same search, returning matching block ids in document order.
+(define
+  content/search-text-ids
+  (fn
+    (doc term)
+    (map (fn (b) (blk-id b)) (content/search-text doc term))))
+
 ;; table of contents: {:id :level :text} for every heading, in document order.
 (define
   content/headings

lib/content/scoreboard.json

@@ -3,7 +3,7 @@
     "block": {"pass": 38, "fail": 0},
     "doc": {"pass": 40, "fail": 0},
     "render": {"pass": 42, "fail": 0},
-    "api": {"pass": 26, "fail": 0},
+    "api": {"pass": 32, "fail": 0},
     "meta": {"pass": 27, "fail": 0},
     "page": {"pass": 7, "fail": 0},
     "page-full": {"pass": 4, "fail": 0},
@@ -14,14 +14,14 @@
     "tree-edit": {"pass": 17, "fail": 0},
     "move": {"pass": 11, "fail": 0},
     "clone": {"pass": 10, "fail": 0},
-    "query": {"pass": 13, "fail": 0},
+    "query": {"pass": 20, "fail": 0},
     "toc": {"pass": 8, "fail": 0},
     "anchor": {"pass": 6, "fail": 0},
     "outline": {"pass": 14, "fail": 0},
     "flatten": {"pass": 10, "fail": 0},
     "transform": {"pass": 12, "fail": 0},
     "normalize": {"pass": 11, "fail": 0},
-    "find-replace": {"pass": 10, "fail": 0},
+    "find-replace": {"pass": 16, "fail": 0},
     "stats": {"pass": 17, "fail": 0},
     "summary": {"pass": 14, "fail": 0},
     "index": {"pass": 13, "fail": 0},
@@ -31,7 +31,7 @@
     "data": {"pass": 25, "fail": 0},
     "wire": {"pass": 11, "fail": 0},
     "validate": {"pass": 23, "fail": 0},
-    "store": {"pass": 33, "fail": 0},
+    "store": {"pass": 46, "fail": 0},
     "snapshot": {"pass": 20, "fail": 0},
     "crdt": {"pass": 34, "fail": 0},
     "crdt-tree": {"pass": 21, "fail": 0},
@@ -42,7 +42,7 @@
     "md-doc": {"pass": 12, "fail": 0},
     "fed": {"pass": 20, "fail": 0}
   },
-  "total_pass": 746,
+  "total_pass": 778,
   "total_fail": 0,
-  "total": 746
+  "total": 778
 }

lib/content/scoreboard.md

@@ -7,7 +7,7 @@ _Generated by `lib/content/conformance.sh`_
 | block | 38 | 0 | 38 |
 | doc | 40 | 0 | 40 |
 | render | 42 | 0 | 42 |
-| api | 26 | 0 | 26 |
+| api | 32 | 0 | 32 |
 | meta | 27 | 0 | 27 |
 | page | 7 | 0 | 7 |
 | page-full | 4 | 0 | 4 |
@@ -18,14 +18,14 @@ _Generated by `lib/content/conformance.sh`_
 | tree-edit | 17 | 0 | 17 |
 | move | 11 | 0 | 11 |
 | clone | 10 | 0 | 10 |
-| query | 13 | 0 | 13 |
+| query | 20 | 0 | 20 |
 | toc | 8 | 0 | 8 |
 | anchor | 6 | 0 | 6 |
 | outline | 14 | 0 | 14 |
 | flatten | 10 | 0 | 10 |
 | transform | 12 | 0 | 12 |
 | normalize | 11 | 0 | 11 |
-| find-replace | 10 | 0 | 10 |
+| find-replace | 16 | 0 | 16 |
 | stats | 17 | 0 | 17 |
 | summary | 14 | 0 | 14 |
 | index | 13 | 0 | 13 |
@@ -35,7 +35,7 @@ _Generated by `lib/content/conformance.sh`_
 | data | 25 | 0 | 25 |
 | wire | 11 | 0 | 11 |
 | validate | 23 | 0 | 23 |
-| store | 33 | 0 | 33 |
+| store | 46 | 0 | 46 |
 | snapshot | 20 | 0 | 20 |
 | crdt | 34 | 0 | 34 |
 | crdt-tree | 21 | 0 | 21 |
@@ -45,4 +45,4 @@ _Generated by `lib/content/conformance.sh`_
 | md-import | 38 | 0 | 38 |
 | md-doc | 12 | 0 | 12 |
 | fed | 20 | 0 | 20 |
-| **Total** | **746** | **0** | **746** |
+| **Total** | **778** | **0** | **778** |

lib/content/store.sx

@@ -5,9 +5,10 @@
 ;; replay of its op stream up to a sequence number; the materialised doc is a
 ;; cache, never primary state.
 ;;
-;; Requires (loaded by the harness): block.sx, doc.sx, and persist
+;; Requires (loaded by the harness): block.sx, doc.sx, section.sx (doc-deep-find
-;; (event/backend/log/kv/api). The persist backend `b` is opened by the caller
+;; + doc-tree-ids, for the tree-wide diff), plus persist (event/backend/log/kv/
-;; via (persist/open) and injected — content knows nothing about which backend.
+;; api). The persist backend `b` is opened by the caller via (persist/open) and
+;; injected — content knows nothing about which backend.
 
 (define content/-stream (fn (doc-id) (str "content:" doc-id)))
 
@@ -69,11 +70,18 @@
   (fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
 
 ;; ── diff between two materialised document versions ──
-;; Returns {:added (ids) :removed (ids) :changed (ids)} where changed = ids
+;; Tree-wide: ids are enumerated across the whole block tree (descending into
-;; present in both whose block content differs.
+;; sections), so nested-block adds/removes/changes are detected, not just
-(define
+;; top-level ones. Returns {:added :removed :changed} (lists of ids):
-  content/-missing?
+;;   :added   — ids present (anywhere) in `new` but not in `old`
-  (fn (doc id) (= (ct-index-of (doc-blocks doc) id) -1)))
+;;   :removed — ids present (anywhere) in `old` but not in `new`
+;;   :changed — content blocks present in both whose block value differs
+;; Section containers never appear in :changed (they hold no own content — a
+;; child change surfaces as that child's own entry); a whole section appearing
+;; or disappearing shows up in :added / :removed by its id.
+(define content/-all-ids (fn (doc) (doc-tree-ids doc)))
+
+(define content/-missing? (fn (doc id) (= (doc-deep-find doc id) nil)))
 
 (define
   content/-changed
@@ -83,15 +91,16 @@
       (fn
         (id)
         (let
-          ((bo (doc-find old id)) (bn (doc-find new id)))
+          ((bo (doc-deep-find old id)) (bn (doc-deep-find new id)))
           (cond
             ((= bo nil) false)
             ((= bn nil) false)
+            ((= (blk-type bo) "section") false)
             ((= bo bn) false)
             (else true))))
-      (doc-ids old))))
+      (content/-all-ids old))))
 
-(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (doc-ids old)) :added (filter (fn (id) (content/-missing? old id)) (doc-ids new))}))
+(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (content/-all-ids old)) :added (filter (fn (id) (content/-missing? old id)) (content/-all-ids new))}))
 
 ;; convenience: diff two persisted versions by seq.
 (define

lib/content/tests/api.sx

@@ -97,3 +97,37 @@
   "render original unchanged"
   (content/render d1 "html")
   "<h1>Hi</h1><p>World</p>")
+
+;; ── facade find/has? are TREE-WIDE (reach into sections); find-top/has-top?
+;; keep the top-level-only lookup. This makes the read-by-id surface consistent
+;; with content/edit, whose update/delete are already tree-wide. ──
+(content-bootstrap-section!)
+(define
+  nd
+  (content/append
+    (content/empty "nested")
+    (mk-section
+      "sec"
+      (list (content/block "text" "inner" (list (list "text" "deep")))))))
+(content-test
+  "find nested (deep)"
+  (blk-id (content/find nd "inner"))
+  "inner")
+(content-test "has? nested (deep)" (content/has? nd "inner") true)
+(content-test "find-top misses nested" (content/find-top nd "inner") nil)
+(content-test "has-top? misses nested" (content/has-top? nd "inner") false)
+(content-test
+  "find-top sees top-level"
+  (blk-id (content/find-top nd "sec"))
+  "sec")
+;; a nested block updated by id via content/edit is now readable by id via
+;; content/find (was impossible when find was top-level-only).
+(content-test
+  "edit-then-find nested round-trip"
+  (str
+    (blk-send
+      (content/find
+        (content/edit nd (content/update "inner" "text" "edited"))
+        "inner")
+      "text"))
+  "edited")

lib/content/tests/find-replace.sx

@@ -1,8 +1,10 @@
-;; Extension — global find/replace across text-bearing blocks.
+;; Extension — global find/replace across every text-bearing field.
 
 (st-bootstrap-classes!)
 (content/bootstrap!)
 (content-bootstrap-section!)
+(content-bootstrap-callout!)
+(content-bootstrap-table!)
 
 (define
   d
@@ -30,11 +32,12 @@
   (str (blk-send (doc-deep-find r "n") "text"))
   "nested Bar")
 
-;; ── does NOT touch image alt/src (not a text field) ──
+;; ── image alt IS a text field (asText ^ alt), so it is rewritten ──
 (content-test
-  "image alt untouched"
+  "image alt replaced"
   (str (blk-send (doc-deep-find r "img") "alt"))
-  "Foo alt")
+  "Bar alt")
+;; ── but src is a URL, not prose, so it stays put ──
 (content-test
   "image src untouched"
   (str (blk-send (doc-deep-find r "img") "src"))
@@ -76,6 +79,68 @@
   (str (blk-send (doc-find r2 "q") "text"))
   "new saying")
 
+;; ── callout text is covered (consistency with asText/stats/summary) ──
+(content-test
+  "replace callout text"
+  (str
+    (blk-send
+      (doc-find
+        (content/find-replace
+          (doc-append (doc-empty "d") (mk-callout "co" "note" "Foo here"))
+          "Foo"
+          "Bar")
+        "co")
+      "text"))
+  "Bar here")
+(content-test
+  "callout kind untouched by text replace"
+  (str
+    (blk-send
+      (doc-find
+        (content/find-replace
+          (doc-append (doc-empty "d") (mk-callout "co" "note" "x"))
+          "note"
+          "X")
+        "co")
+      "kind"))
+  "note")
+
+;; ── list items are rewritten (asText folds items) ──
+(define
+  rl
+  (content/find-replace
+    (doc-append
+      (doc-empty "d")
+      (mk-list "l" false (list "Foo one" "two Foo")))
+    "Foo"
+    "Bar"))
+(content-test
+  "replace first list item"
+  (str (first (blk-send (doc-find rl "l") "items")))
+  "Bar one")
+(content-test
+  "replace second list item"
+  (str (first (rest (blk-send (doc-find rl "l") "items"))))
+  "two Bar")
+
+;; ── table headers + cells are rewritten (asText folds rows) ──
+(define
+  rt
+  (content/find-replace
+    (doc-append
+      (doc-empty "d")
+      (mk-table "t" (list "Foo head") (list (list "a Foo" "b"))))
+    "Foo"
+    "Bar"))
+(content-test
+  "replace table header"
+  (str (first (table-headers (doc-find rt "t"))))
+  "Bar head")
+(content-test
+  "replace table cell"
+  (str (first (first (table-rows (doc-find rt "t")))))
+  "a Bar")
+
 ;; ── no match → unchanged render ──
 (content-test
   "no match"

lib/content/tests/query.sx

@@ -1,8 +1,11 @@
-;; Extension — block query + table of contents.
+;; Extension — block query + table of contents + prose search.
 
 (st-bootstrap-classes!)
 (content/bootstrap!)
+(content-bootstrap-text!)
 (content-bootstrap-section!)
+(content-bootstrap-table!)
+(content-bootstrap-callout!)
 
 (define
   d
@@ -87,3 +90,49 @@
   "deep toc level"
   (get (first (content/headings deep)) :level)
   3)
+
+;; ── prose search (content/search-text) ──
+;; "cat" appears in text, image alt, a list item, a table cell, and a callout
+;; — every text-bearing field — so search must find all five via asText.
+(define
+  sd
+  (doc-append
+    (doc-append
+      (doc-append
+        (doc-append
+          (doc-append
+            (doc-empty "sd")
+            (mk-heading "sh" 1 "Welcome aboard"))
+          (mk-text "st" "the cat sat"))
+        (mk-image "si" "/x.png" "a cat photo"))
+      (mk-list "sl" false (list "first cat" "second dog")))
+    (mk-section
+      "sec"
+      (list
+        (mk-table "stb" (list "Animal") (list (list "cat") (list "fish")))
+        (mk-callout "sc" "note" "beware of cat")))))
+
+(content-test
+  "search across every text-bearing field"
+  (content/search-text-ids sd "cat")
+  (list "st" "si" "sl" "stb" "sc"))
+(content-test "search count" (len (content/search-text sd "cat")) 5)
+(content-test
+  "search heading text"
+  (content/search-text-ids sd "Welcome")
+  (list "sh"))
+(content-test
+  "search list item only"
+  (content/search-text-ids sd "dog")
+  (list "sl"))
+(content-test "search no match" (content/search-text-ids sd "zzz") (list))
+;; section containers are excluded — a term living only inside a section's
+;; children returns the child, never the section wrapper.
+(content-test
+  "search excludes section wrapper"
+  (content/search-text-ids sd "fish")
+  (list "stb"))
+(content-test
+  "search returns block objects"
+  (blk-id (first (content/search-text sd "Welcome")))
+  "sh")

lib/content/tests/store.sx

@@ -151,3 +151,58 @@
   "op-log media type"
   (blk-type (doc-find (content/head B3 "rich") "v"))
   "media")
+
+;; ── op-log update/delete reach NESTED blocks (tree-wide by id) ──
+(content-bootstrap-section!)
+(define B4 (persist/open))
+(content/commit!
+  B4
+  "nest"
+  (op-insert (mk-section "sec" (list (mk-text "n" "orig"))) nil)
+  1)
+(content/commit! B4 "nest" (op-update "n" "text" "edited") 2)
+(content-test
+  "op-log nested update"
+  (str (blk-send (doc-deep-find (content/head B4 "nest") "n") "text"))
+  "edited")
+(content-test
+  "op-log nested update tree intact"
+  (doc-tree-ids (content/head B4 "nest"))
+  (list "sec" "n"))
+(content/commit! B4 "nest" (op-delete "n") 3)
+(content-test
+  "op-log nested delete"
+  (doc-tree-ids (content/head B4 "nest"))
+  (list "sec"))
+(content-test
+  "op-log nested delete via content/at seq2"
+  (doc-tree-ids (content/at B4 "nest" 2))
+  (list "sec" "n"))
+
+;; ── diff is TREE-WIDE: nested-block add/change/remove are detected, and
+;; section containers never appear in :changed (a top-level-only diff would miss
+;; "n" entirely and instead flag the section). ──
+(define dn01 (content/diff-versions B4 "nest" 0 1))
+(content-test
+  "diff nested added (section + child)"
+  (get dn01 :added)
+  (list "sec" "n"))
+(content-test "diff nested added removed empty" (get dn01 :removed) (list))
+(content-test "diff nested added changed empty" (get dn01 :changed) (list))
+
+(define dn12 (content/diff-versions B4 "nest" 1 2))
+(content-test
+  "diff nested changed child only"
+  (get dn12 :changed)
+  (list "n"))
+(content-test "diff nested changed no add" (get dn12 :added) (list))
+(content-test "diff nested changed no remove" (get dn12 :removed) (list))
+
+(define dn23 (content/diff-versions B4 "nest" 2 3))
+(content-test "diff nested removed child" (get dn23 :removed) (list "n"))
+(content-test "diff nested removed no change" (get dn23 :changed) (list))
+
+(content-test
+  "diff nested no-op"
+  (get (content/diff-versions B4 "nest" 1 1) :changed)
+  (list))

lib/erlang/conformance.conf

@@ -32,6 +32,7 @@ SUITES=(
   "fib:lib/erlang/tests/programs/fib_server.sx:{:passed er-fib-test-pass :failed (- er-fib-test-count er-fib-test-pass) :total er-fib-test-count}"
   "ffi:lib/erlang/tests/ffi.sx:{:passed er-ffi-test-pass :failed (- er-ffi-test-count er-ffi-test-pass) :total er-ffi-test-count}"
   "vm:lib/erlang/tests/vm.sx:{:passed er-vm-test-pass :failed (- er-vm-test-count er-vm-test-pass) :total er-vm-test-count}"
+  "send_after:lib/erlang/tests/send_after.sx:{:passed er-sa-test-pass :failed (- er-sa-test-count er-sa-test-pass) :total er-sa-test-count}"
 )
 
 # Preserve the historical scoreboard schema so consumers of

lib/erlang/runtime.sx

@@ -135,6 +135,56 @@
         (dict-set! s :next-ref (+ n 1))
         (er-mk-ref n)))))
 
+;; ── logical clock + timer wheel ──────────────────────────────────
+;; The scheduler runs a synchronous model: logical time advances only
+;; when the runnable queue drains (see `er-sched-advance-time!`). The
+;; clock is in milliseconds, monotonic, never derived from wall time
+;; — deterministic and time-travel-safe. `send_after` schedules a
+;; message-delivery event at an absolute deadline; `receive after Ms`
+;; schedules a timeout event the same way. When no process is runnable
+;; the scheduler jumps the clock to the earliest pending deadline and
+;; fires that single event, then re-runs.
+(define er-clock (fn () (get (er-sched) :clock)))
+
+;; Advance the clock to `ms`, but never backwards (monotonicity).
+(define
+  er-clock-set!
+  (fn (ms) (dict-set! (er-sched) :clock (max (er-clock) ms))))
+
+(define er-sched-timers (fn () (get (er-sched) :timers)))
+
+;; Register a timer event. `dest` is a pid or registered-atom value,
+;; resolved to a live process at fire time. Returns the timer ref.
+(define
+  er-timer-add!
+  (fn
+    (deadline dest msg ref)
+    (append!
+      (er-sched-timers)
+      {:ref ref :deadline deadline :dest dest :msg msg :alive true})
+    ref))
+
+;; Find the live timer with the given ref, or nil.
+(define
+  er-timer-find-alive
+  (fn
+    (ref)
+    (let
+      ((ts (er-sched-timers)) (found (list nil)))
+      (for-each
+        (fn
+          (i)
+          (let
+            ((t (nth ts i)))
+            (when
+              (and
+                (= (nth found 0) nil)
+                (get t :alive)
+                (er-ref-equal? (get t :ref) ref))
+              (set-nth! found 0 t))))
+        (range 0 (len ts)))
+      (nth found 0))))
+
 ;; ── scheduler state ──────────────────────────────────────────────
 (define er-scheduler (list nil))
 
@@ -151,6 +201,8 @@
         :processes {}
         :registered {}
         :ets {}
+        :clock 0
+        :timers (list)
         :runnable (er-q-new)})))
 
 (define er-sched (fn () (nth er-scheduler 0)))
@@ -217,6 +269,7 @@
             :trap-exit false
             :has-timeout false
             :timed-out false
+            :timeout-deadline nil
             :exit-reason nil}))
         (dict-set! (er-sched-processes) (er-pid-key pid) proc)
         (er-sched-enqueue! pid)
@@ -456,6 +509,69 @@
       (error "Erlang: make_ref/0: arity")
       (er-ref-new!))))
 
+;; ── timer BIFs ───────────────────────────────────────────────────
+;; erlang:send_after(Time, Dest, Msg) -> Ref
+;;   Schedules Msg to be delivered to Dest after Time ms (logical).
+;;   Time must be a non-negative integer; Dest a pid or registered
+;;   atom name. Returns a fresh timer reference.
+(define
+  er-bif-send-after
+  (fn
+    (vs)
+    (let
+      ((time (nth vs 0)) (dest (nth vs 1)) (msg (nth vs 2)))
+      (cond
+        (not (and (= (type-of time) "number") (>= time 0)))
+        (raise (er-mk-error-marker (er-mk-atom "badarg")))
+        (not (or (er-pid? dest) (er-atom? dest)))
+        (raise (er-mk-error-marker (er-mk-atom "badarg")))
+        :else
+        (er-timer-add!
+          (+ (er-clock) (truncate time))
+          dest
+          msg
+          (er-ref-new!))))))
+
+;; erlang:cancel_timer(Ref) -> RemainingMs | false
+;;   For a live (not-yet-fired) timer, marks it cancelled and returns
+;;   the milliseconds left until its deadline. For an already-fired,
+;;   already-cancelled, or unknown ref, returns the atom `false`.
+(define
+  er-bif-cancel-timer
+  (fn
+    (vs)
+    (let
+      ((ref (nth vs 0)))
+      (cond
+        (not (er-ref? ref))
+        (raise (er-mk-error-marker (er-mk-atom "badarg")))
+        :else
+        (let
+          ((t (er-timer-find-alive ref)))
+          (cond
+            (= t nil) (er-mk-atom "false")
+            :else (do
+              (dict-set! t :alive false)
+              (max 0 (- (get t :deadline) (er-clock))))))))))
+
+;; erlang:monotonic_time() | erlang:monotonic_time(Unit) -> Integer
+;;   Returns the scheduler's logical monotonic clock in milliseconds.
+;;   Unit (millisecond / second / native) is accepted for API
+;;   compatibility; all units report from the same ms-resolution clock.
+(define
+  er-bif-monotonic-time
+  (fn
+    (vs)
+    (cond
+      (= (len vs) 0) (er-clock)
+      (and (= (len vs) 1) (er-atom? (nth vs 0)))
+      (let
+        ((unit (get (nth vs 0) :name)))
+        (cond
+          (= unit "second") (truncate (/ (er-clock) 1000))
+          :else (er-clock)))
+      :else (raise (er-mk-error-marker (er-mk-atom "badarg"))))))
+
 ;; Add `target` to `pid`'s :links list if not already there.
 (define
   er-link-add-one!
@@ -664,37 +780,122 @@
       (cond
         (not (= pid nil))
         (do (er-sched-step! pid) (er-sched-run-all!))
-        ;; Queue empty — fire one pending receive-with-timeout and go again.
+        ;; Queue empty — advance logical time to the next pending
-        (er-sched-fire-one-timeout!) (er-sched-run-all!)
+        ;; deadline (timer delivery or receive-timeout) and go again.
+        (er-sched-advance-time!) (er-sched-run-all!)
         :else nil))))
 
-;; Wake one waiting process whose receive had an `after Ms` clause.
+;; ── time advance ─────────────────────────────────────────────────
-;; Returns true if one fired. In our synchronous model "time passes"
+;; Called when the runnable queue is empty. Two kinds of pending event
-;; once the runnable queue drains — timeouts only fire then.
+;; carry a deadline: live `send_after` timers and waiting processes in
+;; a `receive ... after Ms` block. Find the single earliest deadline
+;; across both, jump the clock to it, and fire just that one event
+;; (timer wins ties — a message delivered exactly at the timeout
+;; arrives "first"). Returns true if an event fired, false when there
+;; is nothing left to wake (genuine idle / termination).
 (define
-  er-sched-fire-one-timeout!
+  er-sched-advance-time!
   (fn
     ()
     (let
-      ((ks (keys (er-sched-processes))) (fired (list false)))
+      ((best (er-sched-next-event)))
+      (cond
+        (= best nil) false
+        :else (do
+          (er-clock-set! (get best :deadline))
+          (cond
+            (= (get best :kind) "timer")
+            (er-timer-fire! (get best :timer))
+            :else (er-recv-timeout-fire! (get best :proc)))
+          true)))))
+
+;; Scan timers and waiting-with-timeout processes for the earliest
+;; deadline. Returns {:kind "timer"|"recv" :deadline D ...} or nil.
+(define
+  er-sched-next-event
+  (fn
+    ()
+    (let
+      ((best (list nil)))
+      (for-each
+        (fn
+          (i)
+          (let
+            ((t (nth (er-sched-timers) i)))
+            (when
+              (get t :alive)
+              (er-event-consider!
+                best
+                {:kind "timer" :deadline (get t :deadline) :timer t}))))
+        (range 0 (len (er-sched-timers))))
       (for-each
         (fn
           (k)
-          (when
+          (let
-            (not (nth fired 0))
+            ((p (get (er-sched-processes) k)))
-            (let
+            (when
-              ((p (get (er-sched-processes) k)))
+              (and (= (get p :state) "waiting") (get p :has-timeout))
-              (when
+              (er-event-consider!
-                (and
+                best
-                  (= (get p :state) "waiting")
+                {:kind "recv"
-                  (get p :has-timeout))
+                  :deadline (get p :timeout-deadline)
-                (dict-set! p :timed-out true)
+                  :proc p}))))
-                (dict-set! p :has-timeout false)
+        (keys (er-sched-processes)))
-                (dict-set! p :state "runnable")
+      (nth best 0))))
-                (er-sched-enqueue! (get p :pid))
+
-                (set-nth! fired 0 true)))))
+;; Keep the earlier-deadline candidate in the single-cell `best`.
-        ks)
+;; Strictly-earlier replaces; equal deadlines keep the incumbent so a
-      (nth fired 0))))
+;; timer registered first (and timers over recv-timeouts) win ties.
+(define
+  er-event-consider!
+  (fn
+    (best cand)
+    (when
+      (or
+        (= (nth best 0) nil)
+        (< (get cand :deadline) (get (nth best 0) :deadline)))
+      (set-nth! best 0 cand))))
+
+;; Deliver a fired timer's message to its destination and retire it.
+;; Destination is resolved at fire time; a dead/missing target (or an
+;; unregistered name) silently drops the message, as in real Erlang.
+(define
+  er-timer-fire!
+  (fn
+    (t)
+    (dict-set! t :alive false)
+    (let
+      ((pid (er-timer-resolve-dest (get t :dest))))
+      (when
+        (and (not (= pid nil)) (er-proc-exists? pid))
+        (er-proc-mailbox-push! pid (get t :msg))
+        (when
+          (= (er-proc-field pid :state) "waiting")
+          (er-proc-set! pid :state "runnable")
+          (er-sched-enqueue! pid))))))
+
+;; Non-raising destination resolver for timer delivery.
+(define
+  er-timer-resolve-dest
+  (fn
+    (v)
+    (cond
+      (er-pid? v) v
+      (er-atom? v)
+      (let
+        ((name (get v :name)))
+        (if (dict-has? (er-registered) name) (get (er-registered) name) nil))
+      :else nil)))
+
+;; Wake a process whose `receive ... after Ms` deadline elapsed.
+(define
+  er-recv-timeout-fire!
+  (fn
+    (p)
+    (dict-set! p :timed-out true)
+    (dict-set! p :has-timeout false)
+    (dict-set! p :state "runnable")
+    (er-sched-enqueue! (get p :pid))))
 
 (define
   er-sched-step!
@@ -731,7 +932,10 @@
           0
           (if
             (= prev-k nil)
-            (er-apply-fun (er-proc-field pid :initial-fun) (list))
+            (er-apply-fun
+              (er-proc-field pid :initial-fun)
+              (let ((args (er-proc-field pid :pending-args)))
+                (cond (= args nil) (list) :else args)))
             (do (er-proc-set! pid :continuation nil) (prev-k nil)))))
       (let
         ((r (nth result-ref 0)))
@@ -956,8 +1160,118 @@
         (= ty "nil") (er-mk-nil)
         :else v))))
 
+;; ── HTTP request/response marshaling (Step 8b-start) ────────────
+;; The native `http-listen` primitive hands the handler an SX dict
+;;   {:method :path :query :headers :body}
+;; and expects an SX dict back
+;;   {:status :headers :body}
+;; This layer converts so Erlang handlers see proper proplists:
+;;   [{method, <<"GET">>}, {path, <<"/foo">>}, {query, <<>>},
+;;    {headers, [{<<"content-type">>, <<"text/plain">>}, ...]},
+;;    {body, <<...>>}]
+;; Headers ride as a nested proplist with binary keys — header names
+;; are arbitrary user input, so they stay out of the atom table. The
+;; outer request keys (method/path/query/headers/body) are fixed and
+;; small, so they become atoms (cheap to pattern-match against).
 
+(define er-of-sx-deep
+  (fn (v)
+    (cond
+      (= (type-of v) "dict") (er-dict-to-header-proplist v)
+      :else (er-of-sx v))))
 
+(define er-dict-to-header-proplist
+  (fn (d)
+    (let ((ks (keys d)) (out (er-mk-nil)))
+      (for-each
+        (fn (i)
+          (let ((idx (- (- (len ks) 1) i)))
+            (let ((k (nth ks idx)))
+              (let ((v (get d k)))
+                (set!
+                  out
+                  (er-mk-cons
+                    (er-mk-tuple
+                      (list
+                        (er-mk-binary (map char->integer (string->list k)))
+                        (er-of-sx-deep v)))
+                    out))))))
+        (range 0 (len ks)))
+      out)))
+
+(define er-request-dict-to-proplist
+  (fn (d)
+    (cond
+      (not (= (type-of d) "dict")) (er-of-sx d)
+      :else
+        (let ((ks (keys d)) (out (er-mk-nil)))
+          (for-each
+            (fn (i)
+              (let ((idx (- (- (len ks) 1) i)))
+                (let ((k (nth ks idx)))
+                  (let ((v (get d k)))
+                    (set!
+                      out
+                      (er-mk-cons
+                        (er-mk-tuple
+                          (list (er-mk-atom k) (er-of-sx-deep v)))
+                        out))))))
+            (range 0 (len ks)))
+          out))))
+
+;; Inverse: handler's proplist response -> SX dict for native send.
+;; Value rules:
+;;   Erlang binary   -> SX string (bytes joined)
+;;   Erlang integer  -> SX number passthrough
+;;   Erlang cons of 2-tuples -> nested SX dict (e.g. headers)
+;;   Erlang cons (other shapes) -> SX list via er-to-sx
+;;   anything else   -> er-to-sx passthrough
+
+(define er-proplist-2tuple?
+  (fn (v)
+    (cond
+      (er-nil? v) true
+      (er-cons? v)
+        (let ((h (get v :head)))
+          (cond
+            (and (er-tuple? h) (= (len (get h :elements)) 2))
+              (er-proplist-2tuple? (get v :tail))
+            :else false))
+      :else false)))
+
+(define er-to-sx-deep
+  (fn (v)
+    (cond
+      (er-binary? v) (list->string (map integer->char (get v :bytes)))
+      (and (er-cons? v) (er-proplist-2tuple? v)) (er-proplist-to-dict v)
+      :else (er-to-sx v))))
+
+(define er-proplist-to-dict
+  (fn (pl)
+    (let ((d (dict)))
+      (er-proplist-fill! pl d)
+      d)))
+
+(define er-proplist-fill!
+  (fn (pl d)
+    (cond
+      (er-nil? pl) nil
+      (er-cons? pl)
+        (let ((head (get pl :head)) (tail (get pl :tail)))
+          (cond
+            (and (er-tuple? head) (= (len (get head :elements)) 2))
+              (let ((kv (get head :elements)))
+                (let ((k (nth kv 0)) (v (nth kv 1)))
+                  (let ((key-str
+                          (cond
+                            (er-atom? k) (get k :name)
+                            (er-binary? k)
+                              (list->string (map integer->char (get k :bytes)))
+                            :else (str k))))
+                    (dict-set! d key-str (er-to-sx-deep v))
+                    (er-proplist-fill! tail d))))
+            :else (er-proplist-fill! tail d)))
+      :else nil)))
 
 ;; Load an Erlang module declaration. Source must start with
 ;; `-module(Name).` and contain function definitions. Functions
@@ -1064,8 +1378,15 @@
            {reply, Reply, NewState} ->
              From ! {Ref, Reply},
              gen_server:loop(Mod, NewState);
+           {reply, Reply, NewState, Timeout} ->
+             From ! {Ref, Reply},
+             erlang:send_after(Timeout, self(), {timeout}),
+             gen_server:loop(Mod, NewState);
            {noreply, NewState} ->
              gen_server:loop(Mod, NewState);
+           {noreply, NewState, Timeout} ->
+             erlang:send_after(Timeout, self(), {timeout}),
+             gen_server:loop(Mod, NewState);
            {stop, Reason, Reply, NewState} ->
              From ! {Ref, Reply},
              exit(Reason)
@@ -1073,11 +1394,17 @@
        {'$gen_cast', Msg} ->
          case Mod:handle_cast(Msg, State) of
            {noreply, NewState} -> gen_server:loop(Mod, NewState);
+           {noreply, NewState, Timeout} ->
+             erlang:send_after(Timeout, self(), {timeout}),
+             gen_server:loop(Mod, NewState);
            {stop, Reason, NewState} -> exit(Reason)
          end;
        Other ->
          case Mod:handle_info(Other, State) of
            {noreply, NewState} -> gen_server:loop(Mod, NewState);
+           {noreply, NewState, Timeout} ->
+             erlang:send_after(Timeout, self(), {timeout}),
+             gen_server:loop(Mod, NewState);
            {stop, Reason, NewState} -> exit(Reason)
          end
      end.")
@@ -1468,9 +1795,141 @@
 ;; entry is keyed by "Module/Name/Arity"; multi-arity BIFs register
 ;; once per arity. Called eagerly at the end of runtime.sx so the
 ;; registry is ready before any erlang-eval-ast call.
-(define er-register-builtin-bifs!
+(define
-  (fn ()
+  er-bif-http-listen
-    ;; erlang module — type predicates (all pure)
+  (fn
+    (vs)
+    (let
+      ((port (nth vs 0)) (handler (nth vs 1)))
+      (cond
+        (not (= (type-of port) "number"))
+        (raise (er-mk-error-marker (er-mk-atom "badarg")))
+        (not (er-fun? handler))
+        (raise (er-mk-error-marker (er-mk-atom "badarg")))
+        :else (let
+          ;; Bridge between native http-listen and Erlang handler.
+          ;;
+          ;; Inbound: native passes Req as SX Dict
+          ;;   {:method :path :query :headers :body}
+          ;; converted to Erlang request proplist via the live
+          ;; er-request-dict-to-proplist marshaller — that's the
+          ;; same shape http_server:route/2 consumes (binaries
+          ;; for path/method/body, dict-like proplist for headers).
+          ;;
+          ;; Outbound: Erlang handler returns
+          ;;   [{status, Int}, {headers, [{Bin, Bin}, ...]}, {body, Bin}]
+          ;; converted back to SX Dict via er-proplist-to-dict —
+          ;; binary values become SX strings, the headers cons
+          ;; flattens to a nested SX dict (via er-to-sx-deep's
+          ;; proplist-2tuple detection). Matches what native
+          ;; http-listen serialises to the wire.
+          ;;
+          ;; (Step 8b-bridge originally shipped parallel
+          ;; er-http-req-of-sx / er-http-resp-to-sx helpers; commit
+          ;; 78eae9ef deleted them as dead because the BIF body
+          ;; still referenced them — Blockers #1. This rewrite
+          ;; threads through the live marshallers instead.)
+          ;; Run the handler as a SCHEDULED er-process so any
+          ;; `receive` (e.g. gen_server:call inside a kernel-aware
+          ;; route) suspends and resumes inside the SX scheduler.
+          ;; Without this, native http-listen invokes the handler
+          ;; closure on a fresh OCaml thread that has no scheduler
+          ;; frame, so the receive's er-suspend-marker propagates
+          ;; out and the connection writes nothing — the Blockers
+          ;; #4 deadlock the m2 loop observed.
+          ;;
+          ;; er-spawn-fun requires an er-fun (Erlang-AST-shaped
+          ;; dict); handler IS one (created by user `fun (Req) ->
+          ;; route(Req, Cfg) end`). To feed req-pl as the call
+          ;; argument we stash it on the process record's
+          ;; :pending-args field — er-sched-step-alive! reads it
+          ;; on first step (the alternative was a host-closure-to-
+          ;; er-fun wrapper, which needs AST construction).
+          ((sx-handler
+             (fn (req-dict)
+               (let ((req-pl (er-request-dict-to-proplist req-dict)))
+                 (let ((proc (er-proc-new! (er-env-new))))
+                   (dict-set! proc :initial-fun handler)
+                   (dict-set! proc :pending-args (list req-pl))
+                   (er-sched-run-all!)
+                   (let ((resp-pl (er-proc-field (get proc :pid) :exit-result)))
+                     (er-proplist-to-dict resp-pl)))))))
+          (http-listen port sx-handler))))))
+
+;; httpc:request/4(Url, Method, Headers, Body) - BRIEFING-EXCEPTION:
+;; the m2 briefing's one allowed scope exception for Step 8e, mirroring
+;; M1 Step 8a's http:listen wrapper on the client side.
+;;
+;; Url is an Erlang binary (must start with http://).
+;; Method is an Erlang atom or binary; passed through to the native
+;; verbatim, so callers should supply 'get / 'post or <<"GET">> as
+;; appropriate (the native compares uppercase).
+;; Headers is an Erlang proplist [{Name, Value}, ...]; names and
+;; values are binaries or atoms (er-proplist-to-dict handles both).
+;; Body is an Erlang binary (use <<>> for empty).
+;;
+;; Returns a 4-tuple {ok, StatusInt, HeadersProplist, BodyBinary}.
+;; The native primitive raises Eval_error on DNS / connect / bad URL;
+;; we catch the host exception here and re-raise as an Erlang error
+;; marker so callers can use try/catch error:{network, _} -> _ end.
+(define
+  er-bif-httpc-request
+  (fn
+    (vs)
+    (let
+      ((url     (nth vs 0))
+       (method  (nth vs 1))
+       (headers (nth vs 2))
+       (body    (nth vs 3)))
+      (let
+        ((url-str
+           (cond
+             (er-binary? url) (list->string (map integer->char (get url :bytes)))
+             :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))
+         (method-str
+           (cond
+             ;; Erlang convention is lowercase atoms (get/post/put/...);
+             ;; the HTTP wire wants uppercase. Binaries pass through so
+             ;; callers can override with mixed-case verbs if needed.
+             (er-atom? method)   (upcase (get method :name))
+             (er-binary? method) (list->string (map integer->char (get method :bytes)))
+             :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))
+         (headers-dict
+           (cond
+             (er-nil? headers)  (dict)
+             (er-cons? headers) (er-proplist-to-dict headers)
+             :else (raise (er-mk-error-marker (er-mk-atom "badarg")))))
+         (body-str
+           (cond
+             (er-binary? body) (list->string (map integer->char (get body :bytes)))
+             (er-nil? body)    ""
+             :else (raise (er-mk-error-marker (er-mk-atom "badarg"))))))
+        (let ((resp-ref (list nil)) (err-ref (list nil)))
+          (guard (c (:else (set-nth! err-ref 0 c)))
+            (set-nth! resp-ref 0
+              (http-request method-str url-str headers-dict body-str)))
+          (cond
+            (not (= (nth err-ref 0) nil))
+              ;; Host error -> Erlang error:{network, ReasonBinary}
+              (raise (er-mk-error-marker
+                (er-mk-tuple (list
+                  (er-mk-atom "network")
+                  (er-mk-binary (map char->integer
+                    (string->list (str (nth err-ref 0)))))))))
+            :else
+              (let ((resp (nth resp-ref 0)))
+                (er-mk-tuple
+                  (list
+                    (er-mk-atom "ok")
+                    (get resp :status)
+                    (er-of-sx-deep (get resp :headers))
+                    (er-mk-binary (map char->integer (string->list (get resp :body)))))))))))))
+
+;; Register everything at load time.
+(define
+  er-register-builtin-bifs!
+  (fn
+    ()
     (er-register-pure-bif! "erlang" "is_integer" 1 er-bif-is-integer)
     (er-register-pure-bif! "erlang" "is_atom" 1 er-bif-is-atom)
     (er-register-pure-bif! "erlang" "is_list" 1 er-bif-is-list)
@@ -1479,33 +1938,71 @@
     (er-register-pure-bif! "erlang" "is_float" 1 er-bif-is-float)
     (er-register-pure-bif! "erlang" "is_boolean" 1 er-bif-is-boolean)
     (er-register-pure-bif! "erlang" "is_pid" 1 er-bif-is-pid)
-    (er-register-pure-bif! "erlang" "is_reference" 1 er-bif-is-reference)
+    (er-register-pure-bif!
+      "erlang"
+      "is_reference"
+      1
+      er-bif-is-reference)
     (er-register-pure-bif! "erlang" "is_binary" 1 er-bif-is-binary)
-    (er-register-pure-bif! "erlang" "is_function" 1 er-bif-is-function)
+    (er-register-pure-bif!
-    (er-register-pure-bif! "erlang" "is_function" 2 er-bif-is-function)
+      "erlang"
-    ;; erlang module — pure data ops
+      "is_function"
+      1
+      er-bif-is-function)
+    (er-register-pure-bif!
+      "erlang"
+      "is_function"
+      2
+      er-bif-is-function)
     (er-register-pure-bif! "erlang" "length" 1 er-bif-length)
     (er-register-pure-bif! "erlang" "hd" 1 er-bif-hd)
     (er-register-pure-bif! "erlang" "tl" 1 er-bif-tl)
     (er-register-pure-bif! "erlang" "element" 2 er-bif-element)
     (er-register-pure-bif! "erlang" "tuple_size" 1 er-bif-tuple-size)
     (er-register-pure-bif! "erlang" "byte_size" 1 er-bif-byte-size)
-    (er-register-pure-bif! "erlang" "atom_to_list" 1 er-bif-atom-to-list)
+    (er-register-pure-bif!
-    (er-register-pure-bif! "erlang" "list_to_atom" 1 er-bif-list-to-atom)
+      "erlang"
+      "atom_to_list"
+      1
+      er-bif-atom-to-list)
+    (er-register-pure-bif!
+      "erlang"
+      "list_to_atom"
+      1
+      er-bif-list-to-atom)
     (er-register-pure-bif! "erlang" "abs" 1 er-bif-abs)
     (er-register-pure-bif! "erlang" "min" 2 er-bif-min)
     (er-register-pure-bif! "erlang" "max" 2 er-bif-max)
-    (er-register-pure-bif! "erlang" "tuple_to_list" 1 er-bif-tuple-to-list)
+    (er-register-pure-bif!
-    (er-register-pure-bif! "erlang" "list_to_tuple" 1 er-bif-list-to-tuple)
+      "erlang"
-    (er-register-pure-bif! "erlang" "integer_to_list" 1 er-bif-integer-to-list)
+      "tuple_to_list"
-    (er-register-pure-bif! "erlang" "list_to_integer" 1 er-bif-list-to-integer)
+      1
-    ;; erlang module — process / runtime (side-effecting)
+      er-bif-tuple-to-list)
+    (er-register-pure-bif!
+      "erlang"
+      "list_to_tuple"
+      1
+      er-bif-list-to-tuple)
+    (er-register-pure-bif!
+      "erlang"
+      "integer_to_list"
+      1
+      er-bif-integer-to-list)
+    (er-register-pure-bif!
+      "erlang"
+      "list_to_integer"
+      1
+      er-bif-list-to-integer)
     (er-register-bif! "erlang" "self" 0 er-bif-self)
     (er-register-bif! "erlang" "spawn" 1 er-bif-spawn)
     (er-register-bif! "erlang" "spawn" 3 er-bif-spawn)
     (er-register-bif! "erlang" "exit" 1 er-bif-exit)
     (er-register-bif! "erlang" "exit" 2 er-bif-exit)
     (er-register-bif! "erlang" "make_ref" 0 er-bif-make-ref)
+    (er-register-bif! "erlang" "send_after" 3 er-bif-send-after)
+    (er-register-bif! "erlang" "cancel_timer" 1 er-bif-cancel-timer)
+    (er-register-bif! "erlang" "monotonic_time" 0 er-bif-monotonic-time)
+    (er-register-bif! "erlang" "monotonic_time" 1 er-bif-monotonic-time)
     (er-register-bif! "erlang" "link" 1 er-bif-link)
     (er-register-bif! "erlang" "unlink" 1 er-bif-unlink)
     (er-register-bif! "erlang" "monitor" 2 er-bif-monitor)
@@ -1515,12 +2012,16 @@
     (er-register-bif! "erlang" "unregister" 1 er-bif-unregister)
     (er-register-bif! "erlang" "whereis" 1 er-bif-whereis)
     (er-register-bif! "erlang" "registered" 0 er-bif-registered)
-    ;; erlang module — exception raising (modelled as side-effecting)
+    (er-register-bif!
-    (er-register-bif! "erlang" "throw" 1
+      "erlang"
+      "throw"
+      1
       (fn (vs) (raise (er-mk-throw-marker (er-bif-arg1 vs "throw")))))
-    (er-register-bif! "erlang" "error" 1
+    (er-register-bif!
+      "erlang"
+      "error"
+      1
       (fn (vs) (raise (er-mk-error-marker (er-bif-arg1 vs "error")))))
-    ;; lists module — all pure
     (er-register-pure-bif! "lists" "reverse" 1 er-bif-lists-reverse)
     (er-register-pure-bif! "lists" "map" 2 er-bif-lists-map)
     (er-register-pure-bif! "lists" "foldl" 3 er-bif-lists-foldl)
@@ -1534,11 +2035,13 @@
     (er-register-pure-bif! "lists" "filter" 2 er-bif-lists-filter)
     (er-register-pure-bif! "lists" "any" 2 er-bif-lists-any)
     (er-register-pure-bif! "lists" "all" 2 er-bif-lists-all)
-    (er-register-pure-bif! "lists" "duplicate" 2 er-bif-lists-duplicate)
+    (er-register-pure-bif!
-    ;; io module — side-effecting (writes to io buffer)
+      "lists"
+      "duplicate"
+      2
+      er-bif-lists-duplicate)
     (er-register-bif! "io" "format" 1 er-bif-io-format)
     (er-register-bif! "io" "format" 2 er-bif-io-format)
-    ;; ets module — side-effecting (mutates table state)
     (er-register-bif! "ets" "new" 2 er-bif-ets-new)
     (er-register-bif! "ets" "insert" 2 er-bif-ets-insert)
     (er-register-bif! "ets" "lookup" 2 er-bif-ets-lookup)
@@ -1546,18 +2049,15 @@
     (er-register-bif! "ets" "delete" 2 er-bif-ets-delete)
     (er-register-bif! "ets" "tab2list" 1 er-bif-ets-tab2list)
     (er-register-bif! "ets" "info" 2 er-bif-ets-info)
-    ;; code module — side-effecting (mutates module registry, kills procs)
     (er-register-bif! "code" "load_binary" 3 er-bif-code-load-binary)
     (er-register-bif! "code" "purge" 1 er-bif-code-purge)
     (er-register-bif! "code" "soft_purge" 1 er-bif-code-soft-purge)
     (er-register-bif! "code" "which" 1 er-bif-code-which)
     (er-register-bif! "code" "is_loaded" 1 er-bif-code-is-loaded)
     (er-register-bif! "code" "all_loaded" 0 er-bif-code-all-loaded)
-    ;; file module
     (er-register-bif! "file" "read_file" 1 er-bif-file-read-file)
     (er-register-bif! "file" "write_file" 2 er-bif-file-write-file)
     (er-register-bif! "file" "delete" 1 er-bif-file-delete)
-    ;; Phase 8 FFI — host-primitive BIFs (loops/fed-prims)
     (er-register-pure-bif! "crypto" "hash" 2 er-bif-crypto-hash)
     (er-register-pure-bif! "cid" "from_bytes" 1 er-bif-cid-from-bytes)
     (er-register-pure-bif! "cid" "to_string" 1 er-bif-cid-to-string)
@@ -1623,5 +2123,11 @@
     (er-register-pure-bif! "erlang" "list_to_binary"  1 er-bif-list-to-binary)
     (er-mk-atom "ok")))
 
+;; ── m2 federation BIFs (top-level registration; defs above) ─────
+(er-register-bif! "http" "listen" 2 er-bif-http-listen)
+(er-register-bif! "httpc" "request" 4 er-bif-httpc-request)
+
 ;; Register everything at load time.
+(jit-exclude! "er-*" "erlang-*")
+
 (er-register-builtin-bifs!)

lib/erlang/scoreboard.json

@@ -1,7 +1,7 @@
 {
   "language": "erlang",
-  "total_pass": 761,
+  "total_pass": 771,
-  "total": 761,
+  "total": 771,
   "suites": [
     {"name":"tokenize","pass":62,"total":62,"status":"ok"},
     {"name":"parse","pass":52,"total":52,"status":"ok"},
@@ -13,6 +13,7 @@
     {"name":"echo","pass":7,"total":7,"status":"ok"},
     {"name":"fib","pass":8,"total":8,"status":"ok"},
     {"name":"ffi","pass":37,"total":37,"status":"ok"},
-    {"name":"vm","pass":78,"total":78,"status":"ok"}
+    {"name":"vm","pass":78,"total":78,"status":"ok"},
+    {"name":"send_after","pass":10,"total":10,"status":"ok"}
   ]
 }

lib/erlang/scoreboard.md

@@ -1,6 +1,6 @@
 # Erlang-on-SX Scoreboard
 
-**Total: 761 / 761 tests passing**
+**Total: 771 / 771 tests passing**
 
 |  | Suite | Pass | Total |
 |---|---|---|---|
@@ -15,5 +15,6 @@
 | ✅ | fib | 8 | 8 |
 | ✅ | ffi | 37 | 37 |
 | ✅ | vm | 78 | 78 |
+| ✅ | send_after | 10 | 10 |
 
 Generated by `lib/erlang/conformance.sh`.

lib/erlang/tests/send_after.sx

@@ -0,0 +1,163 @@
+;; erlang:send_after / cancel_timer — timer primitives.
+;;
+;; A process schedules a message to itself (or another pid / registered
+;; name) after N logical milliseconds. `cancel_timer` removes a pending
+;; timer and reports the time left. These are the same primitives the
+;; gen_server library uses to implement `{noreply, State, Timeout}`.
+;;
+;; The scheduler runs a synchronous logical clock (see runtime.sx
+;; `er-sched-advance-time!`): time advances only when the runnable
+;; queue drains, jumping to the earliest pending deadline. That makes
+;; delivery deterministic and time-travel-safe — no wall clock.
+
+(define er-sa-test-count 0)
+(define er-sa-test-pass 0)
+(define er-sa-test-fails (list))
+
+(define
+  er-sa-test
+  (fn
+    (name actual expected)
+    (set! er-sa-test-count (+ er-sa-test-count 1))
+    (if
+      (= actual expected)
+      (set! er-sa-test-pass (+ er-sa-test-pass 1))
+      (append!
+        er-sa-test-fails
+        {:actual actual :expected expected :name name}))))
+
+(define er-sa-pred
+  (fn (name actual) (er-sa-test name (if actual true false) true)))
+
+(define sa-ev erlang-eval-ast)
+
+;; ── T1 — schedule a self-message, receive it after the deadline ──
+;; send_after returns a reference handle.
+(er-sa-pred
+  "T1 send_after returns a ref"
+  (er-ref?
+    (sa-ev "erlang:send_after(50, self(), hello)")))
+
+;; The scheduled message lands and a plain receive picks it up.
+(er-sa-test
+  "T1 delivered message received"
+  (get
+    (sa-ev
+      "erlang:send_after(50, self(), hello),
+       receive M -> M end")
+    :name)
+  "hello")
+
+;; Logical time advances exactly to the timer deadline (50ms) by the
+;; time the message is received — round-trip latency well under 100ms.
+(er-sa-test
+  "T1 clock at deadline on receipt"
+  (sa-ev
+    "erlang:send_after(50, self(), hello),
+     receive hello -> erlang:monotonic_time() end")
+  50)
+
+;; ── T2 — cancel_timer returns remaining ms; message never arrives ──
+;; Cancel immediately after scheduling: clock has not advanced, so the
+;; full duration (~1000ms) is reported as remaining.
+(er-sa-test
+  "T2 cancel returns remaining ms"
+  (sa-ev
+    "Ref = erlang:send_after(1000, self(), late),
+     erlang:cancel_timer(Ref)")
+  1000)
+
+;; The cancelled timer never delivers — the receive falls through to
+;; its `after` clause and returns `none`.
+(er-sa-test
+  "T2 cancelled message never arrives"
+  (get
+    (sa-ev
+      "Ref = erlang:send_after(1000, self(), late),
+       erlang:cancel_timer(Ref),
+       receive late -> got after 50 -> none end")
+    :name)
+  "none")
+
+;; ── T3 — multiple timers fire in deadline order, not schedule order ──
+;; `b` is scheduled first (deadline 80) but `a` second (deadline 20).
+;; Two plain receives drain the mailbox in arrival order — and arrival
+;; is governed by deadline, so the first message out is `a`.
+(er-sa-test
+  "T3 timers fire in deadline order"
+  (er-format-value
+    (sa-ev
+      "erlang:send_after(80, self(), b),
+       erlang:send_after(20, self(), a),
+       X = receive M1 -> M1 end,
+       Y = receive M2 -> M2 end,
+       {X, Y}"))
+  "{a,b}")
+
+;; A selective receive on `a` matches the earlier-deadline timer even
+;; though `b` was scheduled first.
+(er-sa-test
+  "T3 selective receive picks earliest deadline"
+  (get
+    (sa-ev
+      "erlang:send_after(80, self(), b),
+       erlang:send_after(20, self(), a),
+       receive a -> first end")
+    :name)
+  "first")
+
+;; ── T4 — cancel_timer on an already-fired timer returns false ──────
+;; Once `x` has been received the timer has fired; cancelling its ref
+;; now yields the atom `false`.
+(er-sa-test
+  "T4 cancel of fired timer is false"
+  (get
+    (sa-ev
+      "Ref = erlang:send_after(20, self(), x),
+       receive x -> ok end,
+       erlang:cancel_timer(Ref)")
+    :name)
+  "false")
+
+;; ── T5 — send_after to a registered atom name ──────────────────────
+;; A second process registers itself as `srv`; the timer addresses it
+;; by name, and the delayed message lands in that process's mailbox.
+;; The server forwards what it got back to the parent for inspection.
+(er-sa-test
+  "T5 timer delivers to registered name"
+  (get
+    (sa-ev
+      "Me = self(),
+       Pid = spawn(fun () -> receive M -> Me ! {got, M} end end),
+       register(srv, Pid),
+       erlang:send_after(20, srv, ping),
+       receive {got, X} -> X end")
+    :name)
+  "ping")
+
+;; ── T6 — gen_server {noreply, State, Timeout} hookup ───────────────
+;; A gen_server that, on the `arm` cast, returns {noreply, S, 100}.
+;; The library schedules {timeout} to itself via send_after; when no
+;; other message arrives first, handle_info({timeout}, S) fires. The
+;; handler signals the parent so we can confirm the timeout landed.
+(do
+  (er-load-gen-server!)
+  (erlang-load-module
+    "-module(sa_tmo).
+     init(Me) -> {ok, Me}.
+     handle_call(_R, _F, S) -> {reply, ok, S}.
+     handle_cast(arm, Me) -> {noreply, Me, 100}.
+     handle_info({timeout}, Me) -> Me ! fired, {noreply, Me};
+     handle_info(_M, S) -> {noreply, S}.")
+  nil)
+
+(er-sa-test
+  "T6 gen_server timeout fires handle_info"
+  (get
+    (sa-ev
+      "Me = self(),
+       P = gen_server:start_link(sa_tmo, Me),
+       gen_server:cast(P, arm),
+       receive fired -> ok after 5000 -> timeout end")
+    :name)
+  "ok")

lib/erlang/transpile.sx

@@ -1147,7 +1147,7 @@
         (and (er-atom? ms) (= (get ms :name) "infinity"))
         (er-eval-receive-loop node pid env)
         (= ms 0) (er-eval-receive-poll node pid env)
-        :else (er-eval-receive-timed node pid env)))))
+        :else (er-eval-receive-timed node pid env (+ (er-clock) ms))))))
 
 ;; after 0 — poll once; on no match, run the after-body immediately.
 (define
@@ -1161,12 +1161,15 @@
         (get r :value)
         (er-eval-body (get node :after-body) env)))))
 
-;; after Ms — suspend; on resume check :timed-out. When the scheduler
+;; after Ms — suspend with an absolute `deadline` (logical ms). On
-;; runs out of other work it fires one pending timeout per round.
+;; resume check :timed-out: the scheduler fires the earliest pending
+;; deadline once the runnable queue drains. A non-matching message can
+;; wake the process early; it re-suspends on the SAME deadline so the
+;; timeout window is not extended.
 (define
   er-eval-receive-timed
   (fn
-    (node pid env)
+    (node pid env deadline)
     (let
       ((r (er-try-receive (get node :clauses) pid env)))
       (if
@@ -1174,6 +1177,7 @@
         (get r :value)
         (do
           (er-proc-set! pid :has-timeout true)
+          (er-proc-set! pid :timeout-deadline deadline)
           (call/cc
             (fn
               (k)
@@ -1186,7 +1190,7 @@
               (er-proc-set! pid :timed-out false)
               (er-proc-set! pid :has-timeout false)
               (er-eval-body (get node :after-body) env))
-            (er-eval-receive-timed node pid env)))))))
+            (er-eval-receive-timed node pid env deadline)))))))
 
 ;; Scan mailbox in arrival order. For each msg, try every clause.
 ;; On first match: remove that msg from mailbox and return body value.

lib/events/api.sx

@@ -275,3 +275,55 @@
       ((ev/would-time-conflict? b store actor occ)
         {:status :time-conflict :actor actor :occ-key (ev-occ-key occ)})
       (else (ev/book-occ! b store actor occ)))))
+
+;; ---- whole-series operations ----
+;; Apply a booking action to every occurrence of one event in [ws, we) — e.g.
+;; "RSVP to the whole weekly class". Returns a list of (occ-key status) results,
+;; one per occurrence (empty if the event id is unknown).
+(define
+  ev/book-series!
+  (fn
+    (b store actor event-id ws we)
+    (let
+      ((ev (ev/event-by-id store event-id)))
+      (if
+        (nil? ev)
+        (list)
+        (map
+          (fn (occ) (list (ev-occ-key occ) (get (ev/book-occ! b store actor occ) :status)))
+          (ev-expand ev ws we))))))
+
+;; Cancel `actor` from every occurrence of one event in [ws, we).
+(define
+  ev/cancel-series!
+  (fn
+    (b store actor event-id ws we)
+    (let
+      ((ev (ev/event-by-id store event-id)))
+      (if
+        (nil? ev)
+        (list)
+        (map
+          (fn (occ) (list (ev-occ-key occ) (get (ev/cancel! b (ev-occ-key occ) actor) :status)))
+          (ev-expand ev ws we))))))
+
+;; How many statuses in a series-result list equal `status`.
+(define
+  ev/series-count
+  (fn
+    (results status)
+    (len (filter (fn (r) (= (first (rest r)) status)) results))))
+
+;; The occurrences of one event in [ws, we) that `actor` is booked into.
+(define
+  ev/series-booked
+  (fn
+    (b store actor event-id ws we)
+    (let
+      ((ev (ev/event-by-id store event-id)))
+      (if
+        (nil? ev)
+        (list)
+        (filter
+          (fn (occ) (ev-actor-booked? b (ev-occ-key occ) actor))
+          (ev-expand ev ws we))))))

lib/events/conformance.conf

@@ -19,6 +19,7 @@ PRELOADS=(
   lib/datalog/magic.sx
   lib/events/calendar.sx
   lib/events/timezone.sx
+  lib/events/ical.sx
   lib/events/availability.sx
   lib/persist/event.sx
   lib/persist/backend.sx
@@ -49,6 +50,7 @@ PRELOADS=(
 SUITES=(
   "calendar:lib/events/tests/calendar.sx:(ev-calendar-tests-run!)"
   "timezone:lib/events/tests/timezone.sx:(ev-timezone-tests-run!)"
+  "ical:lib/events/tests/ical.sx:(ev-ical-tests-run!)"
   "availability:lib/events/tests/availability.sx:(ev-availability-tests-run!)"
   "api:lib/events/tests/api.sx:(ev-api-tests-run!)"
   "booking:lib/events/tests/booking.sx:(ev-booking-tests-run!)"

lib/events/ical.sx

@@ -0,0 +1,482 @@
+;; lib/events/ical.sx — iCalendar (RFC 5545) export.
+;;
+;; Serializes events to VEVENT / VCALENDAR text so a rose-ash calendar can be
+;; imported by any standard client (Google/Apple/Outlook). Datetimes are UTC
+;; epoch-minutes, emitted as basic-format UTC stamps (YYYYMMDDTHHMM00Z). The
+;; full RRULE / EXDATE / RDATE model maps directly to the standard properties.
+;;
+;; Export is line-oriented: `ev/event->ical-lines` returns the VEVENT as a list
+;; of content lines (no folding/CRLF — easy to assert on); `ev/ical-render`
+;; joins lines with CRLF, the on-the-wire format. Requires calendar.sx.
+
+;; ---- formatting helpers ----
+
+(define ev-ical-pad2 (fn (n) (if (< n 10) (str "0" n) (str n))))
+
+(define
+  ev-ical-pad4
+  (fn
+    (n)
+    (cond
+      ((< n 10) (str "000" n))
+      ((< n 100) (str "00" n))
+      ((< n 1000) (str "0" n))
+      (else (str n)))))
+
+(define
+  ev-ical-nth
+  (fn
+    (xs i)
+    (if
+      (= i 0)
+      (first xs)
+      (ev-ical-nth (rest xs) (- i 1)))))
+
+(define
+  ev-ical-join
+  (fn
+    (parts sep)
+    (if
+      (empty? parts)
+      ""
+      (reduce (fn (acc p) (str acc sep p)) (first parts) (rest parts)))))
+
+;; An epoch-minute as an iCal basic-format stamp (no zone suffix).
+(define
+  ev-ical-dt-stamp
+  (fn
+    (t)
+    (let
+      ((civ (ev-dt->civil t)) (tod (ev-dt-tod t)))
+      (str
+        (ev-ical-pad4 (ev-civ-y civ))
+        (ev-ical-pad2 (ev-civ-m civ))
+        (ev-ical-pad2 (ev-civ-d civ))
+        "T"
+        (ev-ical-pad2 (quotient tod 60))
+        (ev-ical-pad2 (modulo tod 60))
+        "00"))))
+
+;; A UTC epoch-minute as a UTC stamp (trailing Z).
+(define ev-ical-dt (fn (t) (str (ev-ical-dt-stamp t) "Z")))
+
+;; A local epoch-minute as a floating/local stamp (no Z) — used with TZID.
+(define ev-ical-dt-local ev-ical-dt-stamp)
+
+;; A UTC offset in minutes as "+HHMM" / "-HHMM".
+(define
+  ev-ical-offset
+  (fn
+    (mins)
+    (let
+      ((a (abs mins)))
+      (str
+        (if (< mins 0) "-" "+")
+        (ev-ical-pad2 (quotient a 60))
+        (ev-ical-pad2 (modulo a 60))))))
+
+;; A duration in minutes as an iCal DURATION value (PT#H#M).
+(define
+  ev-ical-duration
+  (fn
+    (mins)
+    (let
+      ((h (quotient mins 60)) (m (modulo mins 60)))
+      (cond
+        ((and (> h 0) (> m 0)) (str "PT" h "H" m "M"))
+        ((> h 0) (str "PT" h "H"))
+        (else (str "PT" m "M"))))))
+
+(define
+  ev-ical-wd
+  (fn (w) (ev-ical-nth (list "MO" "TU" "WE" "TH" "FR" "SA" "SU") w)))
+
+(define
+  ev-ical-freq
+  (fn
+    (f)
+    (cond
+      ((= f :daily) "DAILY")
+      ((= f :weekly) "WEEKLY")
+      ((= f :monthly) "MONTHLY")
+      (else "DAILY"))))
+
+;; One BYDAY token: a weekly weekday number -> "MO"; a monthly ordinal weekday
+;; {:ord :wd} -> "2TU" / "-1FR".
+(define
+  ev-ical-byday-token
+  (fn
+    (e)
+    (if
+      (dict? e)
+      (str (get e :ord) (ev-ical-wd (get e :wd)))
+      (ev-ical-wd e))))
+
+;; UNTIL converter: per RFC 5545, even a TZID DTSTART requires UNTIL in UTC, so
+;; a tz event converts its (local) UNTIL to UTC; a non-tz event passes through.
+(define
+  ev-ical-conv
+  (fn
+    (event)
+    (let
+      ((tz (get event :tz)))
+      (if (nil? tz) (fn (t) t) (fn (t) (ev-tz-local->utc tz t))))))
+
+;; ---- VTIMEZONE ----
+;; A tz event exports DTSTART;TZID=<name>:<local time> and the VCALENDAR carries
+;; a VTIMEZONE block defining the zone's DST rules, so a client recurs at a
+;; fixed WALL-CLOCK time (DST-correct) rather than fixed UTC.
+
+;; A DST transition rule -> "FREQ=YEARLY;BYMONTH=<m>;BYDAY=<ord><WD>".
+(define
+  ev-ical-vtz-rrule
+  (fn
+    (rule)
+    (str
+      "FREQ=YEARLY;BYMONTH="
+      (get rule :month)
+      ";BYDAY="
+      (get rule :ord)
+      (ev-ical-wd (get rule :wd)))))
+
+;; The transition's DTSTART (local time of the FROM offset) in a reference year.
+(define
+  ev-ical-vtz-dtstart
+  (fn
+    (rule from-offset)
+    (let
+      ((day (ev-resolve-nth-weekday 1970 (get rule :month) (get rule :ord) (get rule :wd))))
+      (ev-ical-dt-local
+        (+ (* (ev-days-from-civil 1970 (get rule :month) day) 1440)
+          (get rule :time)
+          from-offset)))))
+
+;; The VTIMEZONE content lines for a zone (DAYLIGHT + STANDARD for :dst; a
+;; single STANDARD for :fixed).
+(define
+  ev-ical-vtimezone
+  (fn
+    (tz)
+    (if
+      (= (get tz :kind) :dst)
+      (let
+        ((std (get tz :std-offset))
+          (dst (get tz :dst-offset))
+          (sr (get tz :dst-start))
+          (er (get tz :dst-end)))
+        (list
+          "BEGIN:VTIMEZONE"
+          (str "TZID:" (get tz :name))
+          "BEGIN:DAYLIGHT"
+          (str "DTSTART:" (ev-ical-vtz-dtstart sr std))
+          (str "TZOFFSETFROM:" (ev-ical-offset std))
+          (str "TZOFFSETTO:" (ev-ical-offset dst))
+          (str "RRULE:" (ev-ical-vtz-rrule sr))
+          "END:DAYLIGHT"
+          "BEGIN:STANDARD"
+          (str "DTSTART:" (ev-ical-vtz-dtstart er dst))
+          (str "TZOFFSETFROM:" (ev-ical-offset dst))
+          (str "TZOFFSETTO:" (ev-ical-offset std))
+          (str "RRULE:" (ev-ical-vtz-rrule er))
+          "END:STANDARD"
+          "END:VTIMEZONE"))
+      (list
+        "BEGIN:VTIMEZONE"
+        (str "TZID:" (get tz :name))
+        "BEGIN:STANDARD"
+        "DTSTART:19700101T000000"
+        (str "TZOFFSETFROM:" (ev-ical-offset (get tz :offset)))
+        (str "TZOFFSETTO:" (ev-ical-offset (get tz :offset)))
+        "END:STANDARD"
+        "END:VTIMEZONE"))))
+
+;; ---- RRULE ----
+(define
+  ev-ical-rrule
+  (fn
+    (rrule conv)
+    (let
+      ((parts (list (str "FREQ=" (ev-ical-freq (get rrule :freq))))))
+      (begin
+        (when
+          (and
+            (not (nil? (get rrule :interval)))
+            (> (get rrule :interval) 1))
+          (append! parts (str "INTERVAL=" (get rrule :interval))))
+        (when
+          (not (nil? (get rrule :count)))
+          (append! parts (str "COUNT=" (get rrule :count))))
+        (when
+          (not (nil? (get rrule :until)))
+          (append! parts (str "UNTIL=" (ev-ical-dt (conv (get rrule :until))))))
+        (when
+          (not (nil? (get rrule :byday)))
+          (append!
+            parts
+            (str
+              "BYDAY="
+              (ev-ical-join (map ev-ical-byday-token (get rrule :byday)) ","))))
+        (when
+          (not (nil? (get rrule :bymonthday)))
+          (append!
+            parts
+            (str
+              "BYMONTHDAY="
+              (ev-ical-join
+                (map (fn (d) (str d)) (get rrule :bymonthday))
+                ","))))
+        (str "RRULE:" (ev-ical-join parts ";"))))))
+
+;; ---- VEVENT / VCALENDAR ----
+
+;; The VEVENT content lines for an event (list of strings). A tz event uses
+;; DTSTART;TZID=<name>:<local> (matched by a VTIMEZONE at the VCALENDAR level)
+;; with EXDATE/RDATE in the same TZID-local form; UNTIL is always UTC. A non-tz
+;; event uses UTC `Z` stamps throughout.
+(define
+  ev/event->ical-lines
+  (fn
+    (event)
+    (let
+      ((lines (list "BEGIN:VEVENT"))
+        (conv (ev-ical-conv event))
+        (tz (get event :tz)))
+      (let
+        ((dtparam (if (nil? tz) "" (str ";TZID=" (get tz :name))))
+          (fmt (if (nil? tz) ev-ical-dt ev-ical-dt-local)))
+        (begin
+          (append! lines (str "UID:" (get event :id)))
+          (append! lines (str "SUMMARY:" (get event :id)))
+          (append! lines (str "DTSTART" dtparam ":" (fmt (get event :dtstart))))
+          (append!
+            lines
+            (str "DURATION:" (ev-ical-duration (get event :duration))))
+          (when
+            (not (nil? (get event :rrule)))
+            (append! lines (ev-ical-rrule (get event :rrule) conv)))
+          (when
+            (and
+              (not (nil? (get event :exdate)))
+              (> (len (get event :exdate)) 0))
+            (append!
+              lines
+              (str
+                "EXDATE"
+                dtparam
+                ":"
+                (ev-ical-join (map fmt (get event :exdate)) ","))))
+          (when
+            (and
+              (not (nil? (get event :rdate)))
+              (> (len (get event :rdate)) 0))
+            (append!
+              lines
+              (str
+                "RDATE"
+                dtparam
+                ":"
+                (ev-ical-join (map fmt (get event :rdate)) ","))))
+          (append! lines "END:VEVENT")
+          lines)))))
+
+;; Collect the distinct timezones used by a list of events (by :name).
+(define
+  ev-ical-distinct-tzs
+  (fn
+    (events)
+    (reduce
+      (fn
+        (acc ev)
+        (let
+          ((tz (get ev :tz)))
+          (if
+            (or (nil? tz) (ev-ical-tz-seen? acc (get tz :name)))
+            acc
+            (append acc (list tz)))))
+      (list)
+      events)))
+
+(define
+  ev-ical-tz-seen?
+  (fn
+    (tzs name)
+    (cond
+      ((empty? tzs) false)
+      ((= (get (first tzs) :name) name) true)
+      (else (ev-ical-tz-seen? (rest tzs) name)))))
+
+;; A full VCALENDAR (list of content lines): a VTIMEZONE block for each distinct
+;; zone the events reference, then every VEVENT.
+(define
+  ev/events->ical-lines
+  (fn
+    (events)
+    (let
+      ((lines (list "BEGIN:VCALENDAR" "VERSION:2.0" "PRODID:-//rose-ash//events-on-sx//EN")))
+      (begin
+        (for-each
+          (fn
+            (tz)
+            (for-each (fn (l) (append! lines l)) (ev-ical-vtimezone tz)))
+          (ev-ical-distinct-tzs events))
+        (for-each
+          (fn
+            (ev)
+            (for-each (fn (l) (append! lines l)) (ev/event->ical-lines ev)))
+          events)
+        (append! lines "END:VCALENDAR")
+        lines))))
+
+;; Render content lines to the on-the-wire iCalendar text (CRLF-separated).
+(define ev/ical-render (fn (lines) (ev-ical-join lines "\r\n")))
+
+;; ---- import (parse VEVENT/VCALENDAR back into events) ----
+;; Inverse of the export above: parse iCalendar content lines into event dicts
+;; (ev-event-full shape). Capacity is not an iCal property, so imported events
+;; default to capacity 0 — set it after import if needed.
+
+;; "20260601T180000Z" -> UTC epoch-minutes.
+(define
+  ev-ical-parse-dt
+  (fn
+    (s)
+    (ev-dt
+      (string->number (substring s 0 4))
+      (string->number (substring s 4 6))
+      (string->number (substring s 6 8))
+      (string->number (substring s 9 11))
+      (string->number (substring s 11 13)))))
+
+;; "30M" / "" -> minutes.
+(define
+  ev-ical-parse-min
+  (fn
+    (s)
+    (if (= (string-length s) 0) 0 (string->number (first (split s "M"))))))
+
+;; "PT1H30M" / "PT1H" / "PT30M" -> minutes.
+(define
+  ev-ical-parse-duration
+  (fn
+    (s)
+    (let
+      ((body (substring s 2 (string-length s))))
+      (let
+        ((hparts (split body "H")))
+        (if
+          (> (len hparts) 1)
+          (+ (* 60 (string->number (first hparts))) (ev-ical-parse-min (first (rest hparts))))
+          (ev-ical-parse-min body))))))
+
+(define
+  ev-ical-wd->num
+  (fn
+    (tok)
+    (cond
+      ((= tok "MO") 0)
+      ((= tok "TU") 1)
+      ((= tok "WE") 2)
+      ((= tok "TH") 3)
+      ((= tok "FR") 4)
+      ((= tok "SA") 5)
+      ((= tok "SU") 6)
+      (else 0))))
+
+;; "MO" -> 0 ; "2TU" -> {:ord 2 :wd 1} ; "-1FR" -> {:ord -1 :wd 4}
+(define
+  ev-ical-parse-byday-token
+  (fn
+    (tok)
+    (let
+      ((n (string-length tok)))
+      (if
+        (= n 2)
+        (ev-ical-wd->num tok)
+        {:ord (string->number (substring tok 0 (- n 2)))
+          :wd (ev-ical-wd->num (substring tok (- n 2) n))}))))
+
+(define
+  ev-ical-parse-freq
+  (fn
+    (v)
+    (cond
+      ((= v "DAILY") :daily)
+      ((= v "WEEKLY") :weekly)
+      ((= v "MONTHLY") :monthly)
+      (else :daily))))
+
+;; "FREQ=WEEKLY;INTERVAL=2;UNTIL=...;BYDAY=MO,WE" -> rrule dict.
+(define
+  ev-ical-parse-rrule
+  (fn
+    (val)
+    (let
+      ((rr {}))
+      (begin
+        (for-each
+          (fn
+            (p)
+            (let
+              ((kv (split p "=")))
+              (let
+                ((k (first kv)) (v (first (rest kv))))
+                (cond
+                  ((= k "FREQ") (dict-set! rr :freq (ev-ical-parse-freq v)))
+                  ((= k "INTERVAL") (dict-set! rr :interval (string->number v)))
+                  ((= k "COUNT") (dict-set! rr :count (string->number v)))
+                  ((= k "UNTIL") (dict-set! rr :until (ev-ical-parse-dt v)))
+                  ((= k "BYDAY") (dict-set! rr :byday (map ev-ical-parse-byday-token (split v ","))))
+                  ((= k "BYMONTHDAY") (dict-set! rr :bymonthday (map string->number (split v ","))))
+                  (else nil)))))
+          (split val ";"))
+        rr))))
+
+;; Parse a VEVENT's content lines into an event dict.
+(define
+  ev/ical-lines->event
+  (fn
+    (lines)
+    (let
+      ((ev {:capacity 0 :rrule nil}) (exd (list)) (rd (list)))
+      (begin
+        (for-each
+          (fn
+            (line)
+            (let
+              ((kv (split line ":")))
+              (when
+                (> (len kv) 1)
+                (let
+                  ;; strip any property parameters (e.g. ";TZID=...") from the key
+                  ((k (first (split (first kv) ";"))) (v (first (rest kv))))
+                  (cond
+                    ((= k "UID") (dict-set! ev :id (string->symbol v)))
+                    ((= k "DTSTART") (dict-set! ev :dtstart (ev-ical-parse-dt v)))
+                    ((= k "DURATION") (dict-set! ev :duration (ev-ical-parse-duration v)))
+                    ((= k "RRULE") (dict-set! ev :rrule (ev-ical-parse-rrule v)))
+                    ((= k "EXDATE") (set! exd (map ev-ical-parse-dt (split v ","))))
+                    ((= k "RDATE") (set! rd (map ev-ical-parse-dt (split v ","))))
+                    (else nil))))))
+          lines)
+        (dict-set! ev :exdate exd)
+        (dict-set! ev :rdate rd)
+        ev))))
+
+;; Split a VCALENDAR line list into per-VEVENT line groups.
+(define
+  ev-ical-group-vevents
+  (fn
+    (lines cur in acc)
+    (cond
+      ((empty? lines) acc)
+      ((= (first lines) "BEGIN:VEVENT") (ev-ical-group-vevents (rest lines) (list) true acc))
+      ((= (first lines) "END:VEVENT") (ev-ical-group-vevents (rest lines) (list) false (append acc (list cur))))
+      (in (ev-ical-group-vevents (rest lines) (append cur (list (first lines))) true acc))
+      (else (ev-ical-group-vevents (rest lines) cur false acc)))))
+
+;; Parse a VCALENDAR line list into a list of events.
+(define
+  ev/parse-vcalendar
+  (fn
+    (lines)
+    (map ev/ical-lines->event (ev-ical-group-vevents lines (list) false (list)))))

lib/events/scoreboard.json

@@ -1,13 +1,14 @@
 {
   "lang": "events",
-  "total_passed": 311,
+  "total_passed": 376,
   "total_failed": 0,
-  "total": 311,
+  "total": 376,
   "suites": [
     {"name":"calendar","passed":51,"failed":0,"total":51},
     {"name":"timezone","passed":17,"failed":0,"total":17},
+    {"name":"ical","passed":56,"failed":0,"total":56},
     {"name":"availability","passed":22,"failed":0,"total":22},
-    {"name":"api","passed":32,"failed":0,"total":32},
+    {"name":"api","passed":41,"failed":0,"total":41},
     {"name":"booking","passed":82,"failed":0,"total":82},
     {"name":"booking-notify","passed":11,"failed":0,"total":11},
     {"name":"ticket","passed":31,"failed":0,"total":31},
@@ -16,5 +17,5 @@
     {"name":"federation","passed":29,"failed":0,"total":29},
     {"name":"integration","passed":8,"failed":0,"total":8}
   ],
-  "generated": "2026-06-07T13:59:09+00:00"
+  "generated": "2026-06-07T20:02:48+00:00"
 }

lib/events/scoreboard.md

@@ -1,13 +1,14 @@
 # events scoreboard
 
-**311 / 311 passing** (0 failure(s)).
+**376 / 376 passing** (0 failure(s)).
 
 | Suite | Passed | Total | Status |
 |-------|--------|-------|--------|
 | calendar | 51 | 51 | ok |
 | timezone | 17 | 17 | ok |
+| ical | 56 | 56 | ok |
 | availability | 22 | 22 | ok |
-| api | 32 | 32 | ok |
+| api | 41 | 41 | ok |
 | booking | 82 | 82 | ok |
 | booking-notify | 11 | 11 | ok |
 | ticket | 31 | 31 | ok |

lib/events/tests/api.sx

@@ -319,6 +319,65 @@
             (ev/would-time-conflict? b store (quote zed) ob)
             false))))))
 
+;; ---- whole-series booking ----
+(define
+  ev-api-sr-run-all!
+  (fn
+    ()
+    (let
+      ((b (persist/open))
+        (store
+          (ev/schedule
+            (ev/empty)
+            (quote yoga)
+            (ev-dt 2026 6 1 18 0)
+            60
+            {:freq :weekly :byday (list 0 2) :count 4}
+            20))
+        (ws (ev-date 2026 6 1))
+        (we (ev-date 2026 7 1)))
+      (do
+        (let
+          ((res (ev/book-series! b store (quote nia) (quote yoga) ws we)))
+          (do
+            (ev-api-check! "series booking covers all four occurrences" (len res) 4)
+            (ev-api-check! "all occurrences booked" (ev/series-count res :booked) 4)
+            (ev-api-check!
+              "actor is now booked into the whole series"
+              (len (ev/series-booked b store (quote nia) (quote yoga) ws we))
+              4)))
+        ;; re-booking the series is idempotent
+        (ev-api-check!
+          "re-booking the series is idempotent"
+          (ev/series-count (ev/book-series! b store (quote nia) (quote yoga) ws we) :already)
+          4)
+        ;; cancel the whole series
+        (let
+          ((res (ev/cancel-series! b store (quote nia) (quote yoga) ws we)))
+          (do
+            (ev-api-check! "series cancel reports four cancellations" (ev/series-count res :cancelled) 4)
+            (ev-api-check!
+              "actor booked into nothing after series cancel"
+              (len (ev/series-booked b store (quote nia) (quote yoga) ws we))
+              0)))
+        ;; capacity interacts per-occurrence: fill one occurrence first
+        (let
+          ((b2 (persist/open))
+            (s2
+              (ev/schedule (ev/empty) (quote clinic) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 3} 1)))
+          (do
+            (ev/book-occ! b2 s2 (quote x) (ev-occ (quote clinic) (ev-dt 2026 6 2 9 0) 30))
+            (let
+              ((res (ev/book-series! b2 s2 (quote nia) (quote clinic) (ev-date 2026 6 1) (ev-date 2026 6 10))))
+              (do
+                (ev-api-check! "series booking succeeds on free occurrences" (ev/series-count res :booked) 2)
+                (ev-api-check! "series booking hits :full where capacity is taken" (ev/series-count res :full) 1)))))
+        ;; unknown event id
+        (ev-api-check!
+          "series booking an unknown event yields no results"
+          (ev/book-series! b store (quote nia) (quote nope) ws we)
+          (list))))))
+
 (define
   ev-api-tests-run!
   (fn
@@ -329,4 +388,5 @@
       (set! ev-api-failures (list))
       (ev-api-run-all!)
       (ev-api-cf-run-all!)
+      (ev-api-sr-run-all!)
       {:failures ev-api-failures :total (+ ev-api-pass ev-api-fail) :passed ev-api-pass :failed ev-api-fail})))

lib/events/tests/ical.sx

@@ -0,0 +1,387 @@
+;; lib/events/tests/ical.sx — iCalendar (RFC 5545) export.
+
+(define ev-ic-pass 0)
+(define ev-ic-fail 0)
+(define ev-ic-failures (list))
+
+(define
+  ev-ic-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! ev-ic-pass (+ ev-ic-pass 1))
+      (do
+        (set! ev-ic-fail (+ ev-ic-fail 1))
+        (append!
+          ev-ic-failures
+          (str name "\n    expected: " expected "\n    got:      " got))))))
+
+;; Find the value of a "KEY:value" line in a VEVENT line list (or nil).
+(define
+  ev-ic-line
+  (fn
+    (lines key)
+    (cond
+      ((empty? lines) nil)
+      ((ev-ic-prefix? (first lines) (str key ":")) (first lines))
+      (else (ev-ic-line (rest lines) key)))))
+
+(define
+  ev-ic-prefix?
+  (fn
+    (s p)
+    (and (>= (len s) (len p)) (= (substring s 0 (len p)) p))))
+
+(define
+  ev-ic-run-all!
+  (fn
+    ()
+    (do
+      (let
+        ((lines (ev/event->ical-lines (ev-event (quote one) (ev-dt 2026 6 10 14 0) 60 nil 1))))
+        (do
+          (ev-ic-check! "VEVENT opens" (first lines) "BEGIN:VEVENT")
+          (ev-ic-check! "VEVENT closes" (ev-ic-line lines "END") "END:VEVENT")
+          (ev-ic-check!
+            "UID is the event id"
+            (ev-ic-line lines "UID")
+            "UID:one")
+          (ev-ic-check!
+            "DTSTART is a UTC basic-format stamp"
+            (ev-ic-line lines "DTSTART")
+            "DTSTART:20260610T140000Z")
+          (ev-ic-check!
+            "DURATION of 60m is PT1H"
+            (ev-ic-line lines "DURATION")
+            "DURATION:PT1H")
+          (ev-ic-check!
+            "a one-off event has no RRULE"
+            (ev-ic-line lines "RRULE")
+            nil)))
+      (ev-ic-check!
+        "30m duration is PT30M"
+        (ev-ic-line
+          (ev/event->ical-lines
+            (ev-event
+              (quote e)
+              (ev-dt 2026 1 1 9 0)
+              30
+              nil
+              1))
+          "DURATION")
+        "DURATION:PT30M")
+      (ev-ic-check!
+        "90m duration is PT1H30M"
+        (ev-ic-line
+          (ev/event->ical-lines
+            (ev-event
+              (quote e)
+              (ev-dt 2026 1 1 9 0)
+              90
+              nil
+              1))
+          "DURATION")
+        "DURATION:PT1H30M")
+      (let
+        ((lines (ev/event->ical-lines (ev-event-full (quote yoga) (ev-dt 2026 6 1 18 0) 90 {:interval 2 :freq :weekly :until (ev-dt 2026 6 30 23 0) :byday (list 0 2)} 20 (list (ev-dt 2026 6 8 18 0)) (list (ev-dt 2026 6 20 18 0))))))
+        (do
+          (ev-ic-check!
+            "weekly RRULE serializes interval/until/byday in order"
+            (ev-ic-line lines "RRULE")
+            "RRULE:FREQ=WEEKLY;INTERVAL=2;UNTIL=20260630T230000Z;BYDAY=MO,WE")
+          (ev-ic-check!
+            "EXDATE line"
+            (ev-ic-line lines "EXDATE")
+            "EXDATE:20260608T180000Z")
+          (ev-ic-check!
+            "RDATE line"
+            (ev-ic-line lines "RDATE")
+            "RDATE:20260620T180000Z")))
+      (ev-ic-check!
+        "daily COUNT RRULE"
+        (ev-ic-line
+          (ev/event->ical-lines
+            (ev-event
+              (quote d)
+              (ev-dt 2026 6 1 9 0)
+              30
+              {:freq :daily :count 5}
+              1))
+          "RRULE")
+        "RRULE:FREQ=DAILY;COUNT=5")
+      (ev-ic-check!
+        "monthly nth-weekday BYDAY (2nd Tuesday)"
+        (ev-ic-line
+          (ev/event->ical-lines
+            (ev-event
+              (quote b)
+              (ev-dt 2026 1 13 9 0)
+              60
+              {:freq :monthly :byday (list {:ord 2 :wd 1})}
+              5))
+          "RRULE")
+        "RRULE:FREQ=MONTHLY;BYDAY=2TU")
+      (ev-ic-check!
+        "monthly last-Friday BYDAY"
+        (ev-ic-line
+          (ev/event->ical-lines
+            (ev-event
+              (quote b)
+              (ev-dt 2026 1 30 9 0)
+              60
+              {:freq :monthly :byday (list {:ord -1 :wd 4})}
+              5))
+          "RRULE")
+        "RRULE:FREQ=MONTHLY;BYDAY=-1FR")
+      (ev-ic-check!
+        "monthly BYMONTHDAY (incl. negative)"
+        (ev-ic-line
+          (ev/event->ical-lines
+            (ev-event
+              (quote b)
+              (ev-dt 2026 1 15 9 0)
+              60
+              {:bymonthday (list 15 -1) :freq :monthly}
+              5))
+          "RRULE")
+        "RRULE:FREQ=MONTHLY;BYMONTHDAY=15,-1")
+      (ev-ic-check!
+        "all seven weekday tokens map correctly"
+        (ev-ic-line
+          (ev/event->ical-lines
+            (ev-event
+              (quote w)
+              (ev-dt 2026 6 1 9 0)
+              30
+              {:freq :weekly :byday (list 0 1 2 3 4 5 6)}
+              1))
+          "RRULE")
+        "RRULE:FREQ=WEEKLY;BYDAY=MO,TU,WE,TH,FR,SA,SU")
+      (let
+        ((cal (ev/events->ical-lines (list (ev-event (quote a) (ev-dt 2026 6 1 9 0) 30 nil 1) (ev-event (quote b) (ev-dt 2026 6 2 9 0) 30 nil 1)))))
+        (do
+          (ev-ic-check! "VCALENDAR opens" (first cal) "BEGIN:VCALENDAR")
+          (ev-ic-check!
+            "VCALENDAR declares VERSION"
+            (ev-ic-line cal "VERSION")
+            "VERSION:2.0")
+          (ev-ic-check!
+            "two events -> two VEVENT blocks"
+            (len (filter (fn (l) (= l "BEGIN:VEVENT")) cal))
+            2)
+          (ev-ic-check!
+            "VCALENDAR has exactly one closing line"
+            (len (filter (fn (l) (= l "END:VCALENDAR")) cal))
+            1)))
+      (ev-ic-check!
+        "render joins lines with CRLF"
+        (ev/ical-render
+          (list "BEGIN:VCALENDAR" "VERSION:2.0" "END:VCALENDAR"))
+        "BEGIN:VCALENDAR\r\nVERSION:2.0\r\nEND:VCALENDAR"))))
+
+;; ---- import + round-trip ----
+
+;; The occurrence starts an event expands to over a fixed window.
+(define
+  ev-ic-starts
+  (fn
+    (ev)
+    (map (fn (o) (get o :start)) (ev-expand ev (ev-date 2026 1 1) (ev-date 2027 1 1)))))
+
+;; Round-trip an event through export then import; true if both expand alike.
+(define
+  ev-ic-roundtrips?
+  (fn
+    (ev)
+    (= (ev-ic-starts ev) (ev-ic-starts (ev/ical-lines->event (ev/event->ical-lines ev))))))
+
+(define
+  ev-ic-rt-run-all!
+  (fn
+    ()
+    (do
+      ;; ---- field parsers ----
+      (ev-ic-check! "parse DTSTART" (ev-ical-parse-dt "20260601T180000Z") (ev-dt 2026 6 1 18 0))
+      (ev-ic-check! "parse DURATION PT1H30M" (ev-ical-parse-duration "PT1H30M") 90)
+      (ev-ic-check! "parse DURATION PT1H" (ev-ical-parse-duration "PT1H") 60)
+      (ev-ic-check! "parse DURATION PT30M" (ev-ical-parse-duration "PT30M") 30)
+      (ev-ic-check! "parse plain BYDAY token" (ev-ical-parse-byday-token "MO") 0)
+      (ev-ic-check! "parse ordinal BYDAY token" (ev-ical-parse-byday-token "2TU") {:ord 2 :wd 1})
+      (ev-ic-check! "parse last-weekday BYDAY token" (ev-ical-parse-byday-token "-1FR") {:ord -1 :wd 4})
+
+      ;; ---- imported event basic fields ----
+      (let
+        ((ev (ev/ical-lines->event (ev/event->ical-lines (ev-event (quote yoga) (ev-dt 2026 6 1 18 0) 90 nil 1)))))
+        (do
+          (ev-ic-check! "imported id is a symbol" (get ev :id) (quote yoga))
+          (ev-ic-check! "imported dtstart" (get ev :dtstart) (ev-dt 2026 6 1 18 0))
+          (ev-ic-check! "imported duration" (get ev :duration) 90)))
+
+      ;; ---- round-trips preserve the occurrence set ----
+      (ev-ic-check!
+        "round-trip: one-off event"
+        (ev-ic-roundtrips? (ev-event (quote a) (ev-dt 2026 6 10 14 0) 60 nil 1))
+        true)
+      (ev-ic-check!
+        "round-trip: daily COUNT"
+        (ev-ic-roundtrips? (ev-event (quote a) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 5} 1))
+        true)
+      (ev-ic-check!
+        "round-trip: weekly interval/until/byday + exdate + rdate"
+        (ev-ic-roundtrips?
+          (ev-event-full
+            (quote a)
+            (ev-dt 2026 6 1 18 0)
+            90
+            {:freq :weekly :interval 2 :byday (list 0 2) :until (ev-dt 2026 6 30 23 0)}
+            20
+            (list (ev-dt 2026 6 8 18 0))
+            (list (ev-dt 2026 6 20 18 0))))
+        true)
+      (ev-ic-check!
+        "round-trip: monthly nth-weekday"
+        (ev-ic-roundtrips? (ev-event (quote a) (ev-dt 2026 1 13 9 0) 60 {:freq :monthly :byday (list {:ord 2 :wd 1})} 1))
+        true)
+      (ev-ic-check!
+        "round-trip: monthly bymonthday"
+        (ev-ic-roundtrips? (ev-event (quote a) (ev-dt 2026 1 15 9 0) 60 {:freq :monthly :bymonthday (list 15 -1)} 1))
+        true)
+
+      ;; ---- parse a VCALENDAR with several events ----
+      (let
+        ((cal
+           (ev/events->ical-lines
+             (list
+               (ev-event (quote a) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 3} 1)
+               (ev-event (quote b) (ev-dt 2026 6 2 10 0) 60 nil 1)))))
+        (let
+          ((events (ev/parse-vcalendar cal)))
+          (do
+            (ev-ic-check! "VCALENDAR parses both events" (len events) 2)
+            (ev-ic-check! "first event id" (get (first events) :id) (quote a))
+            (ev-ic-check! "second event id" (get (first (rest events)) :id) (quote b))
+            (ev-ic-check!
+              "parsed events expand correctly"
+              (ev-ic-starts (first events))
+              (ev-ic-starts (ev-event (quote a) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 3} 1)))))))))
+
+;; ---- timezone-aware export (TZID + VTIMEZONE) ----
+(define
+  ev-ic-find
+  (fn
+    (lines pfx)
+    (cond
+      ((empty? lines) nil)
+      ((ev-ic-prefix? (first lines) pfx) (first lines))
+      (else (ev-ic-find (rest lines) pfx)))))
+
+(define ev-ic-count (fn (lines x) (len (filter (fn (l) (= l x)) lines))))
+
+(define
+  ev-ic-index
+  (fn
+    (lines x)
+    (cond
+      ((empty? lines) -1)
+      ((= (first lines) x) 0)
+      (else
+        (let ((r (ev-ic-index (rest lines) x))) (if (< r 0) -1 (+ 1 r)))))))
+
+(define
+  ev-ic-tz-run-all!
+  (fn
+    ()
+    (do
+      ;; a tz event's DTSTART is local wall-clock with a TZID parameter
+      (ev-ic-check!
+        "tz event DTSTART uses TZID + local wall-clock (not UTC)"
+        (ev-ic-find (ev/event->ical-lines (ev-event-tz (quote w) (ev-dt 2026 7 15 18 0) 60 nil 1 ev-tz-london)) "DTSTART")
+        "DTSTART;TZID=Europe/London:20260715T180000")
+      (ev-ic-check!
+        "a non-tz event still uses a UTC Z stamp"
+        (ev-ic-find (ev/event->ical-lines (ev-event (quote n) (ev-dt 2026 7 15 18 0) 60 nil 1)) "DTSTART")
+        "DTSTART:20260715T180000Z")
+      ;; UNTIL stays UTC even for a TZID event (RFC 5545)
+      (ev-ic-check!
+        "tz event RRULE UNTIL is still UTC"
+        (ev-ic-find
+          (ev/event->ical-lines
+            (ev-event-tz (quote s) (ev-dt 2026 6 1 18 0) 60 {:freq :weekly :byday (list 0) :until (ev-dt 2026 6 30 23 0)} 1 ev-tz-london))
+          "RRULE")
+        "RRULE:FREQ=WEEKLY;UNTIL=20260630T220000Z;BYDAY=MO")
+      ;; EXDATE matches the DTSTART form (TZID + local)
+      (ev-ic-check!
+        "tz event EXDATE uses TZID + local"
+        (ev-ic-find
+          (ev/event->ical-lines
+            (assoc
+              (ev-event-tz (quote s) (ev-dt 2026 7 1 18 0) 60 {:freq :daily :count 3} 1 ev-tz-london)
+              :exdate
+              (list (ev-dt 2026 7 2 18 0))))
+          "EXDATE")
+        "EXDATE;TZID=Europe/London:20260702T180000")
+
+      ;; ---- VTIMEZONE block ----
+      (let
+        ((vtz (ev-ical-vtimezone ev-tz-london)))
+        (do
+          (ev-ic-check! "VTIMEZONE names the zone" (ev-ic-find vtz "TZID") "TZID:Europe/London")
+          (ev-ic-check! "DAYLIGHT transitions GMT->BST" (ev-ic-find vtz "TZOFFSETTO:+0100") "TZOFFSETTO:+0100")
+          (ev-ic-check! "DAYLIGHT rule is last Sunday of March" (ev-ic-find vtz "RRULE:FREQ=YEARLY;BYMONTH=3") "RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU")
+          (ev-ic-check! "STANDARD rule is last Sunday of October" (ev-ic-find vtz "RRULE:FREQ=YEARLY;BYMONTH=10") "RRULE:FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU")))
+      (let
+        ((vtz (ev-ical-vtimezone ev-tz-paris)))
+        (do
+          (ev-ic-check! "Paris DAYLIGHT goes to +0200 (CEST)" (ev-ic-find vtz "TZOFFSETTO:+0200") "TZOFFSETTO:+0200")
+          (ev-ic-check! "Paris STANDARD goes to +0100 (CET)" (ev-ic-find vtz "TZOFFSETTO:+0100") "TZOFFSETTO:+0100")))
+
+      ;; ---- VCALENDAR carries one VTIMEZONE per distinct zone ----
+      (let
+        ((cal (ev/events->ical-lines (list (ev-event-tz (quote a) (ev-dt 2026 6 1 9 0) 60 nil 1 ev-tz-london)))))
+        (do
+          (ev-ic-check! "VCALENDAR includes the referenced VTIMEZONE" (ev-ic-count cal "BEGIN:VTIMEZONE") 1)
+          (ev-ic-check! "VTIMEZONE precedes the VEVENT" (< (ev-ic-index cal "BEGIN:VTIMEZONE") (ev-ic-index cal "BEGIN:VEVENT")) true)))
+      (ev-ic-check!
+        "two events in the same zone share one VTIMEZONE"
+        (ev-ic-count
+          (ev/events->ical-lines
+            (list
+              (ev-event-tz (quote a) (ev-dt 2026 6 1 9 0) 60 nil 1 ev-tz-london)
+              (ev-event-tz (quote b) (ev-dt 2026 6 2 9 0) 60 nil 1 ev-tz-london)))
+          "BEGIN:VTIMEZONE")
+        1)
+      (ev-ic-check!
+        "events in two zones get two VTIMEZONEs"
+        (ev-ic-count
+          (ev/events->ical-lines
+            (list
+              (ev-event-tz (quote a) (ev-dt 2026 6 1 9 0) 60 nil 1 ev-tz-london)
+              (ev-event-tz (quote b) (ev-dt 2026 6 2 9 0) 60 nil 1 ev-tz-paris)))
+          "BEGIN:VTIMEZONE")
+        2)
+      (ev-ic-check!
+        "a non-tz-only calendar has no VTIMEZONE"
+        (ev-ic-count (ev/events->ical-lines (list (ev-event (quote a) (ev-dt 2026 6 1 9 0) 60 nil 1))) "BEGIN:VTIMEZONE")
+        0)
+
+      ;; ---- import tolerates the TZID parameter ----
+      (ev-ic-check!
+        "import parses DTSTART;TZID local time"
+        (get
+          (ev/ical-lines->event (ev/event->ical-lines (ev-event-tz (quote a) (ev-dt 2026 7 15 18 0) 60 nil 1 ev-tz-london)))
+          :dtstart)
+        (ev-dt 2026 7 15 18 0)))))
+
+(define
+  ev-ical-tests-run!
+  (fn
+    ()
+    (do
+      (set! ev-ic-pass 0)
+      (set! ev-ic-fail 0)
+      (set! ev-ic-failures (list))
+      (ev-ic-run-all!)
+      (ev-ic-rt-run-all!)
+      (ev-ic-tz-run-all!)
+      {:failures ev-ic-failures :total (+ ev-ic-pass ev-ic-fail) :passed ev-ic-pass :failed ev-ic-fail})))

lib/haskell/runtime.sx

@@ -148,3 +148,9 @@
           (fn (acc i) (str acc (char-at buf i)))
           ""
           (range off (string-length buf)))))))
+
+;; ── JIT interpret-only boundary ───────────────────────────────────────────
+;; The Haskell evaluator (hk-eval and the lazy-thunk forcer) recurses deeply
+;; over the AST/graph; under JIT the recursive eval can miscompile into a
+;; non-terminating loop. Exclude the hk- namespace from JIT.
+(jit-exclude! "hk-*")

lib/js/runtime.sx

@@ -6994,3 +6994,9 @@
 (set! js-global-this js-global)
 
 (dict-set! js-global "globalThis" js-global)
+
+;; ── JIT interpret-only boundary ───────────────────────────────────────────
+;; The JS evaluator (transpile.sx) uses call/cc for control flow (exceptions,
+;; early return); a JIT-compiled frame can't escape through a CEK continuation.
+;; Exclude the js- namespace from JIT. See Sx_types.jit_excluded_prefixes.
+(jit-exclude! "js-*" "jp-*")

lib/maude/conditional.sx

@@ -0,0 +1,164 @@
+;; lib/maude/conditional.sx — conditional equations (Phase 4) + owise.
+;;
+;; A condition-aware superset of the Phase 3 reducer. `ceq L = R if COND` fires
+;; only when COND holds under the matching substitution. Conditions come from
+;; the parser as:
+;;   {:kind :eq :lhs L :rhs R}   — holds iff reduce(s L) =AC= reduce(s R)
+;;   {:kind :bool :term T}       — holds iff reduce(s T) =AC= true
+;; Condition evaluation recurses through the SAME reducer (mau/cnormalize), so
+;; a ceq whose guard mentions other (possibly conditional) equations Just Works
+;; — termination rests on the guard reducing on structurally smaller arguments
+;; (and the global fuel guard).
+;;
+;; `owise` (otherwise): an equation tagged [owise] fires at a redex only when
+;; NO ordinary equation applies there. crewrite-top is two-pass: ordinary
+;; equations first, owise equations last.
+;;
+;; Single-step firing uses the short-circuiting matcher in fire.sx
+;; (mau/fire-eq). The eager candidate enumeration (mau/eq-candidates) is
+;; retained for `search` (rewrite.sx), which genuinely needs every successor.
+
+(define
+  mau/ac-candidates
+  (fn
+    (theory f th eq term)
+    (let
+      ((id (get th :id))
+        (pels (mau/flatten-op theory f (get eq :lhs)))
+        (sels (mau/flatten-op theory f term)))
+      (let
+        ((matches (if (get th :comm) (mau/match-multiset theory f (mau/append2 pels (list (mau/var "$R" ""))) sels {} id) (mau/match-sequence theory f (mau/append2 (list (mau/var "$L" "")) (mau/append2 pels (list (mau/var "$R" "")))) sels {} id))))
+        (map (fn (s) {:s s :result (mau/ac-eq-result theory f th eq s)}) matches)))))
+
+(define
+  mau/eq-candidates
+  (fn
+    (theory eq term)
+    (let
+      ((lhs (get eq :lhs)))
+      (let
+        ((th (if (mau/app? lhs) (mau/th-of theory (mau/op lhs)) {:id nil :assoc false :comm false})))
+        (if
+          (and (mau/app? lhs) (get th :assoc))
+          (mau/ac-candidates theory (mau/op lhs) th eq term)
+          (map (fn (s) {:s s :result (mau/subst-apply s (get eq :rhs))}) (mau/mm theory lhs term {})))))))
+
+(define
+  mau/cond-holds?
+  (fn
+    (theory eqs cond s)
+    (if
+      (= cond nil)
+      true
+      (if
+        (= (get cond :kind) "eq")
+        (mau/ac-equal?
+          theory
+          (mau/cnormalize
+            theory
+            eqs
+            (mau/subst-apply s (get cond :lhs))
+            mau/reduce-fuel)
+          (mau/cnormalize
+            theory
+            eqs
+            (mau/subst-apply s (get cond :rhs))
+            mau/reduce-fuel))
+        (mau/ac-equal?
+          theory
+          (mau/cnormalize
+            theory
+            eqs
+            (mau/subst-apply s (get cond :term))
+            mau/reduce-fuel)
+          (mau/const "true"))))))
+
+(define
+  mau/try-candidates
+  (fn
+    (theory all-eqs cond term cands)
+    (if
+      (empty? cands)
+      nil
+      (let
+        ((c (first cands)))
+        (if
+          (and
+            (not (mau/ac-equal? theory (get c :result) term))
+            (mau/cond-holds? theory all-eqs cond (get c :s)))
+          (get c :result)
+          (mau/try-candidates theory all-eqs cond term (rest cands)))))))
+
+;; ---- owise partitioning ----
+
+(define mau/eq-owise? (fn (e) (= (get e :owise) true)))
+(define mau/filter-owise (fn (eqs) (filter mau/eq-owise? eqs)))
+(define
+  mau/filter-noowise
+  (fn (eqs) (filter (fn (e) (not (mau/eq-owise? e))) eqs)))
+
+(define
+  mau/crewrite-loop
+  (fn
+    (theory all-eqs eqs term)
+    (if
+      (empty? eqs)
+      nil
+      (let
+        ((r (mau/fire-eq theory all-eqs (first eqs) term)))
+        (if (= r nil) (mau/crewrite-loop theory all-eqs (rest eqs) term) r)))))
+
+(define
+  mau/crewrite-top
+  (fn
+    (theory eqs term)
+    (let
+      ((r (mau/crewrite-loop theory eqs (mau/filter-noowise eqs) term)))
+      (if
+        (= r nil)
+        (mau/crewrite-loop theory eqs (mau/filter-owise eqs) term)
+        r))))
+
+(define
+  mau/cnormalize
+  (fn
+    (theory eqs term fuel)
+    (if
+      (<= fuel 0)
+      term
+      (cond
+        ((mau/var? term) term)
+        ((mau/app? term)
+          (let
+            ((nargs (map (fn (a) (mau/cnormalize theory eqs a fuel)) (mau/args term))))
+            (let
+              ((t2 (mau/app (mau/op term) nargs)))
+              (let
+                ((r (mau/crewrite-top theory eqs t2)))
+                (if
+                  (= r nil)
+                  t2
+                  (mau/cnormalize theory eqs r (- fuel 1)))))))
+        (else term)))))
+
+(define
+  mau/creduce
+  (fn
+    (m term)
+    (mau/cnormalize
+      (mau/build-theory m)
+      (mau/module-eqs m)
+      term
+      mau/reduce-fuel)))
+
+(define
+  mau/creduce-term
+  (fn (m src) (mau/creduce m (mau/parse-term-in m src))))
+
+(define
+  mau/creduce->str
+  (fn (m src) (mau/term->str (mau/creduce-term m src))))
+
+(define
+  mau/ccanon
+  (fn (m src) (mau/canon (mau/build-theory m) (mau/creduce-term m src))))

lib/maude/confluence.sx

@@ -0,0 +1,268 @@
+;; lib/maude/confluence.sx — critical-pair / local-confluence checking.
+;;
+;; A terminating equation set is confluent iff every critical pair is joinable
+;; (Knuth-Bendix / Newman). A critical pair arises when two oriented equations
+;; overlap: a non-variable subterm of one LHS unifies with the other LHS, giving
+;; two ways to rewrite the overlap; they must reduce to the same normal form.
+;;
+;; This needs TWO-SIDED unification (variables on both sides), not the one-sided
+;; matching the reducer uses — so this file carries its own syntactic unifier.
+;;
+;; SCOPE / honesty: the unifier is SYNTACTIC. For free/constructor operators the
+;; check is exact. For assoc/comm (AC) operators it sees only syntactic overlaps
+;; (full AC-unification is NP/infinitary — out of scope), but joinability is
+;; tested with `mau/ac-equal?` (canonical form modulo the theory), so AC laws are
+;; joined correctly even though their overlaps are under-approximated. Conditional
+;; and `owise` equations are not oriented (skipped).
+
+;; ---------- syntactic unification (vars on both sides) ----------
+
+(define
+  mau/u-walk
+  (fn
+    (t s)
+    (if
+      (mau/var? t)
+      (let
+        ((b (get s (mau/vname t))))
+        (if (= b nil) t (mau/u-walk b s)))
+      t)))
+
+(define
+  mau/u-occurs?
+  (fn
+    (name t s)
+    (let
+      ((w (mau/u-walk t s)))
+      (cond
+        ((mau/var? w) (= (mau/vname w) name))
+        ((mau/app? w) (mau/u-occurs-any? name (mau/args w) s))
+        (else false)))))
+
+(define
+  mau/u-occurs-any?
+  (fn
+    (name args s)
+    (cond
+      ((empty? args) false)
+      ((mau/u-occurs? name (first args) s) true)
+      (else (mau/u-occurs-any? name (rest args) s)))))
+
+(define
+  mau/u-unify-args
+  (fn
+    (as bs s)
+    (cond
+      ((= s nil) nil)
+      ((and (empty? as) (empty? bs)) s)
+      ((or (empty? as) (empty? bs)) nil)
+      (else
+        (mau/u-unify-args
+          (rest as)
+          (rest bs)
+          (mau/u-unify (first as) (first bs) s))))))
+
+(define
+  mau/u-unify
+  (fn
+    (t1 t2 s)
+    (if
+      (= s nil)
+      nil
+      (let
+        ((a (mau/u-walk t1 s)) (b (mau/u-walk t2 s)))
+        (cond
+          ((and (mau/var? a) (mau/var? b) (= (mau/vname a) (mau/vname b)))
+            s)
+          ((mau/var? a)
+            (if
+              (mau/u-occurs? (mau/vname a) b s)
+              nil
+              (assoc s (mau/vname a) b)))
+          ((mau/var? b)
+            (if
+              (mau/u-occurs? (mau/vname b) a s)
+              nil
+              (assoc s (mau/vname b) a)))
+          ((and (mau/app? a) (mau/app? b))
+            (if
+              (and
+                (= (mau/op a) (mau/op b))
+                (= (mau/arity a) (mau/arity b)))
+              (mau/u-unify-args (mau/args a) (mau/args b) s)
+              nil))
+          (else nil))))))
+
+(define
+  mau/u-apply
+  (fn
+    (t s)
+    (let
+      ((w (mau/u-walk t s)))
+      (if
+        (mau/app? w)
+        (mau/app
+          (mau/op w)
+          (map (fn (a) (mau/u-apply a s)) (mau/args w)))
+        w))))
+
+(define
+  mau/u-rename
+  (fn
+    (t suffix)
+    (cond
+      ((mau/var? t) (mau/var (str (mau/vname t) suffix) (mau/vsort t)))
+      ((mau/app? t)
+        (mau/app
+          (mau/op t)
+          (map (fn (a) (mau/u-rename a suffix)) (mau/args t))))
+      (else t))))
+
+;; ---------- positions ----------
+
+(define
+  mau/positions-args
+  (fn
+    (args i)
+    (if
+      (empty? args)
+      (list)
+      (mau/append2
+        (map (fn (p) (cons i p)) (mau/nv-positions (first args)))
+        (mau/positions-args (rest args) (+ i 1))))))
+
+;; non-variable positions (paths) of a term; root = empty path
+(define
+  mau/nv-positions
+  (fn
+    (t)
+    (if
+      (mau/app? t)
+      (cons (list) (mau/positions-args (mau/args t) 0))
+      (list))))
+
+(define
+  mau/at-path
+  (fn
+    (t path)
+    (if
+      (empty? path)
+      t
+      (mau/at-path (nth (mau/args t) (first path)) (rest path)))))
+
+(define
+  mau/replace-nth
+  (fn
+    (xs i v)
+    (if
+      (= i 0)
+      (cons v (rest xs))
+      (cons (first xs) (mau/replace-nth (rest xs) (- i 1) v)))))
+
+(define
+  mau/replace-at
+  (fn
+    (t path new)
+    (if
+      (empty? path)
+      new
+      (mau/app
+        (mau/op t)
+        (mau/replace-nth
+          (mau/args t)
+          (first path)
+          (mau/replace-at (nth (mau/args t) (first path)) (rest path) new))))))
+
+;; ---------- critical pairs ----------
+
+(define
+  mau/eq-same?
+  (fn
+    (e1 e2)
+    (and
+      (mau/term=? (get e1 :lhs) (get e2 :lhs))
+      (mau/term=? (get e1 :rhs) (get e2 :rhs)))))
+
+(define
+  mau/cps-at
+  (fn
+    (l1 r1 l2 r2 same? paths)
+    (if
+      (empty? paths)
+      (list)
+      (let
+        ((p (first paths)))
+        (if
+          (and same? (empty? p))
+          (mau/cps-at l1 r1 l2 r2 same? (rest paths))
+          (let
+            ((s (mau/u-unify (mau/at-path l1 p) l2 {})))
+            (if
+              (= s nil)
+              (mau/cps-at l1 r1 l2 r2 same? (rest paths))
+              (cons {:right (mau/u-apply (mau/replace-at l1 p r2) s) :left (mau/u-apply r1 s)} (mau/cps-at l1 r1 l2 r2 same? (rest paths))))))))))
+
+(define
+  mau/cps-of
+  (fn
+    (e1 e2)
+    (let
+      ((l1 (mau/u-rename (get e1 :lhs) "#1"))
+        (r1 (mau/u-rename (get e1 :rhs) "#1"))
+        (l2 (mau/u-rename (get e2 :lhs) "#2"))
+        (r2 (mau/u-rename (get e2 :rhs) "#2")))
+      (mau/cps-at l1 r1 l2 r2 (mau/eq-same? e1 e2) (mau/nv-positions l1)))))
+
+(define
+  mau/all-cps
+  (fn
+    (eqs)
+    (mau/concat-map
+      (fn (e1) (mau/concat-map (fn (e2) (mau/cps-of e1 e2)) eqs))
+      eqs)))
+
+;; ---------- public API ----------
+
+(define
+  mau/orientable-eqs
+  (fn
+    (m)
+    (filter
+      (fn (e) (and (= (get e :cond) nil) (not (= (get e :owise) true))))
+      (mau/module-eqs m))))
+
+(define
+  mau/joinable?
+  (fn
+    (theory eqs t1 t2)
+    (mau/ac-equal?
+      theory
+      (mau/cnormalize theory eqs t1 mau/reduce-fuel)
+      (mau/cnormalize theory eqs t2 mau/reduce-fuel))))
+
+(define mau/critical-pairs (fn (m) (mau/all-cps (mau/orientable-eqs m))))
+
+(define
+  mau/non-joinable-pairs
+  (fn
+    (m)
+    (let
+      ((theory (mau/build-theory m)) (eqs (mau/module-eqs m)))
+      (filter
+        (fn
+          (cp)
+          (not (mau/joinable? theory eqs (get cp :left) (get cp :right))))
+        (mau/all-cps (mau/orientable-eqs m))))))
+
+(define mau/confluent? (fn (m) (empty? (mau/non-joinable-pairs m))))
+
+(define
+  mau/cp->str
+  (fn
+    (m cp)
+    (let
+      ((theory (mau/build-theory m)))
+      (str
+        (mau/canon theory (get cp :left))
+        " <?> "
+        (mau/canon theory (get cp :right))))))

lib/maude/conformance.conf

@@ -0,0 +1,41 @@
+# Maude conformance config — sourced by lib/guest/conformance.sh.
+
+LANG_NAME=maude
+MODE=dict
+
+PRELOADS=(
+  lib/guest/lex.sx
+  lib/guest/pratt.sx
+  lib/maude/term.sx
+  lib/maude/parser.sx
+  lib/maude/sorts.sx
+  lib/maude/reduce.sx
+  lib/maude/matching.sx
+  lib/maude/conditional.sx
+  lib/maude/fire.sx
+  lib/maude/confluence.sx
+  lib/maude/rewrite.sx
+  lib/maude/searchpath.sx
+  lib/maude/strategy.sx
+  lib/maude/meta.sx
+  lib/maude/pretty.sx
+  lib/maude/run.sx
+)
+
+SUITES=(
+  "parse:lib/maude/tests/parse.sx:(mau-parse-tests-run!)"
+  "reduce:lib/maude/tests/reduce.sx:(mau-reduce-tests-run!)"
+  "matching:lib/maude/tests/matching.sx:(mau-matching-tests-run!)"
+  "confluence:lib/maude/tests/confluence.sx:(mau-confluence-tests-run!)"
+  "conditional:lib/maude/tests/conditional.sx:(mau-conditional-tests-run!)"
+  "owise:lib/maude/tests/owise.sx:(mau-owise-tests-run!)"
+  "gather:lib/maude/tests/gather.sx:(mau-gather-tests-run!)"
+  "sorts:lib/maude/tests/sorts.sx:(mau-sorts-tests-run!)"
+  "rewrite:lib/maude/tests/rewrite.sx:(mau-rewrite-tests-run!)"
+  "searchpath:lib/maude/tests/searchpath.sx:(mau-searchpath-tests-run!)"
+  "strategy:lib/maude/tests/strategy.sx:(mau-strategy-tests-run!)"
+  "meta:lib/maude/tests/meta.sx:(mau-meta-tests-run!)"
+  "pretty:lib/maude/tests/pretty.sx:(mau-pretty-tests-run!)"
+  "run:lib/maude/tests/run.sx:(mau-run-tests-run!)"
+  "effects:lib/maude/tests/effects.sx:(mau-effects-tests-run!)"
+)

lib/maude/conformance.sh

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

lib/maude/fire.sx

@@ -0,0 +1,250 @@
+;; lib/maude/fire.sx — short-circuiting rule/equation firing.
+;;
+;; The eager matcher (mau/match-multiset) enumerates EVERY substitution, which
+;; is what `mau/match-all` and `search` need. But for a single rewrite step we
+;; only need the FIRST usable match — and eager enumeration is exponential when
+;; an AC argument has many identical elements (q ; q ; ... ; q). These
+;; find-matchers thread a predicate and stop at the first complete match for
+;; which it returns non-nil; the predicate builds the rewritten term and checks
+;; "progresses AND condition holds", so firing short-circuits on the first
+;; productive match instead of materialising the whole solution set.
+;;
+;; pred : subst -> result-term-or-nil   (result is always a term, never nil)
+
+(define
+  mau/try-list
+  (fn
+    (substs cont)
+    (if
+      (empty? substs)
+      nil
+      (let
+        ((r (cont (first substs))))
+        (if (= r nil) (mau/try-list (rest substs) cont) r)))))
+
+;; ---- multiset (assoc+comm) find ----
+
+(define
+  mau/ms-find
+  (fn
+    (theory f pels sels s id pred)
+    (cond
+      ((empty? pels) (if (empty? sels) (pred s) nil))
+      (else
+        (let
+          ((p (first pels)) (prest (rest pels)))
+          (if
+            (mau/var? p)
+            (mau/ms-find-var
+              theory
+              f
+              prest
+              sels
+              s
+              (mau/vname p)
+              id
+              pred
+              (mau/var-kmin (mau/vname p) id)
+              (mau/all-splits sels))
+            (mau/ms-find-nonvar theory f p prest sels s id pred 0)))))))
+
+(define
+  mau/ms-find-nonvar
+  (fn
+    (theory f p prest sels s id pred i)
+    (if
+      (>= i (len sels))
+      nil
+      (let
+        ((others (mau/remove-at sels i)))
+        (let
+          ((r (mau/try-list (mau/mm theory p (nth sels i) s) (fn (s2) (mau/ms-find theory f prest others s2 id pred)))))
+          (if
+            (not (= r nil))
+            r
+            (mau/ms-find-nonvar
+              theory
+              f
+              p
+              prest
+              sels
+              s
+              id
+              pred
+              (+ i 1))))))))
+
+(define
+  mau/ms-find-var
+  (fn
+    (theory f prest sels s name id pred kmin splits)
+    (if
+      (empty? splits)
+      nil
+      (let
+        ((chosen (first (first splits)))
+          (rests (nth (first splits) 1)))
+        (if
+          (< (len chosen) kmin)
+          (mau/ms-find-var
+            theory
+            f
+            prest
+            sels
+            s
+            name
+            id
+            pred
+            kmin
+            (rest splits))
+          (let
+            ((s2 (mau/bind-check theory s name (mau/rebuild f chosen id))))
+            (let
+              ((r (if (= s2 nil) nil (mau/ms-find theory f prest rests s2 id pred))))
+              (if
+                (not (= r nil))
+                r
+                (mau/ms-find-var
+                  theory
+                  f
+                  prest
+                  sels
+                  s
+                  name
+                  id
+                  pred
+                  kmin
+                  (rest splits))))))))))
+
+;; ---- sequence (assoc, ordered) find ----
+
+(define
+  mau/seq-find
+  (fn
+    (theory f pels sels s id pred)
+    (cond
+      ((empty? pels) (if (empty? sels) (pred s) nil))
+      (else
+        (let
+          ((p (first pels)) (prest (rest pels)))
+          (if
+            (mau/var? p)
+            (mau/seq-find-var
+              theory
+              f
+              prest
+              sels
+              s
+              (mau/vname p)
+              id
+              pred
+              (mau/var-kmin (mau/vname p) id))
+            (if
+              (empty? sels)
+              nil
+              (mau/try-list
+                (mau/mm theory p (first sels) s)
+                (fn
+                  (s2)
+                  (mau/seq-find theory f prest (rest sels) s2 id pred))))))))))
+
+(define
+  mau/seq-find-var
+  (fn
+    (theory f prest sels s name id pred k)
+    (if
+      (> k (len sels))
+      nil
+      (let
+        ((s2 (mau/bind-check theory s name (mau/rebuild f (mau/take sels k) id))))
+        (let
+          ((r (if (= s2 nil) nil (mau/seq-find theory f prest (mau/drop sels k) s2 id pred))))
+          (if
+            (not (= r nil))
+            r
+            (mau/seq-find-var
+              theory
+              f
+              prest
+              sels
+              s
+              name
+              id
+              pred
+              (+ k 1))))))))
+
+;; ---- firing an equation/rule (returns rewritten term or nil) ----
+
+(define
+  mau/fire-plain
+  (fn
+    (theory eqs eq term cnd substs)
+    (if
+      (empty? substs)
+      nil
+      (let
+        ((res (mau/subst-apply (first substs) (get eq :rhs))))
+        (if
+          (and
+            (not (mau/ac-equal? theory res term))
+            (mau/cond-holds? theory eqs cnd (first substs)))
+          res
+          (mau/fire-plain theory eqs eq term cnd (rest substs)))))))
+
+(define
+  mau/fire-ac
+  (fn
+    (theory eqs f th eq term cnd)
+    (let
+      ((id (get th :id))
+        (pels (mau/flatten-op theory f (get eq :lhs)))
+        (sels (mau/flatten-op theory f term)))
+      (let
+        ((pred (fn (s) (let ((res (mau/ac-eq-result theory f th eq s))) (if (and (not (mau/ac-equal? theory res term)) (mau/cond-holds? theory eqs cnd s)) res nil)))))
+        (if
+          (get th :comm)
+          (mau/ms-find
+            theory
+            f
+            (mau/append2 pels (list (mau/var "$R" "")))
+            sels
+            {}
+            id
+            pred)
+          (mau/seq-find
+            theory
+            f
+            (mau/append2
+              (list (mau/var "$L" ""))
+              (mau/append2 pels (list (mau/var "$R" ""))))
+            sels
+            {}
+            id
+            pred))))))
+
+(define
+  mau/fire-eq
+  (fn
+    (theory eqs eq term)
+    (let
+      ((lhs (get eq :lhs)) (cnd (get eq :cond)))
+      (if
+        (mau/app? lhs)
+        (let
+          ((th (mau/th-of theory (mau/op lhs))))
+          (if
+            (get th :assoc)
+            (mau/fire-ac theory eqs (mau/op lhs) th eq term cnd)
+            (mau/fire-plain
+              theory
+              eqs
+              eq
+              term
+              cnd
+              (mau/mm theory lhs term {}))))
+        (mau/fire-plain
+          theory
+          eqs
+          eq
+          term
+          cnd
+          (mau/mm theory lhs term {}))))))

lib/maude/matching.sx

@@ -0,0 +1,565 @@
+;; lib/maude/matching.sx — equational matching modulo assoc/comm/id (Phase 3).
+;;
+;; The chisel. Syntactic matching (reduce.sx) returns at most one substitution;
+;; matching modulo a theory is MULTI-VALUED — `X + Y` against `a + b + c` (with
+;; _+_ assoc comm) has several solutions. `mau/mm` returns the full list of
+;; substitutions; callers (rule application) pick.
+;;
+;; Operator theories come from the signature attributes, collected into a dict
+;; OP-NAME -> {:assoc B :comm B :id ELT}. Matching dispatches on the head op's
+;; theory:
+;;   free        positional, exact arity
+;;   comm        binary, try both argument orderings
+;;   assoc       flatten the f-spine, match the pattern sequence against the
+;;               subject sequence (variables grab contiguous blocks)
+;;   assoc+comm  flatten, match as multisets (variables grab sub-multisets)
+;; Identity (id: e) lets a variable grab the empty block, contributing e.
+;;
+;; Equational rewriting (mau/ac-reduce) extends each f-AC equation l=r to
+;; f(REST..., l) -> f(REST..., r) so a rule fires on any sub-multiset of an
+;; AC term, then renormalises to a fixpoint. A candidate rewrite is taken only
+;; if it changes the AC-canonical form (mau/canon) — idempotency/identity
+;; matches that would re-fire forever are skipped, guaranteeing progress.
+
+;; ---------- theory table ----------
+
+(define
+  mau/build-theory
+  (fn
+    (m)
+    (let
+      ((th {}))
+      (for-each
+        (fn
+          (op)
+          (let
+            ((a (get op :attrs)))
+            (dict-set! th (get op :name) {:id (get a :id) :assoc (= (get a :assoc) true) :comm (= (get a :comm) true)})))
+        (mau/module-ops m))
+      th)))
+
+(define
+  mau/th-of
+  (fn
+    (theory op)
+    (let ((e (get theory op))) (if (= e nil) {:id nil :assoc false :comm false} e))))
+
+;; ---------- small list utilities ----------
+
+(define
+  mau/concat-map
+  (fn
+    (f xs)
+    (if
+      (empty? xs)
+      (list)
+      (mau/append2 (f (first xs)) (mau/concat-map f (rest xs))))))
+
+(define
+  mau/remove-at
+  (fn (xs i) (mau/append2 (mau/take xs i) (mau/drop xs (+ i 1)))))
+
+;; All (chosen complement) pairs over every subset of xs.
+(define
+  mau/all-splits
+  (fn
+    (xs)
+    (if
+      (empty? xs)
+      (list (list (list) (list)))
+      (let
+        ((subsplits (mau/all-splits (rest xs))) (x (first xs)))
+        (mau/concat-map
+          (fn
+            (pair)
+            (let
+              ((c (first pair)) (r (nth pair 1)))
+              (list (list (cons x c) r) (list c (cons x r)))))
+          subsplits)))))
+
+;; ---------- flattening of associative spines ----------
+
+(define
+  mau/flatten-op
+  (fn
+    (theory f term)
+    (if
+      (and (mau/app? term) (= (mau/op term) f))
+      (mau/flatten-op-list theory f (mau/args term))
+      (list term))))
+
+(define
+  mau/flatten-op-list
+  (fn
+    (theory f args)
+    (if
+      (empty? args)
+      (list)
+      (mau/append2
+        (mau/flatten-op theory f (first args))
+        (mau/flatten-op-list theory f (rest args))))))
+
+(define
+  mau/foldr-app
+  (fn
+    (f block)
+    (if
+      (empty? (rest block))
+      (first block)
+      (mau/app f (list (first block) (mau/foldr-app f (rest block)))))))
+
+(define
+  mau/rebuild
+  (fn
+    (f block id)
+    (cond
+      ((empty? block) (if (= id nil) (mau/const "$EMPTY") (mau/const id)))
+      ((empty? (rest block)) (first block))
+      (else (mau/foldr-app f block)))))
+
+(define mau/ac-build (fn (theory f els id) (mau/rebuild f els id)))
+
+;; ---------- AC-canonical form / equality ----------
+
+(define
+  mau/insert-str
+  (fn
+    (x ys)
+    (cond
+      ((empty? ys) (list x))
+      ((<= x (first ys)) (cons x ys))
+      (else (cons (first ys) (mau/insert-str x (rest ys)))))))
+
+(define
+  mau/sort-strings
+  (fn
+    (xs)
+    (if
+      (empty? xs)
+      xs
+      (mau/insert-str (first xs) (mau/sort-strings (rest xs))))))
+
+(define
+  mau/drop-identity
+  (fn
+    (theory f els id)
+    (if
+      (= id nil)
+      els
+      (let
+        ((idc (mau/canon theory (mau/const id))))
+        (filter (fn (e) (not (= (mau/canon theory e) idc))) els)))))
+
+(define
+  mau/canon
+  (fn
+    (theory term)
+    (cond
+      ((mau/var? term) (str "?" (mau/vname term)))
+      ((mau/const? term) (mau/op term))
+      ((mau/app? term)
+        (let
+          ((f (mau/op term)) (th (mau/th-of theory (mau/op term))))
+          (if
+            (get th :assoc)
+            (let
+              ((els (mau/drop-identity theory f (mau/flatten-op theory f term) (get th :id))))
+              (cond
+                ((empty? els)
+                  (if (= (get th :id) nil) "$EMPTY" (get th :id)))
+                ((empty? (rest els)) (mau/canon theory (first els)))
+                (else
+                  (let
+                    ((cs (map (fn (e) (mau/canon theory e)) els)))
+                    (let
+                      ((cs2 (if (get th :comm) (mau/sort-strings cs) cs)))
+                      (str f "(" (join "," cs2) ")"))))))
+            (if
+              (get th :comm)
+              (str
+                f
+                "("
+                (join
+                  ","
+                  (mau/sort-strings
+                    (map (fn (e) (mau/canon theory e)) (mau/args term))))
+                ")")
+              (str
+                f
+                "("
+                (join
+                  ","
+                  (map (fn (e) (mau/canon theory e)) (mau/args term)))
+                ")")))))
+      (else (str term)))))
+
+(define
+  mau/ac-equal?
+  (fn (theory a b) (= (mau/canon theory a) (mau/canon theory b))))
+
+;; ---------- variable block bounds ----------
+
+(define
+  mau/rest-var?
+  (fn
+    (name)
+    (and
+      (> (len name) 0)
+      (= (slice name 0 1) "$"))))
+
+(define
+  mau/var-kmin
+  (fn
+    (name id)
+    (if (or (mau/rest-var? name) (not (= id nil))) 0 1)))
+
+(define
+  mau/bind-check
+  (fn
+    (theory s name val)
+    (let
+      ((b (get s name)))
+      (if
+        (= b nil)
+        (assoc s name val)
+        (if (mau/ac-equal? theory b val) s nil)))))
+
+;; ---------- core multi-valued matcher ----------
+
+(define
+  mau/mm
+  (fn
+    (theory pat subj s)
+    (cond
+      ((mau/var? pat)
+        (let
+          ((bound (get s (mau/vname pat))))
+          (if
+            (= bound nil)
+            (list (assoc s (mau/vname pat) subj))
+            (if (mau/ac-equal? theory bound subj) (list s) (list)))))
+      ((mau/app? pat)
+        (if (mau/app? subj) (mau/mm-app theory pat subj s) (list)))
+      (else (list)))))
+
+(define
+  mau/extend-all
+  (fn
+    (theory p subj substs)
+    (mau/concat-map (fn (s) (mau/mm theory p subj s)) substs)))
+
+(define
+  mau/mm-args
+  (fn
+    (theory ps ss substs)
+    (cond
+      ((and (empty? ps) (empty? ss)) substs)
+      ((or (empty? ps) (empty? ss)) (list))
+      (else
+        (mau/mm-args
+          theory
+          (rest ps)
+          (rest ss)
+          (mau/extend-all theory (first ps) (first ss) substs))))))
+
+(define
+  mau/mm-comm
+  (fn
+    (theory pat subj s)
+    (let
+      ((p1 (nth (mau/args pat) 0))
+        (p2 (nth (mau/args pat) 1))
+        (q1 (nth (mau/args subj) 0))
+        (q2 (nth (mau/args subj) 1)))
+      (mau/append2
+        (mau/mm-args theory (list p1 p2) (list q1 q2) (list s))
+        (mau/mm-args theory (list p1 p2) (list q2 q1) (list s))))))
+
+(define
+  mau/mm-assoc
+  (fn
+    (theory f pat subj s)
+    (let
+      ((pels (mau/flatten-op theory f pat))
+        (sels (mau/flatten-op theory f subj))
+        (th (mau/th-of theory f)))
+      (if
+        (get th :comm)
+        (mau/match-multiset theory f pels sels s (get th :id))
+        (mau/match-sequence theory f pels sels s (get th :id))))))
+
+(define
+  mau/mm-app
+  (fn
+    (theory pat subj s)
+    (let
+      ((f (mau/op pat))
+        (g (mau/op subj))
+        (th (mau/th-of theory (mau/op pat))))
+      (cond
+        ((get th :assoc) (mau/mm-assoc theory f pat subj s))
+        ((get th :comm)
+          (if
+            (and
+              (= f g)
+              (= (mau/arity pat) 2)
+              (= (mau/arity subj) 2))
+            (mau/mm-comm theory pat subj s)
+            (list)))
+        (else
+          (if
+            (and (= f g) (= (mau/arity pat) (mau/arity subj)))
+            (mau/mm-args theory (mau/args pat) (mau/args subj) (list s))
+            (list)))))))
+
+;; ---------- associative (ordered) sequence matching ----------
+
+(define
+  mau/match-sequence
+  (fn
+    (theory f pels sels s id)
+    (cond
+      ((empty? pels) (if (empty? sels) (list s) (list)))
+      (else
+        (let
+          ((p (first pels)) (prest (rest pels)))
+          (if
+            (mau/var? p)
+            (mau/seq-var-loop
+              theory
+              f
+              prest
+              sels
+              s
+              (mau/vname p)
+              id
+              (mau/var-kmin (mau/vname p) id))
+            (if
+              (empty? sels)
+              (list)
+              (mau/concat-map
+                (fn
+                  (s2)
+                  (mau/match-sequence theory f prest (rest sels) s2 id))
+                (mau/mm theory p (first sels) s)))))))))
+
+(define
+  mau/seq-var-loop
+  (fn
+    (theory f prest sels s name id k)
+    (if
+      (> k (len sels))
+      (list)
+      (let
+        ((block (mau/take sels k)) (rests (mau/drop sels k)))
+        (let
+          ((val (mau/rebuild f block id)))
+          (let
+            ((s2 (mau/bind-check theory s name val)))
+            (mau/append2
+              (if
+                (= s2 nil)
+                (list)
+                (mau/match-sequence theory f prest rests s2 id))
+              (mau/seq-var-loop
+                theory
+                f
+                prest
+                sels
+                s
+                name
+                id
+                (+ k 1)))))))))
+
+;; ---------- associative-commutative (multiset) matching ----------
+
+(define
+  mau/match-multiset
+  (fn
+    (theory f pels sels s id)
+    (cond
+      ((empty? pels) (if (empty? sels) (list s) (list)))
+      (else
+        (let
+          ((p (first pels)) (prest (rest pels)))
+          (if
+            (mau/var? p)
+            (mau/ms-var-splits theory f prest sels s (mau/vname p) id)
+            (mau/ms-nonvar-loop theory f p prest sels s id 0)))))))
+
+(define
+  mau/ms-nonvar-loop
+  (fn
+    (theory f p prest sels s id i)
+    (if
+      (>= i (len sels))
+      (list)
+      (let
+        ((elem (nth sels i)) (others (mau/remove-at sels i)))
+        (mau/append2
+          (mau/concat-map
+            (fn (s2) (mau/match-multiset theory f prest others s2 id))
+            (mau/mm theory p elem s))
+          (mau/ms-nonvar-loop theory f p prest sels s id (+ i 1)))))))
+
+(define
+  mau/ms-var-splits
+  (fn
+    (theory f prest sels s name id)
+    (let
+      ((kmin (mau/var-kmin name id)))
+      (mau/concat-map
+        (fn
+          (pair)
+          (let
+            ((chosen (first pair)) (rests (nth pair 1)))
+            (if
+              (< (len chosen) kmin)
+              (list)
+              (let
+                ((val (mau/rebuild f chosen id)))
+                (let
+                  ((s2 (mau/bind-check theory s name val)))
+                  (if
+                    (= s2 nil)
+                    (list)
+                    (mau/match-multiset theory f prest rests s2 id)))))))
+        (mau/all-splits sels)))))
+
+;; ---------- public matching entry ----------
+
+(define
+  mau/match-all
+  (fn (m pat subj) (mau/mm (mau/build-theory m) pat subj {})))
+
+;; ---------- AC-aware equational rewriting ----------
+
+(define
+  mau/restv
+  (fn
+    (theory f s name)
+    (let
+      ((v (get s name)))
+      (cond
+        ((= v nil) (list))
+        ((and (mau/app? v) (= (mau/op v) "$EMPTY")) (list))
+        (else (mau/flatten-op theory f v))))))
+
+(define
+  mau/ac-eq-result
+  (fn
+    (theory f th eq s)
+    (if
+      (get th :comm)
+      (mau/ac-build
+        theory
+        f
+        (mau/append2
+          (mau/flatten-op theory f (mau/subst-apply s (get eq :rhs)))
+          (mau/restv theory f s "$R"))
+        (get th :id))
+      (mau/ac-build
+        theory
+        f
+        (mau/append2
+          (mau/restv theory f s "$L")
+          (mau/append2
+            (mau/flatten-op theory f (mau/subst-apply s (get eq :rhs)))
+            (mau/restv theory f s "$R")))
+        (get th :id)))))
+
+;; Walk the candidate matches and return the first rewrite that actually
+;; changes the term's canonical form (skips idempotency/identity no-ops).
+(define
+  mau/first-change
+  (fn
+    (theory f th eq term matches)
+    (if
+      (empty? matches)
+      nil
+      (let
+        ((result (mau/ac-eq-result theory f th eq (first matches))))
+        (if
+          (mau/ac-equal? theory result term)
+          (mau/first-change theory f th eq term (rest matches))
+          result)))))
+
+(define
+  mau/ac-rewrite-eq
+  (fn
+    (theory f th eq term)
+    (let
+      ((id (get th :id))
+        (pels (mau/flatten-op theory f (get eq :lhs)))
+        (sels (mau/flatten-op theory f term)))
+      (let
+        ((matches (if (get th :comm) (mau/match-multiset theory f (mau/append2 pels (list (mau/var "$R" ""))) sels {} id) (mau/match-sequence theory f (mau/append2 (list (mau/var "$L" "")) (mau/append2 pels (list (mau/var "$R" "")))) sels {} id))))
+        (mau/first-change theory f th eq term matches)))))
+
+(define
+  mau/ac-rewrite-top
+  (fn
+    (theory eqs term)
+    (cond
+      ((empty? eqs) nil)
+      (else
+        (let
+          ((eq (first eqs)))
+          (if
+            (= (get eq :cond) nil)
+            (let
+              ((lhs (get eq :lhs)))
+              (let
+                ((th (if (mau/app? lhs) (mau/th-of theory (mau/op lhs)) {:id nil :assoc false :comm false})))
+                (let
+                  ((r (if (and (mau/app? lhs) (get th :assoc)) (mau/ac-rewrite-eq theory (mau/op lhs) th eq term) (let ((ss (mau/mm theory lhs term {}))) (if (empty? ss) nil (mau/subst-apply (first ss) (get eq :rhs)))))))
+                  (cond
+                    ((= r nil) (mau/ac-rewrite-top theory (rest eqs) term))
+                    ((mau/ac-equal? theory r term)
+                      (mau/ac-rewrite-top theory (rest eqs) term))
+                    (else r)))))
+            (mau/ac-rewrite-top theory (rest eqs) term)))))))
+
+(define
+  mau/ac-normalize
+  (fn
+    (theory eqs term fuel)
+    (if
+      (<= fuel 0)
+      term
+      (cond
+        ((mau/var? term) term)
+        ((mau/app? term)
+          (let
+            ((nargs (map (fn (a) (mau/ac-normalize theory eqs a fuel)) (mau/args term))))
+            (let
+              ((t2 (mau/app (mau/op term) nargs)))
+              (let
+                ((r (mau/ac-rewrite-top theory eqs t2)))
+                (if
+                  (= r nil)
+                  t2
+                  (mau/ac-normalize theory eqs r (- fuel 1)))))))
+        (else term)))))
+
+(define
+  mau/ac-reduce
+  (fn
+    (m term)
+    (mau/ac-normalize
+      (mau/build-theory m)
+      (mau/module-eqs m)
+      term
+      mau/reduce-fuel)))
+
+(define
+  mau/ac-reduce-term
+  (fn (m src) (mau/ac-reduce m (mau/parse-term-in m src))))
+
+(define
+  mau/ac-reduce->str
+  (fn (m src) (mau/term->str (mau/ac-reduce-term m src))))
+
+(define
+  mau/ac-canon
+  (fn (m src) (mau/canon (mau/build-theory m) (mau/ac-reduce-term m src))))

lib/maude/meta.sx

@@ -0,0 +1,104 @@
+;; lib/maude/meta.sx — reflection / META-LEVEL (Phase 7).
+;;
+;; Reflection: a term can be represented AS DATA — another term — and meta-level
+;; functions interpret that representation. In Maude this is the META-LEVEL
+;; (upTerm/downTerm, metaReduce, metaApply, ...). Here object terms are already
+;; SX dicts; the META representation re-encodes a term as a term built from the
+;; meta-constructors `mt-var` and `mt-app`, so a represented term is itself a
+;; first-class object term you can build, inspect, and transform.
+;;
+;;   up-term(X:S)      = mt-var(X, S)            (names/sorts as constants)
+;;   up-term(f(a,b))   = mt-app(f, up(a), up(b))
+;;   down-term reverses.
+;;
+;; Meta-operations reflect object-level behaviour: metaReduce of a represented
+;; term in a module = the representation of its normal form, etc. The
+;; meta-circular law `down(metaReduce(up t)) =AC= reduce t` is exactly the
+;; statement that reflection agrees with the object level.
+
+(define
+  mau/up-term
+  (fn
+    (t)
+    (cond
+      ((mau/var? t)
+        (mau/app
+          "mt-var"
+          (list (mau/const (mau/vname t)) (mau/const (mau/vsort t)))))
+      ((mau/app? t)
+        (mau/app
+          "mt-app"
+          (cons (mau/const (mau/op t)) (map mau/up-term (mau/args t)))))
+      (else t))))
+
+(define
+  mau/down-term
+  (fn
+    (mt)
+    (cond
+      ((and (mau/app? mt) (= (mau/op mt) "mt-var"))
+        (mau/var
+          (mau/op (nth (mau/args mt) 0))
+          (mau/op (nth (mau/args mt) 1))))
+      ((and (mau/app? mt) (= (mau/op mt) "mt-app"))
+        (mau/app
+          (mau/op (first (mau/args mt)))
+          (map mau/down-term (rest (mau/args mt)))))
+      (else mt))))
+
+;; ---- reflective operations (term <-> meta-term) ----
+
+(define
+  mau/meta-reduce
+  (fn (m mt) (mau/up-term (mau/creduce m (mau/down-term mt)))))
+
+(define
+  mau/meta-rewrite
+  (fn (m mt) (mau/up-term (mau/rewrite m (mau/down-term mt)))))
+
+;; apply a named rule once at the top of the represented term; nil if it can't.
+(define
+  mau/meta-apply
+  (fn
+    (m label mt)
+    (let
+      ((theory (mau/build-theory m)) (eqs (mau/module-eqs m)))
+      (let
+        ((r (mau/rules-at-top theory eqs (mau/rules-with-label (mau/module-rules m) label) (mau/down-term mt))))
+        (if
+          (= r nil)
+          nil
+          (mau/up-term (mau/cnormalize theory eqs r mau/reduce-fuel)))))))
+
+;; ---- source-level conveniences ----
+
+(define mau/meta-up (fn (m src) (mau/up-term (mau/parse-term-in m src))))
+
+(define
+  mau/meta-reduce-src
+  (fn (m src) (mau/down-term (mau/meta-reduce m (mau/meta-up m src)))))
+
+(define
+  mau/meta-reduce-canon
+  (fn (m src) (mau/canon (mau/build-theory m) (mau/meta-reduce-src m src))))
+
+;; ---- generic theorem helper: equational proof by reduction ----
+
+(define
+  mau/meta-prove-equal?
+  (fn
+    (m srcA srcB)
+    (mau/ac-equal?
+      (mau/build-theory m)
+      (mau/creduce-term m srcA)
+      (mau/creduce-term m srcB))))
+
+;; meta-circular law: down(metaReduce(up t)) =AC= reduce(t)
+(define
+  mau/meta-circular?
+  (fn
+    (m src)
+    (mau/ac-equal?
+      (mau/build-theory m)
+      (mau/meta-reduce-src m src)
+      (mau/creduce-term m src))))

lib/maude/parser.sx

@@ -0,0 +1,710 @@
+;; lib/maude/parser.sx — Maude module parser.
+;;
+;; Consumes lib/guest/lex.sx (whitespace classes) and lib/guest/pratt.sx
+;; (operator-table lookup), plus lib/maude/term.sx (term constructors).
+;;
+;; Maude tokens are whitespace-delimited words plus the bracketing chars
+;; ( ) [ ] { } , — so an operator name like _+_ or s_ or if_then_else_fi is a
+;; single token. Statements end at a whitespace-delimited "." token.
+;;
+;; Grammar handled here:
+;;   (fmod|mod) NAME is ... (endfm|endm)
+;;   sort/sorts NAMES .
+;;   subsort/subsorts A B < C < D .
+;;   op/ops NAMES : ARITY -> RESULT [ATTRS] .
+;;   var/vars NAMES : SORT .
+;;   eq LHS = RHS [ATTRS] .       ceq LHS = RHS if COND [ATTRS] .
+;;   rl [L] : LHS => RHS .        crl [L] : LHS => RHS if COND .
+;;
+;; Terms: prefix application f(a,b) (op name may contain underscores, e.g.
+;; the prefix form _+_(2,3)); mixfix prefix s_ written `s X`; mixfix infix
+;; _+_ written `X + Y`, parsed by precedence climbing over a table built
+;; from the op declarations. Infix associativity follows `gather`: (E e)=left
+;; (default), (e E)=right (e.g. cons _:_), so `a : b : c` parses right-nested.
+
+;; ---------- tokenizer ----------
+
+(define
+  mau/special-char?
+  (fn
+    (c)
+    (or
+      (= c "(")
+      (= c ")")
+      (= c "[")
+      (= c "]")
+      (= c "{")
+      (= c "}")
+      (= c ","))))
+
+(define
+  mau/tokenize
+  (fn
+    (src)
+    (let
+      ((toks (list)) (pos 0) (n (len src)))
+      (define
+        peekc
+        (fn (o) (if (< (+ pos o) n) (nth src (+ pos o)) nil)))
+      (define curc (fn () (peekc 0)))
+      (define adv! (fn (k) (set! pos (+ pos k))))
+      (define
+        at-comment?
+        (fn
+          ()
+          (or
+            (and
+              (= (curc) "-")
+              (= (peekc 1) "-")
+              (= (peekc 2) "-"))
+            (and
+              (= (curc) "*")
+              (= (peekc 1) "*")
+              (= (peekc 2) "*")))))
+      (define
+        skip-line!
+        (fn
+          ()
+          (when
+            (and (< pos n) (not (= (curc) "\n")))
+            (do (adv! 1) (skip-line!)))))
+      (define
+        read-word!
+        (fn
+          (start)
+          (do
+            (when
+              (and
+                (< pos n)
+                (not (lex-whitespace? (curc)))
+                (not (mau/special-char? (curc))))
+              (do (adv! 1) (read-word! start)))
+            (slice src start pos))))
+      (define
+        scan!
+        (fn
+          ()
+          (cond
+            ((>= pos n) nil)
+            ((lex-whitespace? (curc)) (do (adv! 1) (scan!)))
+            ((at-comment?) (do (skip-line!) (scan!)))
+            ((mau/special-char? (curc))
+              (do (append! toks (curc)) (adv! 1) (scan!)))
+            (else (do (append! toks (read-word! pos)) (scan!))))))
+      (scan!)
+      toks)))
+
+;; ---------- list helpers ----------
+
+(define
+  mau/take
+  (fn
+    (xs k)
+    (if
+      (or (= k 0) (empty? xs))
+      (list)
+      (cons (first xs) (mau/take (rest xs) (- k 1))))))
+
+(define
+  mau/drop
+  (fn
+    (xs k)
+    (if
+      (or (= k 0) (empty? xs))
+      xs
+      (mau/drop (rest xs) (- k 1)))))
+
+(define
+  mau/append2
+  (fn
+    (xs ys)
+    (if (empty? xs) ys (cons (first xs) (mau/append2 (rest xs) ys)))))
+
+(define
+  mau/take-until
+  (fn
+    (xs tok)
+    (if
+      (or (empty? xs) (= (first xs) tok))
+      (list)
+      (cons (first xs) (mau/take-until (rest xs) tok)))))
+
+(define
+  mau/drop-until
+  (fn
+    (xs tok)
+    (cond
+      ((empty? xs) (list))
+      ((= (first xs) tok) xs)
+      (else (mau/drop-until (rest xs) tok)))))
+
+;; ---------- mixfix classification ----------
+
+(define
+  mau/op-form
+  (fn
+    (name)
+    (let
+      ((parts (split name "_")))
+      (cond
+        ((= (len parts) 1) {:kind :const :token name})
+        ((and (= (len parts) 3) (= (nth parts 0) "") (= (nth parts 2) "") (not (= (nth parts 1) "")))
+          {:kind :infix :token (nth parts 1)})
+        ((and (= (len parts) 2) (not (= (nth parts 0) "")) (= (nth parts 1) ""))
+          {:kind :prefix :token (nth parts 0)})
+        ((and (= (len parts) 2) (= (nth parts 0) "") (not (= (nth parts 1) "")))
+          {:kind :postfix :token (nth parts 1)})
+        (else {:kind :mixfix :token name})))))
+
+(define
+  mau/default-prec
+  (fn
+    (kind)
+    (cond
+      ((= kind "infix") 41)
+      ((= kind "prefix") 15)
+      ((= kind "postfix") 15)
+      (else 0))))
+
+(define
+  mau/op-prec
+  (fn
+    (op form)
+    (let
+      ((p (get (get op :attrs) :prec)))
+      (if (= p nil) (mau/default-prec (get form :kind)) p))))
+
+;; parse associativity from a gather spec: (E e)=left, (e E)=right.
+(define
+  mau/gather-assoc
+  (fn
+    (attrs)
+    (let
+      ((g (get attrs :gather)))
+      (if
+        (or (= g nil) (< (len g) 2))
+        "left"
+        (cond
+          ((= (nth g 1) "E") "right")
+          ((= (nth g 0) "E") "left")
+          (else "left"))))))
+
+(define
+  mau/build-infix-table
+  (fn
+    (ops)
+    (if
+      (empty? ops)
+      (list)
+      (let
+        ((op (first ops)) (rest-tbl (mau/build-infix-table (rest ops))))
+        (let
+          ((form (mau/op-form (get op :name))))
+          (if
+            (= (get form :kind) "infix")
+            (cons
+              (list
+                (get form :token)
+                (mau/op-prec op form)
+                (get op :name)
+                (mau/gather-assoc (get op :attrs)))
+              rest-tbl)
+            rest-tbl))))))
+
+(define
+  mau/build-prefix-table
+  (fn
+    (ops)
+    (if
+      (empty? ops)
+      (list)
+      (let
+        ((op (first ops)) (rest-tbl (mau/build-prefix-table (rest ops))))
+        (let
+          ((form (mau/op-form (get op :name))))
+          (if
+            (= (get form :kind) "prefix")
+            (cons
+              (list (get form :token) (mau/op-prec op form) (get op :name))
+              rest-tbl)
+            rest-tbl))))))
+
+;; ---------- term parsing ----------
+
+(define mau/has-colon? (fn (tok) (contains? tok ":")))
+
+(define
+  mau/atom->term
+  (fn
+    (tok vars)
+    (cond
+      ((mau/has-colon? tok)
+        (let
+          ((parts (split tok ":")))
+          (mau/var (nth parts 0) (nth parts 1))))
+      ((not (= (get vars tok) nil)) (mau/var tok (get vars tok)))
+      (else (mau/const tok)))))
+
+(define
+  mau/parse-term
+  (fn
+    (toks grammar)
+    (let
+      ((ts toks)
+        (pos 0)
+        (n (len toks))
+        (infix-tbl (get grammar :infix))
+        (prefix-tbl (get grammar :prefix))
+        (vars (get grammar :vars))
+        (prefix-rbp 1000))
+      (define tcur (fn () (if (< pos n) (nth ts pos) nil)))
+      (define
+        tpeek
+        (fn (o) (if (< (+ pos o) n) (nth ts (+ pos o)) nil)))
+      (define tadv! (fn () (set! pos (+ pos 1))))
+      (define
+        parse-args
+        (fn
+          ()
+          (if
+            (= (tcur) ")")
+            (do (tadv!) (list))
+            (let
+              ((acc (list)))
+              (define
+                more
+                (fn
+                  ()
+                  (do
+                    (append! acc (parse-expr 0))
+                    (when (= (tcur) ",") (do (tadv!) (more))))))
+              (do (more) (when (= (tcur) ")") (tadv!)) acc)))))
+      (define
+        parse-primary
+        (fn
+          ()
+          (let
+            ((t (tcur)))
+            (cond
+              ((= t "(")
+                (do
+                  (tadv!)
+                  (let
+                    ((e (parse-expr 0)))
+                    (do (when (= (tcur) ")") (tadv!)) e))))
+              ((not (= (pratt-op-lookup prefix-tbl t) nil))
+                (let
+                  ((entry (pratt-op-lookup prefix-tbl t)))
+                  (do
+                    (tadv!)
+                    (let
+                      ((operand (parse-expr prefix-rbp)))
+                      (mau/app (nth entry 2) (list operand))))))
+              ((= (tpeek 1) "(")
+                (let
+                  ((name t))
+                  (do (tadv!) (tadv!) (mau/app name (parse-args)))))
+              (else (do (tadv!) (mau/atom->term t vars)))))))
+      (define
+        parse-expr
+        (fn
+          (minbp)
+          (let
+            ((lhs (parse-primary)))
+            (define
+              climb
+              (fn
+                (acc)
+                (let
+                  ((t (tcur)))
+                  (let
+                    ((entry (if (= t nil) nil (pratt-op-lookup infix-tbl t))))
+                    (if
+                      (= entry nil)
+                      acc
+                      (let
+                        ((lbp (pratt-op-prec entry)))
+                        (if
+                          (< lbp minbp)
+                          acc
+                          (do
+                            (tadv!)
+                            (let
+                              ((rbp (if (= (nth entry 3) "right") lbp (+ lbp 1))))
+                              (let
+                                ((rhs (parse-expr rbp)))
+                                (climb
+                                  (mau/app
+                                    (nth entry 2)
+                                    (list acc rhs)))))))))))))
+            (climb lhs))))
+      (parse-expr 0))))
+
+;; ---------- statement splitting ----------
+
+(define
+  mau/split-statements
+  (fn
+    (toks)
+    (let
+      ((stmts (list)) (cur (list)))
+      (define
+        flush!
+        (fn
+          ()
+          (when
+            (not (empty? cur))
+            (do (append! stmts cur) (set! cur (list))))))
+      (define
+        loop
+        (fn
+          (ts)
+          (cond
+            ((empty? ts) (flush!))
+            ((= (first ts) ".") (do (flush!) (loop (rest ts))))
+            (else (do (append! cur (first ts)) (loop (rest ts)))))))
+      (do (loop toks) stmts))))
+
+(define
+  mau/split-groups
+  (fn
+    (toks)
+    (let
+      ((groups (list)) (cur (list)))
+      (define flush! (fn () (do (append! groups cur) (set! cur (list)))))
+      (define
+        loop
+        (fn
+          (ts)
+          (cond
+            ((empty? ts) (flush!))
+            ((= (first ts) "<") (do (flush!) (loop (rest ts))))
+            (else (do (append! cur (first ts)) (loop (rest ts)))))))
+      (do (loop toks) groups))))
+
+;; ---------- attributes ----------
+
+(define mau/strip-brackets (fn (toks) (mau/take-until (rest toks) "]")))
+
+(define
+  mau/parse-attr-tokens
+  (fn
+    (toks)
+    (let
+      ((acc {}))
+      (define
+        loop
+        (fn
+          (ts)
+          (cond
+            ((empty? ts) nil)
+            ((= (first ts) "assoc")
+              (do (dict-set! acc :assoc true) (loop (rest ts))))
+            ((= (first ts) "comm")
+              (do (dict-set! acc :comm true) (loop (rest ts))))
+            ((or (= (first ts) "idem") (= (first ts) "idempotent"))
+              (do (dict-set! acc :idem true) (loop (rest ts))))
+            ((= (first ts) "ctor")
+              (do (dict-set! acc :ctor true) (loop (rest ts))))
+            ((= (first ts) "owise")
+              (do (dict-set! acc :owise true) (loop (rest ts))))
+            ((= (first ts) "id:")
+              (do
+                (dict-set! acc :id (nth ts 1))
+                (loop (mau/drop ts 2))))
+            ((= (first ts) "prec")
+              (do
+                (dict-set! acc :prec (parse-number (nth ts 1)))
+                (loop (mau/drop ts 2))))
+            ((= (first ts) "label")
+              (do
+                (dict-set! acc :label (nth ts 1))
+                (loop (mau/drop ts 2))))
+            ((= (first ts) "gather")
+              (let
+                ((after2 (mau/drop ts 2)))
+                (do
+                  (dict-set! acc :gather (mau/take-until after2 ")"))
+                  (loop (rest (mau/drop-until after2 ")"))))))
+            (else (loop (rest ts))))))
+      (do (loop toks) acc))))
+
+(define
+  mau/parse-attrs
+  (fn
+    (toks)
+    (if
+      (or (empty? toks) (not (= (first toks) "[")))
+      {}
+      (mau/parse-attr-tokens (mau/strip-brackets toks)))))
+
+;; Split a token sequence into {:term tokens-before-bracket :attrs parsed}.
+(define mau/split-attrs (fn (toks) {:attrs (mau/parse-attrs (mau/drop-until toks "[")) :term (mau/take-until toks "[")}))
+
+;; ---------- signature collection ----------
+
+(define
+  mau/append-each!
+  (fn (acc xs) (for-each (fn (x) (append! acc x)) xs)))
+
+(define
+  mau/register-ops!
+  (fn
+    (ops names arity result attrs)
+    (for-each (fn (nm) (append! ops {:name nm :attrs attrs :arity arity :result result})) names)))
+
+(define
+  mau/each-set-var!
+  (fn
+    (vars names sort)
+    (for-each (fn (nm) (dict-set! vars nm sort)) names)))
+
+(define
+  mau/cross-append!
+  (fn
+    (acc g1 g2)
+    (for-each
+      (fn
+        (sub)
+        (for-each (fn (super) (append! acc (list sub super))) g2))
+      g1)))
+
+(define
+  mau/add-subsort-chain!
+  (fn
+    (acc groups)
+    (when
+      (and (not (empty? groups)) (not (empty? (rest groups))))
+      (do
+        (mau/cross-append! acc (first groups) (nth groups 1))
+        (mau/add-subsort-chain! acc (rest groups))))))
+
+(define
+  mau/add-subsorts!
+  (fn (acc body) (mau/add-subsort-chain! acc (mau/split-groups body))))
+
+(define
+  mau/add-vars!
+  (fn
+    (vars body)
+    (let
+      ((names (mau/take-until body ":"))
+        (sort (first (rest (mau/drop-until body ":")))))
+      (mau/each-set-var! vars names sort))))
+
+(define
+  mau/add-ops!
+  (fn
+    (ops body)
+    (let
+      ((names (mau/take-until body ":"))
+        (afterc (rest (mau/drop-until body ":"))))
+      (let
+        ((arity (mau/take-until afterc "->"))
+          (aftera (rest (mau/drop-until afterc "->"))))
+        (let
+          ((result (first aftera))
+            (attrs (mau/parse-attrs (mau/drop aftera 1))))
+          (mau/register-ops! ops names arity result attrs))))))
+
+(define
+  mau/collect-sig!
+  (fn
+    (stmts sorts subsorts ops vars)
+    (for-each
+      (fn
+        (s)
+        (let
+          ((head (first s)) (body (rest s)))
+          (cond
+            ((or (= head "sort") (= head "sorts"))
+              (mau/append-each! sorts body))
+            ((or (= head "subsort") (= head "subsorts"))
+              (mau/add-subsorts! subsorts body))
+            ((or (= head "op") (= head "ops")) (mau/add-ops! ops body))
+            ((or (= head "var") (= head "vars")) (mau/add-vars! vars body))
+            (else nil))))
+      stmts)))
+
+;; ---------- equations / rules ----------
+
+(define
+  mau/parse-cond
+  (fn
+    (toks grammar)
+    (if
+      (mau/member? "=" toks)
+      (let
+        ((l (mau/take-until toks "="))
+          (r (rest (mau/drop-until toks "="))))
+        {:lhs (mau/parse-term l grammar) :kind :eq :rhs (mau/parse-term r grammar)})
+      {:kind :bool :term (mau/parse-term toks grammar)})))
+
+(define
+  mau/parse-eq
+  (fn
+    (body grammar conditional?)
+    (let
+      ((lhs-toks (mau/take-until body "="))
+        (after (rest (mau/drop-until body "="))))
+      (if
+        conditional?
+        (let
+          ((rhs-toks (mau/take-until after "if"))
+            (cond-raw (rest (mau/drop-until after "if"))))
+          (let ((csplit (mau/split-attrs cond-raw))) {:lhs (mau/parse-term lhs-toks grammar) :t :eq :cond (mau/parse-cond (get csplit :term) grammar) :rhs (mau/parse-term rhs-toks grammar) :owise (= (get (get csplit :attrs) :owise) true)}))
+        (let ((rsplit (mau/split-attrs after))) {:lhs (mau/parse-term lhs-toks grammar) :t :eq :cond nil :rhs (mau/parse-term (get rsplit :term) grammar) :owise (= (get (get rsplit :attrs) :owise) true)})))))
+
+(define
+  mau/strip-label
+  (fn
+    (body)
+    (if
+      (and (not (empty? body)) (= (first body) "["))
+      (let
+        ((label (nth body 1)) (after (mau/drop body 3)))
+        (if
+          (and (not (empty? after)) (= (first after) ":"))
+          {:label label :rest (rest after)}
+          {:label label :rest after}))
+      {:label nil :rest body})))
+
+(define
+  mau/parse-rule
+  (fn
+    (body grammar conditional?)
+    (let
+      ((b (mau/strip-label body)))
+      (let
+        ((label (get b :label)) (rest-toks (get b :rest)))
+        (let
+          ((lhs-toks (mau/take-until rest-toks "=>"))
+            (after (rest (mau/drop-until rest-toks "=>"))))
+          (if
+            conditional?
+            (let
+              ((rhs-toks (mau/take-until after "if"))
+                (cond-toks (rest (mau/drop-until after "if"))))
+              {:lhs (mau/parse-term lhs-toks grammar) :label label :t :rule :cond (mau/parse-cond (get (mau/split-attrs cond-toks) :term) grammar) :rhs (mau/parse-term rhs-toks grammar)})
+            {:lhs (mau/parse-term lhs-toks grammar) :label label :t :rule :cond nil :rhs (mau/parse-term (get (mau/split-attrs after) :term) grammar)}))))))
+
+(define
+  mau/collect-rules!
+  (fn
+    (stmts grammar eqs rules)
+    (for-each
+      (fn
+        (s)
+        (let
+          ((head (first s)) (body (rest s)))
+          (cond
+            ((= head "eq") (append! eqs (mau/parse-eq body grammar false)))
+            ((= head "ceq") (append! eqs (mau/parse-eq body grammar true)))
+            ((= head "rl")
+              (append! rules (mau/parse-rule body grammar false)))
+            ((= head "crl")
+              (append! rules (mau/parse-rule body grammar true)))
+            (else nil))))
+      stmts)))
+
+;; ---------- module assembly ----------
+
+(define mau/make-grammar (fn (ops vars) {:prefix (mau/build-prefix-table ops) :ops ops :vars vars :infix (mau/build-infix-table ops)}))
+
+(define
+  mau/build-module
+  (fn
+    (kind name body)
+    (let
+      ((stmts (mau/split-statements body))
+        (sorts (list))
+        (subsorts (list))
+        (ops (list))
+        (vars {})
+        (eqs (list))
+        (rules (list)))
+      (mau/collect-sig! stmts sorts subsorts ops vars)
+      (let
+        ((grammar (mau/make-grammar ops vars)))
+        (mau/collect-rules! stmts grammar eqs rules)
+        {:name name :grammar grammar :sorts sorts :eqs eqs :ops ops :t :module :vars vars :subsorts subsorts :kind kind :rules rules}))))
+
+(define
+  mau/parse-module
+  (fn
+    (src)
+    (let
+      ((toks (mau/tokenize src)))
+      (let
+        ((kind (nth toks 0)) (name (nth toks 1)))
+        (let
+          ((body (mau/take (mau/drop toks 3) (- (len toks) 4))))
+          (mau/build-module kind name body))))))
+
+;; ---------- signature queries ----------
+
+(define mau/module-name (fn (m) (get m :name)))
+(define mau/module-kind (fn (m) (get m :kind)))
+(define mau/module-sorts (fn (m) (get m :sorts)))
+(define mau/module-subsorts (fn (m) (get m :subsorts)))
+(define mau/module-ops (fn (m) (get m :ops)))
+(define mau/module-vars (fn (m) (get m :vars)))
+(define mau/module-eqs (fn (m) (get m :eqs)))
+(define mau/module-rules (fn (m) (get m :rules)))
+(define mau/module-grammar (fn (m) (get m :grammar)))
+
+(define
+  mau/parse-term-in
+  (fn (m src) (mau/parse-term (mau/tokenize src) (mau/module-grammar m))))
+
+(define
+  mau/collect-supers
+  (fn
+    (pairs s)
+    (cond
+      ((empty? pairs) (list))
+      ((= (first (first pairs)) s)
+        (cons
+          (nth (first pairs) 1)
+          (mau/collect-supers (rest pairs) s)))
+      (else (mau/collect-supers (rest pairs) s)))))
+
+(define mau/supers-of (fn (m s) (mau/collect-supers (get m :subsorts) s)))
+
+(define
+  mau/dfs-reach
+  (fn
+    (m frontier target seen)
+    (cond
+      ((empty? frontier) false)
+      ((= (first frontier) target) true)
+      ((mau/member? (first frontier) seen)
+        (mau/dfs-reach m (rest frontier) target seen))
+      (else
+        (mau/dfs-reach
+          m
+          (mau/append2 (mau/supers-of m (first frontier)) (rest frontier))
+          target
+          (cons (first frontier) seen))))))
+
+(define
+  mau/subsort?
+  (fn
+    (m sub super)
+    (mau/dfs-reach m (mau/supers-of m sub) super (list sub))))
+
+(define mau/sort<=? (fn (m a b) (or (= a b) (mau/subsort? m a b))))
+
+(define
+  mau/filter-ops
+  (fn
+    (ops name)
+    (cond
+      ((empty? ops) (list))
+      ((= (get (first ops) :name) name)
+        (cons (first ops) (mau/filter-ops (rest ops) name)))
+      (else (mau/filter-ops (rest ops) name)))))
+
+(define
+  mau/ops-named
+  (fn (m name) (mau/filter-ops (mau/module-ops m) name)))

lib/maude/pretty.sx

@@ -0,0 +1,82 @@
+;; lib/maude/pretty.sx — mixfix surface-syntax printer.
+;;
+;; term->str renders the internal prefix form (`_+_(s_(X), 0)`); this renders
+;; terms back in Maude mixfix surface syntax (`((s X) + 0)`), driven by the
+;; operator forms in the module signature. Fully parenthesised — unambiguous
+;; rather than minimal. Constants and unknown ops fall back to prefix form.
+
+(define
+  mau/render-forms
+  (fn
+    (m)
+    (let
+      ((tbl {}))
+      (for-each
+        (fn
+          (op)
+          (dict-set! tbl (get op :name) (mau/op-form (get op :name))))
+        (mau/module-ops m))
+      tbl)))
+
+(define
+  mau/render-args
+  (fn
+    (forms args)
+    (cond
+      ((empty? args) "")
+      ((empty? (rest args)) (mau/render-term forms (first args)))
+      (else
+        (str
+          (mau/render-term forms (first args))
+          ", "
+          (mau/render-args forms (rest args)))))))
+
+(define
+  mau/render-term
+  (fn
+    (forms t)
+    (cond
+      ((mau/var? t) (mau/vname t))
+      ((mau/app? t)
+        (let
+          ((form (get forms (mau/op t))) (args (mau/args t)))
+          (cond
+            ((empty? args) (mau/op t))
+            ((and form (= (get form :kind) "infix") (= (len args) 2))
+              (str
+                "("
+                (mau/render-term forms (nth args 0))
+                " "
+                (get form :token)
+                " "
+                (mau/render-term forms (nth args 1))
+                ")"))
+            ((and form (= (get form :kind) "prefix") (= (len args) 1))
+              (str
+                "("
+                (get form :token)
+                " "
+                (mau/render-term forms (first args))
+                ")"))
+            ((and form (= (get form :kind) "postfix") (= (len args) 1))
+              (str
+                "("
+                (mau/render-term forms (first args))
+                " "
+                (get form :token)
+                ")"))
+            (else (str (mau/op t) "(" (mau/render-args forms args) ")")))))
+      (else (str t)))))
+
+(define
+  mau/term->maude
+  (fn (m t) (mau/render-term (mau/render-forms m) t)))
+
+;; reduce / rewrite then render in surface syntax
+(define
+  mau/red->maude
+  (fn (m src) (mau/term->maude m (mau/creduce-term m src))))
+
+(define
+  mau/rew->maude
+  (fn (m src) (mau/term->maude m (mau/rewrite-term m src))))

lib/maude/reduce.sx

@@ -0,0 +1,143 @@
+;; lib/maude/reduce.sx — syntactic equational reduction (Phase 2).
+;;
+;; Apply unconditional equations left-to-right to a fixpoint, using strict
+;; one-sided syntactic matching (no theories yet — assoc/comm/id come in
+;; Phase 3). Reduction is innermost: arguments are normalised before the
+;; enclosing operator is rewritten.
+;;
+;; A substitution is a dict VAR-NAME -> term, extended immutably via `assoc`.
+;; Matching is one-sided: only the pattern (equation LHS) carries variables;
+;; the subject is treated structurally.
+
+;; ---------- matching ----------
+
+(define
+  mau/match
+  (fn
+    (pat subj s)
+    (cond
+      ((= s nil) nil)
+      ((mau/var? pat)
+        (let
+          ((bound (get s (mau/vname pat))))
+          (if
+            (= bound nil)
+            (assoc s (mau/vname pat) subj)
+            (if (mau/term=? bound subj) s nil))))
+      ((and (mau/app? pat) (mau/app? subj))
+        (if
+          (and
+            (= (mau/op pat) (mau/op subj))
+            (= (mau/arity pat) (mau/arity subj)))
+          (mau/match-args (mau/args pat) (mau/args subj) s)
+          nil))
+      (else nil))))
+
+(define
+  mau/match-args
+  (fn
+    (ps ss s)
+    (cond
+      ((= s nil) nil)
+      ((and (empty? ps) (empty? ss)) s)
+      ((or (empty? ps) (empty? ss)) nil)
+      (else
+        (mau/match-args
+          (rest ps)
+          (rest ss)
+          (mau/match (first ps) (first ss) s))))))
+
+;; ---------- substitution application ----------
+
+(define
+  mau/subst-apply-list
+  (fn
+    (s args)
+    (if
+      (empty? args)
+      (list)
+      (cons
+        (mau/subst-apply s (first args))
+        (mau/subst-apply-list s (rest args))))))
+
+(define
+  mau/subst-apply
+  (fn
+    (s term)
+    (cond
+      ((mau/var? term)
+        (let ((b (get s (mau/vname term)))) (if (= b nil) term b)))
+      ((mau/app? term)
+        (mau/app (mau/op term) (mau/subst-apply-list s (mau/args term))))
+      (else term))))
+
+;; ---------- top-level rewrite ----------
+
+;; Try each unconditional equation in order; on the first whose LHS matches
+;; the term, return the instantiated RHS. nil if none apply.
+(define
+  mau/rewrite-top
+  (fn
+    (eqs term)
+    (cond
+      ((empty? eqs) nil)
+      (else
+        (let
+          ((eq (first eqs)))
+          (if
+            (= (get eq :cond) nil)
+            (let
+              ((s (mau/match (get eq :lhs) term {})))
+              (if
+                (= s nil)
+                (mau/rewrite-top (rest eqs) term)
+                (mau/subst-apply s (get eq :rhs))))
+            (mau/rewrite-top (rest eqs) term)))))))
+
+;; ---------- normalisation (innermost to fixpoint) ----------
+
+(define
+  mau/normalize-args
+  (fn
+    (eqs args fuel)
+    (if
+      (empty? args)
+      (list)
+      (cons
+        (mau/normalize eqs (first args) fuel)
+        (mau/normalize-args eqs (rest args) fuel)))))
+
+(define
+  mau/normalize
+  (fn
+    (eqs term fuel)
+    (if
+      (<= fuel 0)
+      term
+      (cond
+        ((mau/var? term) term)
+        ((mau/app? term)
+          (let
+            ((nargs (mau/normalize-args eqs (mau/args term) fuel)))
+            (let
+              ((t2 (mau/app (mau/op term) nargs)))
+              (let
+                ((r (mau/rewrite-top eqs t2)))
+                (if (= r nil) t2 (mau/normalize eqs r (- fuel 1)))))))
+        (else term)))))
+
+;; ---------- module-level API ----------
+
+(define mau/reduce-fuel 1000000)
+
+(define
+  mau/reduce
+  (fn (m term) (mau/normalize (mau/module-eqs m) term mau/reduce-fuel)))
+
+(define
+  mau/reduce-term
+  (fn (m src) (mau/reduce m (mau/parse-term-in m src))))
+
+(define
+  mau/reduce->str
+  (fn (m src) (mau/term->str (mau/reduce-term m src))))

lib/maude/rewrite.sx

@@ -0,0 +1,284 @@
+;; lib/maude/rewrite.sx — system modules + rewrite rules (Phase 5).
+;;
+;; Equations (eq/ceq) are applied to a fixpoint to NORMALISE (confluent by
+;; intent). Rules (rl/crl) are TRANSITIONS: asymmetric (=>), possibly
+;; nondeterministic, NOT applied to a fixpoint. Maude's `rew` interleaves
+;; the two: normalise with equations, fire one rule, renormalise, repeat.
+;;
+;; Rule firing reuses the shared firing machinery — a rule dict carries
+;; :lhs/:rhs/:cond exactly like an equation, so `mau/fire-eq` (short-circuit,
+;; fire.sx) applies unchanged (matching modulo the AC theory; crl guards
+;; evaluated with the equations). A rule fires only if it both progresses and
+;; its condition holds.
+;;
+;; `mau/rewrite` follows the default strategy (top-down, leftmost-outermost,
+;; first applicable rule) for one path. `mau/search` does breadth-first reach
+;; over ALL one-step successors — for puzzle solvers / protocol simulators
+;; where the answer is on a branch `rew` would not take.
+
+(define mau/rew-fuel 100000)
+
+;; ---- single-step, default strategy (first applicable, leftmost-outermost) ----
+
+(define
+  mau/rules-at-top
+  (fn
+    (theory eqs rules term)
+    (if
+      (empty? rules)
+      nil
+      (let
+        ((r (mau/fire-eq theory eqs (first rules) term)))
+        (if (= r nil) (mau/rules-at-top theory eqs (rest rules) term) r)))))
+
+(define
+  mau/apply-rule-once
+  (fn
+    (theory eqs rules term)
+    (let
+      ((top (mau/rules-at-top theory eqs rules term)))
+      (if
+        (not (= top nil))
+        top
+        (if
+          (mau/app? term)
+          (mau/apply-rule-in-args
+            theory
+            eqs
+            rules
+            (mau/op term)
+            (mau/args term)
+            (list))
+          nil)))))
+
+(define
+  mau/apply-rule-in-args
+  (fn
+    (theory eqs rules op done todo)
+    (if
+      (empty? todo)
+      nil
+      (let
+        ((r (mau/apply-rule-once theory eqs rules (first todo))))
+        (if
+          (= r nil)
+          (mau/apply-rule-in-args
+            theory
+            eqs
+            rules
+            op
+            (mau/append2 done (list (first todo)))
+            (rest todo))
+          (mau/app op (mau/append2 done (cons r (rest todo)))))))))
+
+(define
+  mau/rewrite-steps
+  (fn
+    (theory eqs rules term steps)
+    (if
+      (<= steps 0)
+      (mau/cnormalize theory eqs term mau/reduce-fuel)
+      (let
+        ((nf (mau/cnormalize theory eqs term mau/reduce-fuel)))
+        (let
+          ((r (mau/apply-rule-once theory eqs rules nf)))
+          (if
+            (= r nil)
+            nf
+            (mau/rewrite-steps theory eqs rules r (- steps 1))))))))
+
+(define
+  mau/rewrite
+  (fn
+    (m term)
+    (mau/rewrite-steps
+      (mau/build-theory m)
+      (mau/module-eqs m)
+      (mau/module-rules m)
+      term
+      mau/rew-fuel)))
+
+(define
+  mau/rew
+  (fn
+    (m src n)
+    (mau/rewrite-steps
+      (mau/build-theory m)
+      (mau/module-eqs m)
+      (mau/module-rules m)
+      (mau/parse-term-in m src)
+      n)))
+
+(define
+  mau/rewrite-term
+  (fn (m src) (mau/rewrite m (mau/parse-term-in m src))))
+
+(define
+  mau/rewrite->str
+  (fn (m src) (mau/term->str (mau/rewrite-term m src))))
+
+(define
+  mau/rewrite-canon
+  (fn (m src) (mau/canon (mau/build-theory m) (mau/rewrite-term m src))))
+
+(define mau/rew->str (fn (m src n) (mau/term->str (mau/rew m src n))))
+
+(define
+  mau/rew-canon
+  (fn (m src n) (mau/canon (mau/build-theory m) (mau/rew m src n))))
+
+;; ---- all one-step successors (for search; eager enumeration) ----
+
+(define
+  mau/cands-results
+  (fn
+    (theory eqs cond term cands)
+    (mau/concat-map
+      (fn
+        (c)
+        (if
+          (and
+            (not (mau/ac-equal? theory (get c :result) term))
+            (mau/cond-holds? theory eqs cond (get c :s)))
+          (list (mau/cnormalize theory eqs (get c :result) mau/reduce-fuel))
+          (list)))
+      cands)))
+
+(define
+  mau/top-successors
+  (fn
+    (theory eqs rules term)
+    (mau/concat-map
+      (fn
+        (rule)
+        (mau/cands-results
+          theory
+          eqs
+          (get rule :cond)
+          term
+          (mau/eq-candidates theory rule term)))
+      rules)))
+
+(define
+  mau/arg-successors
+  (fn
+    (theory eqs rules op done todo)
+    (if
+      (empty? todo)
+      (list)
+      (mau/append2
+        (map
+          (fn
+            (sub)
+            (mau/app op (mau/append2 done (cons sub (rest todo)))))
+          (mau/all-successors theory eqs rules (first todo)))
+        (mau/arg-successors
+          theory
+          eqs
+          rules
+          op
+          (mau/append2 done (list (first todo)))
+          (rest todo))))))
+
+(define
+  mau/all-successors
+  (fn
+    (theory eqs rules term)
+    (mau/append2
+      (mau/top-successors theory eqs rules term)
+      (if
+        (mau/app? term)
+        (mau/arg-successors
+          theory
+          eqs
+          rules
+          (mau/op term)
+          (mau/args term)
+          (list))
+        (list)))))
+
+(define
+  mau/successors
+  (fn
+    (m src)
+    (let
+      ((theory (mau/build-theory m)) (eqs (mau/module-eqs m)))
+      (map
+        (fn (t) (mau/canon theory t))
+        (mau/all-successors
+          theory
+          eqs
+          (mau/module-rules m)
+          (mau/cnormalize
+            theory
+            eqs
+            (mau/parse-term-in m src)
+            mau/reduce-fuel))))))
+
+;; ---- breadth-first reachability search ----
+
+(define
+  mau/canon-list
+  (fn (theory ts) (map (fn (t) (mau/canon theory t)) ts)))
+
+(define
+  mau/bfs-search
+  (fn
+    (theory eqs rules frontier seen goal depth)
+    (cond
+      ((mau/member? goal (mau/canon-list theory frontier)) true)
+      ((<= depth 0) false)
+      ((empty? frontier) false)
+      (else
+        (let
+          ((newf (list)) (newseen seen))
+          (for-each
+            (fn
+              (t)
+              (for-each
+                (fn
+                  (succ)
+                  (let
+                    ((c (mau/canon theory succ)))
+                    (when
+                      (not (mau/member? c newseen))
+                      (do
+                        (set! newseen (cons c newseen))
+                        (append! newf succ)))))
+                (mau/all-successors theory eqs rules t)))
+            frontier)
+          (mau/bfs-search
+            theory
+            eqs
+            rules
+            newf
+            newseen
+            goal
+            (- depth 1)))))))
+
+(define
+  mau/search
+  (fn
+    (m start-src goal-src max-depth)
+    (let
+      ((theory (mau/build-theory m))
+        (eqs (mau/module-eqs m))
+        (rules (mau/module-rules m)))
+      (let
+        ((start (mau/cnormalize theory eqs (mau/parse-term-in m start-src) mau/reduce-fuel))
+          (goal
+            (mau/canon
+              theory
+              (mau/cnormalize
+                theory
+                eqs
+                (mau/parse-term-in m goal-src)
+                mau/reduce-fuel))))
+        (mau/bfs-search
+          theory
+          eqs
+          rules
+          (list start)
+          (list (mau/canon theory start))
+          goal
+          max-depth)))))

lib/maude/run.sx

@@ -0,0 +1,132 @@
+;; lib/maude/run.sx — run a Maude program: a module followed by commands.
+;;
+;; Parses a single fmod/mod ... endfm/endm module plus trailing commands and
+;; executes them, Maude-style:
+;;   reduce TERM .   (alias: red)   — normalise with equations
+;;   rewrite TERM .  (alias: rew)   — apply rules under the default strategy
+;;   search START =>* GOAL .         — reachability (=>*, =>+, =>! all treated
+;;                                     as reachability); reports the path
+;; `... in MODNAME : TERM .` is accepted (the module qualifier is ignored —
+;; there is one module in scope). reduce/rewrite results carry the least sort,
+;; rendered Maude-style by mau/run-pretty as `result SORT: TERM`.
+
+(define mau/search-depth 200)
+
+(define
+  mau/module-end-idx
+  (fn
+    (toks i)
+    (cond
+      ((>= i (len toks)) (- 0 1))
+      ((or (= (nth toks i) "endfm") (= (nth toks i) "endm")) i)
+      (else (mau/module-end-idx toks (+ i 1))))))
+
+(define
+  mau/parse-module-from-toks
+  (fn
+    (toks)
+    (let
+      ((kind (nth toks 0)) (name (nth toks 1)))
+      (mau/build-module
+        kind
+        name
+        (mau/take (mau/drop toks 3) (- (len toks) 4))))))
+
+(define
+  mau/strip-in
+  (fn
+    (toks)
+    (if
+      (and (not (empty? toks)) (= (first toks) "in"))
+      (rest (mau/drop-until toks ":"))
+      toks)))
+
+(define
+  mau/find-arrow
+  (fn
+    (toks)
+    (cond
+      ((empty? toks) nil)
+      ((and (>= (len (first toks)) 2) (= (slice (first toks) 0 2) "=>"))
+        (first toks))
+      (else (mau/find-arrow (rest toks))))))
+
+(define
+  mau/run-search
+  (fn
+    (m term-toks)
+    (let
+      ((arrow (mau/find-arrow term-toks)) (g (mau/module-grammar m)))
+      (if
+        (= arrow nil)
+        {:path nil :cmd "search" :result "no arrow"}
+        (let
+          ((start-toks (mau/take-until term-toks arrow))
+            (goal-toks (rest (mau/drop-until term-toks arrow))))
+          (let
+            ((path (mau/search-path-terms m (mau/parse-term start-toks g) (mau/parse-term goal-toks g) mau/search-depth)))
+            {:path path :cmd "search" :result (if (= path nil) "no solution" (join " => " path))}))))))
+
+(define
+  mau/run-command
+  (fn
+    (m stmt)
+    (let
+      ((head (first stmt)))
+      (if
+        (or (= head "search") (= head "srch"))
+        (mau/run-search m (rest stmt))
+        (let
+          ((t (mau/parse-term (mau/strip-in (rest stmt)) (mau/module-grammar m))))
+          (cond
+            ((or (= head "reduce") (= head "red"))
+              (let ((r (mau/creduce m t))) {:cmd "reduce" :sort (mau/term-sort m r) :result (mau/term->maude m r)}))
+            ((or (= head "rewrite") (= head "rew"))
+              (let ((r (mau/rewrite m t))) {:cmd "rewrite" :sort (mau/term-sort m r) :result (mau/term->maude m r)}))
+            (else {:cmd head :result "?"})))))))
+
+(define
+  mau/run-commands
+  (fn
+    (m stmts)
+    (if
+      (empty? stmts)
+      (list)
+      (if
+        (empty? (first stmts))
+        (mau/run-commands m (rest stmts))
+        (cons
+          (mau/run-command m (first stmts))
+          (mau/run-commands m (rest stmts)))))))
+
+(define
+  mau/run-program
+  (fn
+    (src)
+    (let
+      ((toks (mau/tokenize src)))
+      (let
+        ((eidx (mau/module-end-idx toks 0)))
+        (let
+          ((m (mau/parse-module-from-toks (mau/take toks (+ eidx 1))))
+            (cmd-toks (mau/drop toks (+ eidx 1))))
+          (mau/run-commands m (mau/split-statements cmd-toks)))))))
+
+;; just the rendered result strings
+(define
+  mau/run
+  (fn (src) (map (fn (r) (get r :result)) (mau/run-program src))))
+
+;; Maude-style printout: `result SORT: TERM` for reduce/rewrite, the path for search
+(define
+  mau/run-pretty
+  (fn
+    (src)
+    (map
+      (fn
+        (r)
+        (if
+          (= (get r :cmd) "search")
+          (str "search: " (get r :result))
+          (str "result " (get r :sort) ": " (get r :result))))
+      (mau/run-program src))))

lib/maude/scoreboard.json

@@ -0,0 +1,24 @@
+{
+  "lang": "maude",
+  "total_passed": 274,
+  "total_failed": 0,
+  "total": 274,
+  "suites": [
+    {"name":"parse","passed":65,"failed":0,"total":65},
+    {"name":"reduce","passed":26,"failed":0,"total":26},
+    {"name":"matching","passed":28,"failed":0,"total":28},
+    {"name":"confluence","passed":12,"failed":0,"total":12},
+    {"name":"conditional","passed":19,"failed":0,"total":19},
+    {"name":"owise","passed":8,"failed":0,"total":8},
+    {"name":"gather","passed":7,"failed":0,"total":7},
+    {"name":"sorts","passed":14,"failed":0,"total":14},
+    {"name":"rewrite","passed":21,"failed":0,"total":21},
+    {"name":"searchpath","passed":8,"failed":0,"total":8},
+    {"name":"strategy","passed":19,"failed":0,"total":19},
+    {"name":"meta","passed":18,"failed":0,"total":18},
+    {"name":"pretty","passed":11,"failed":0,"total":11},
+    {"name":"run","passed":10,"failed":0,"total":10},
+    {"name":"effects","passed":8,"failed":0,"total":8}
+  ],
+  "generated": "2026-06-07T20:18:07+00:00"
+}

lib/maude/scoreboard.md

@@ -0,0 +1,21 @@
+# maude scoreboard
+
+**274 / 274 passing** (0 failure(s)).
+
+| Suite | Passed | Total | Status |
+|-------|--------|-------|--------|
+| parse | 65 | 65 | ok |
+| reduce | 26 | 26 | ok |
+| matching | 28 | 28 | ok |
+| confluence | 12 | 12 | ok |
+| conditional | 19 | 19 | ok |
+| owise | 8 | 8 | ok |
+| gather | 7 | 7 | ok |
+| sorts | 14 | 14 | ok |
+| rewrite | 21 | 21 | ok |
+| searchpath | 8 | 8 | ok |
+| strategy | 19 | 19 | ok |
+| meta | 18 | 18 | ok |
+| pretty | 11 | 11 | ok |
+| run | 10 | 10 | ok |
+| effects | 8 | 8 | ok |

lib/maude/searchpath.sx

@@ -0,0 +1,103 @@
+;; lib/maude/searchpath.sx — reachability search returning the witness path.
+;;
+;; mau/search (rewrite.sx) answers yes/no. For puzzle solvers you want the
+;; actual sequence of states from start to goal. mau/search-path runs the same
+;; BFS but threads the path so far; it returns the list of canonical states
+;; start..goal (shortest by step count) or nil if unreachable within depth.
+
+(define mau/reverse2 (fn (xs) (mau/rev-acc xs (list))))
+
+(define
+  mau/rev-acc
+  (fn
+    (xs acc)
+    (if (empty? xs) acc (mau/rev-acc (rest xs) (cons (first xs) acc)))))
+
+;; find a frontier path whose current state (its head) matches the goal canon
+(define
+  mau/path-hit
+  (fn
+    (theory frontier goal)
+    (cond
+      ((empty? frontier) nil)
+      ((= (mau/canon theory (first (first frontier))) goal)
+        (first frontier))
+      (else (mau/path-hit theory (rest frontier) goal)))))
+
+(define
+  mau/bfs-path
+  (fn
+    (theory eqs rules frontier seen goal depth)
+    (let
+      ((hit (mau/path-hit theory frontier goal)))
+      (cond
+        ((not (= hit nil)) hit)
+        ((<= depth 0) nil)
+        ((empty? frontier) nil)
+        (else
+          (let
+            ((newf (list)) (newseen seen))
+            (for-each
+              (fn
+                (path)
+                (for-each
+                  (fn
+                    (succ)
+                    (let
+                      ((c (mau/canon theory succ)))
+                      (when
+                        (not (mau/member? c newseen))
+                        (do
+                          (set! newseen (cons c newseen))
+                          (append! newf (cons succ path))))))
+                  (mau/all-successors theory eqs rules (first path))))
+              frontier)
+            (mau/bfs-path
+              theory
+              eqs
+              rules
+              newf
+              newseen
+              goal
+              (- depth 1))))))))
+
+;; term-level: returns the canonical-state path start..goal, or nil
+(define
+  mau/search-path-terms
+  (fn
+    (m start-term goal-term max-depth)
+    (let
+      ((theory (mau/build-theory m))
+        (eqs (mau/module-eqs m))
+        (rules (mau/module-rules m)))
+      (let
+        ((start (mau/cnormalize theory eqs start-term mau/reduce-fuel))
+          (goal
+            (mau/canon
+              theory
+              (mau/cnormalize theory eqs goal-term mau/reduce-fuel))))
+        (let
+          ((res (mau/bfs-path theory eqs rules (list (list start)) (list (mau/canon theory start)) goal max-depth)))
+          (if
+            (= res nil)
+            nil
+            (map (fn (t) (mau/canon theory t)) (mau/reverse2 res))))))))
+
+(define
+  mau/search-path
+  (fn
+    (m start-src goal-src max-depth)
+    (mau/search-path-terms
+      m
+      (mau/parse-term-in m start-src)
+      (mau/parse-term-in m goal-src)
+      max-depth)))
+
+;; number of steps in the shortest solution (nil if unreachable)
+(define
+  mau/search-length
+  (fn
+    (m start-src goal-src max-depth)
+    (let
+      ((p (mau/search-path m start-src goal-src max-depth)))
+      (if (= p nil) nil (- (len p) 1)))))

lib/maude/sorts.sx

@@ -0,0 +1,87 @@
+;; lib/maude/sorts.sx — order-sorted least-sort inference.
+;;
+;; Order-sorted signatures: subsorts induce a partial order on sorts, and an
+;; overloaded operator can have several declarations. The LEAST SORT of a term
+;; is the smallest result sort among the operator declarations whose argument
+;; sorts the actual arguments satisfy (modulo subsorting). This is what lets
+;; `f(1)` be a NzNat while `f(s 0)` is only a Nat when f is declared at both.
+;;
+;;   mau/term-sort   M T        -> least sort of T (string, "?" if unknown)
+;;   mau/has-sort?   M T SORT   -> does T's least sort fit under SORT?
+
+(define
+  mau/arg-sorts-ok?
+  (fn
+    (m argsorts declared)
+    (cond
+      ((and (empty? argsorts) (empty? declared)) true)
+      ((or (empty? argsorts) (empty? declared)) false)
+      ((mau/sort<=? m (first argsorts) (first declared))
+        (mau/arg-sorts-ok? m (rest argsorts) (rest declared)))
+      (else false))))
+
+(define
+  mau/matching-ops
+  (fn
+    (m name argsorts)
+    (filter
+      (fn
+        (op)
+        (and
+          (= (len (get op :arity)) (len argsorts))
+          (mau/arg-sorts-ok? m argsorts (get op :arity))))
+      (mau/ops-named m name))))
+
+(define
+  mau/least-loop
+  (fn
+    (m best rst)
+    (cond
+      ((empty? rst) best)
+      ((mau/sort<=? m (first rst) best)
+        (mau/least-loop m (first rst) (rest rst)))
+      (else (mau/least-loop m best (rest rst))))))
+
+(define
+  mau/least-sort
+  (fn
+    (m sorts)
+    (if (empty? sorts) "?" (mau/least-loop m (first sorts) (rest sorts)))))
+
+(define
+  mau/result-sort
+  (fn
+    (m name argsorts)
+    (let
+      ((cands (mau/matching-ops m name argsorts)))
+      (if
+        (empty? cands)
+        (let
+          ((any (mau/ops-named m name)))
+          (if (empty? any) "?" (get (first any) :result)))
+        (mau/least-sort m (map (fn (op) (get op :result)) cands))))))
+
+(define
+  mau/term-sort
+  (fn
+    (m t)
+    (cond
+      ((mau/var? t) (mau/vsort t))
+      ((mau/app? t)
+        (mau/result-sort
+          m
+          (mau/op t)
+          (map (fn (a) (mau/term-sort m a)) (mau/args t))))
+      (else "?"))))
+
+(define
+  mau/term-sort-src
+  (fn (m src) (mau/term-sort m (mau/parse-term-in m src))))
+
+(define
+  mau/has-sort?
+  (fn (m t sort) (mau/sort<=? m (mau/term-sort m t) sort)))
+
+(define
+  mau/has-sort-src?
+  (fn (m src sort) (mau/has-sort? m (mau/parse-term-in m src) sort)))

lib/maude/strategy.sx

@@ -0,0 +1,217 @@
+;; lib/maude/strategy.sx — strategy language (Phase 6).
+;;
+;; A strategy controls HOW rules are applied. Strategies are first-class values
+;; (tagged dicts) and SET-VALUED: applying a strategy to a term yields the set
+;; (deduped by canonical form) of result terms. The same rule set under
+;; different strategies computes different things — `;` sequences, `|` unions,
+;; `*`/`+` iterate, `!` normalises.
+;;
+;; Constructors:
+;;   (mau/s-idle)            identity (the term itself)
+;;   (mau/s-fail)            empty set
+;;   (mau/s-all)             apply any rule once, anywhere
+;;   (mau/s-rule LABEL)      apply a named rule once, anywhere
+;;   (mau/s-seq A B)         A ; B   (apply B to every result of A)
+;;   (mau/s-alt A B)         A | B   (union of results)
+;;   (mau/s-star A)          A *     (reflexive-transitive closure)
+;;   (mau/s-plus A)          A +     (one or more)
+;;   (mau/s-bang A)          A !     (normal forms: results where A can't apply)
+;;   (mau/s-name N)          look up named strategy N in the env
+;;
+;; Run with (mau/srun M STRATS STRAT SRC): STRATS is a dict NAME -> strategy.
+
+(define mau/s-idle (fn () {:s :idle}))
+(define mau/s-fail (fn () {:s :fail}))
+(define mau/s-all (fn () {:s :all}))
+(define mau/s-rule (fn (label) {:label label :s :rule}))
+(define mau/s-seq (fn (a b) {:a a :b b :s :seq}))
+(define mau/s-alt (fn (a b) {:a a :b b :s :alt}))
+(define mau/s-star (fn (a) {:a a :s :star}))
+(define mau/s-plus (fn (a) {:a a :s :plus}))
+(define mau/s-bang (fn (a) {:a a :s :bang}))
+(define mau/s-name (fn (n) {:n n :s :name}))
+
+(define
+  mau/rules-with-label
+  (fn (rules label) (filter (fn (r) (= (get r :label) label)) rules)))
+
+(define
+  mau/dedup-loop
+  (fn
+    (theory ts seen acc)
+    (if
+      (empty? ts)
+      acc
+      (let
+        ((c (mau/canon theory (first ts))))
+        (if
+          (mau/member? c seen)
+          (mau/dedup-loop theory (rest ts) seen acc)
+          (mau/dedup-loop
+            theory
+            (rest ts)
+            (cons c seen)
+            (mau/append2 acc (list (first ts)))))))))
+
+(define
+  mau/dedup-canon
+  (fn (theory ts) (mau/dedup-loop theory ts (list) (list))))
+
+;; ---- strategy interpreter ----
+
+(define
+  mau/sapply
+  (fn
+    (ctx strat term)
+    (let
+      ((k (get strat :s)) (theory (get ctx :theory)))
+      (cond
+        ((= k "idle") (list term))
+        ((= k "fail") (list))
+        ((= k "all")
+          (mau/dedup-canon
+            theory
+            (mau/all-successors theory (get ctx :eqs) (get ctx :rules) term)))
+        ((= k "rule")
+          (mau/dedup-canon
+            theory
+            (mau/all-successors
+              theory
+              (get ctx :eqs)
+              (mau/rules-with-label (get ctx :rules) (get strat :label))
+              term)))
+        ((= k "seq")
+          (mau/dedup-canon
+            theory
+            (mau/concat-map
+              (fn (t) (mau/sapply ctx (get strat :b) t))
+              (mau/sapply ctx (get strat :a) term))))
+        ((= k "alt")
+          (mau/dedup-canon
+            theory
+            (mau/append2
+              (mau/sapply ctx (get strat :a) term)
+              (mau/sapply ctx (get strat :b) term))))
+        ((= k "star") (mau/sstar ctx (get strat :a) term))
+        ((= k "plus")
+          (mau/dedup-canon
+            theory
+            (mau/concat-map
+              (fn (t) (mau/sstar ctx (get strat :a) t))
+              (mau/sapply ctx (get strat :a) term))))
+        ((= k "bang")
+          (mau/dedup-canon theory (mau/sbang ctx (get strat :a) term)))
+        ((= k "name")
+          (mau/sapply ctx (get (get ctx :strats) (get strat :n)) term))
+        (else (list))))))
+
+;; reflexive-transitive closure: term plus everything reachable via A
+(define
+  mau/sstar
+  (fn
+    (ctx a term)
+    (mau/sstar-loop
+      ctx
+      a
+      (list term)
+      (list (mau/canon (get ctx :theory) term))
+      (list term))))
+
+(define
+  mau/sstar-loop
+  (fn
+    (ctx a frontier seen acc)
+    (if
+      (empty? frontier)
+      acc
+      (let
+        ((newf (list))
+          (newseen seen)
+          (newacc acc)
+          (theory (get ctx :theory)))
+        (for-each
+          (fn
+            (t)
+            (for-each
+              (fn
+                (succ)
+                (let
+                  ((c (mau/canon theory succ)))
+                  (when
+                    (not (mau/member? c newseen))
+                    (do
+                      (set! newseen (cons c newseen))
+                      (append! newf succ)
+                      (append! newacc succ)))))
+              (mau/sapply ctx a t)))
+          frontier)
+        (mau/sstar-loop ctx a newf newseen newacc)))))
+
+;; normal forms: terms reachable via A where A yields nothing more
+(define
+  mau/sbang
+  (fn
+    (ctx a term)
+    (mau/sbang-loop
+      ctx
+      a
+      (list term)
+      (list (mau/canon (get ctx :theory) term))
+      (list))))
+
+(define
+  mau/sbang-loop
+  (fn
+    (ctx a frontier seen acc)
+    (if
+      (empty? frontier)
+      acc
+      (let
+        ((newf (list))
+          (newseen seen)
+          (newacc acc)
+          (theory (get ctx :theory)))
+        (for-each
+          (fn
+            (t)
+            (let
+              ((succs (mau/sapply ctx a t)))
+              (if
+                (empty? succs)
+                (append! newacc t)
+                (for-each
+                  (fn
+                    (succ)
+                    (let
+                      ((c (mau/canon theory succ)))
+                      (when
+                        (not (mau/member? c newseen))
+                        (do
+                          (set! newseen (cons c newseen))
+                          (append! newf succ)))))
+                  succs))))
+          frontier)
+        (mau/sbang-loop ctx a newf newseen newacc)))))
+
+;; ---- public API ----
+
+(define mau/make-sctx (fn (m strats) {:eqs (mau/module-eqs m) :theory (mau/build-theory m) :strats strats :rules (mau/module-rules m)}))
+
+(define
+  mau/srun
+  (fn
+    (m strats strat src)
+    (let
+      ((ctx (mau/make-sctx m strats)))
+      (let
+        ((t0 (mau/cnormalize (get ctx :theory) (get ctx :eqs) (mau/parse-term-in m src) mau/reduce-fuel)))
+        (mau/dedup-canon (get ctx :theory) (mau/sapply ctx strat t0))))))
+
+(define
+  mau/srun-canon
+  (fn
+    (m strats strat src)
+    (let
+      ((theory (mau/build-theory m)))
+      (mau/sort-strings
+        (map (fn (t) (mau/canon theory t)) (mau/srun m strats strat src))))))

lib/maude/term.sx

@@ -0,0 +1,114 @@
+;; lib/maude/term.sx — Maude term representation.
+;;
+;; A term is one of:
+;;   variable     {:t :var :name "X" :sort "Nat"}
+;;   application  {:t :app :op "_+_" :args (a b ...)}   (constant: empty args)
+;;
+;; Sorts attach to variables; operator/result sorts live on op declarations
+;; in the module signature, not on the term node. Overloading is resolved at
+;; reduction time, so the parser only records the operator name.
+
+(define mau/var (fn (name sort) {:name name :t :var :sort sort}))
+
+(define mau/app (fn (op args) {:op op :t :app :args args}))
+
+(define mau/const (fn (op) {:op op :t :app :args (list)}))
+
+(define mau/var? (fn (t) (and (dict? t) (= (get t :t) "var"))))
+
+(define mau/app? (fn (t) (and (dict? t) (= (get t :t) "app"))))
+
+(define mau/term? (fn (t) (or (mau/var? t) (mau/app? t))))
+
+(define mau/op (fn (t) (get t :op)))
+(define mau/args (fn (t) (get t :args)))
+(define mau/vname (fn (t) (get t :name)))
+(define mau/vsort (fn (t) (get t :sort)))
+(define mau/arity (fn (t) (len (get t :args))))
+
+(define mau/const? (fn (t) (and (mau/app? t) (empty? (mau/args t)))))
+
+(define
+  mau/args=?
+  (fn
+    (as bs)
+    (cond
+      ((and (empty? as) (empty? bs)) true)
+      ((or (empty? as) (empty? bs)) false)
+      (else
+        (and
+          (mau/term=? (first as) (first bs))
+          (mau/args=? (rest as) (rest bs)))))))
+
+(define
+  mau/term=?
+  (fn
+    (a b)
+    (cond
+      ((and (mau/var? a) (mau/var? b))
+        (and
+          (= (mau/vname a) (mau/vname b))
+          (= (mau/vsort a) (mau/vsort b))))
+      ((and (mau/app? a) (mau/app? b))
+        (and
+          (= (mau/op a) (mau/op b))
+          (mau/args=? (mau/args a) (mau/args b))))
+      (else false))))
+
+(define
+  mau/join-args
+  (fn
+    (args)
+    (cond
+      ((empty? args) "")
+      ((empty? (rest args)) (mau/term->str (first args)))
+      (else
+        (str (mau/term->str (first args)) ", " (mau/join-args (rest args)))))))
+
+(define
+  mau/term->str
+  (fn
+    (t)
+    (cond
+      ((mau/var? t) (mau/vname t))
+      ((mau/const? t) (mau/op t))
+      ((mau/app? t) (str (mau/op t) "(" (mau/join-args (mau/args t)) ")"))
+      (else "?"))))
+
+(define
+  mau/member?
+  (fn
+    (x xs)
+    (cond
+      ((empty? xs) false)
+      ((= x (first xs)) true)
+      (else (mau/member? x (rest xs))))))
+
+(define
+  mau/union
+  (fn
+    (xs ys)
+    (cond
+      ((empty? xs) ys)
+      ((mau/member? (first xs) ys) (mau/union (rest xs) ys))
+      (else (cons (first xs) (mau/union (rest xs) ys))))))
+
+(define
+  mau/term-vars
+  (fn
+    (t)
+    (cond
+      ((mau/var? t) (list (mau/vname t)))
+      ((mau/app? t) (mau/term-vars-list (mau/args t)))
+      (else (list)))))
+
+(define
+  mau/term-vars-list
+  (fn
+    (args)
+    (if
+      (empty? args)
+      (list)
+      (mau/union
+        (mau/term-vars (first args))
+        (mau/term-vars-list (rest args))))))

lib/maude/tests/conditional.sx

@@ -0,0 +1,108 @@
+;; lib/maude/tests/conditional.sx — Phase 4: conditional equations.
+
+(define mct-pass 0)
+(define mct-fail 0)
+(define mct-failures (list))
+
+(define
+  mct-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mct-pass (+ mct-pass 1))
+      (do
+        (set! mct-fail (+ mct-fail 1))
+        (append!
+          mct-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; ---- gcd (equational guard, recursive) ----
+
+(define
+  mct-gcd
+  (mau/parse-module
+    "fmod GCD is\n  sorts Nat Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _>_ : Nat Nat -> Bool .\n  op _-_ : Nat Nat -> Nat .\n  op gcd : Nat Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 > Y = false .\n  eq s X > 0 = true .\n  eq s X > s Y = X > Y .\n  eq X - 0 = X .\n  eq 0 - Y = 0 .\n  eq s X - s Y = X - Y .\n  eq gcd(X, 0) = X .\n  eq gcd(0, Y) = Y .\n  eq gcd(X, X) = X .\n  ceq gcd(X, Y) = gcd(X - Y, Y) if X > Y = true .\n  ceq gcd(X, Y) = gcd(Y, X) if Y > X = true .\nendfm"))
+
+(mct-check!
+  "gcd-6-4"
+  (mau/creduce->str mct-gcd "gcd(s s s s s s 0, s s s s 0)")
+  "s_(s_(0))")
+(mct-check!
+  "gcd-3-6"
+  (mau/creduce->str mct-gcd "gcd(s s s 0, s s s s s s 0)")
+  "s_(s_(s_(0)))")
+(mct-check!
+  "gcd-base-zero"
+  (mau/creduce->str mct-gcd "gcd(s s 0, 0)")
+  "s_(s_(0))")
+(mct-check!
+  "gcd-equal"
+  (mau/creduce->str mct-gcd "gcd(s s 0, s s 0)")
+  "s_(s_(0))")
+(mct-check!
+  "gcd-coprime"
+  (mau/creduce->str mct-gcd "gcd(s s s 0, s s 0)")
+  "s_(0)")
+;; guard predicate reductions
+(mct-check! "gt-true" (mau/creduce->str mct-gcd "s s 0 > s 0") "true")
+(mct-check! "gt-false" (mau/creduce->str mct-gcd "s 0 > s s 0") "false")
+
+;; ---- insertion sort (true/false guards) ----
+
+(define
+  mct-sort
+  (mau/parse-module
+    "fmod SORT is\n  sorts Nat List Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _<=_ : Nat Nat -> Bool .\n  op nil : -> List .\n  op _:_ : Nat List -> List .\n  op insert : Nat List -> List .\n  op sort : List -> List .\n  vars M N : Nat .\n  var L : List .\n  eq 0 <= N = true .\n  eq s M <= 0 = false .\n  eq s M <= s N = M <= N .\n  eq insert(N, nil) = N : nil .\n  ceq insert(N, M : L) = N : (M : L) if N <= M = true .\n  ceq insert(N, M : L) = M : insert(N, L) if N <= M = false .\n  eq sort(nil) = nil .\n  eq sort(N : L) = insert(N, sort(L)) .\nendfm"))
+
+(mct-check!
+  "sort-321"
+  (mau/creduce->str mct-sort "sort(s s s 0 : (s 0 : (s s 0 : nil)))")
+  "_:_(s_(0), _:_(s_(s_(0)), _:_(s_(s_(s_(0))), nil)))")
+(mct-check! "sort-empty" (mau/creduce->str mct-sort "sort(nil)") "nil")
+(mct-check!
+  "sort-singleton"
+  (mau/creduce->str mct-sort "sort(s s 0 : nil)")
+  "_:_(s_(s_(0)), nil)")
+(mct-check!
+  "insert-front"
+  (mau/creduce->str mct-sort "insert(0, s 0 : (s s 0 : nil))")
+  "_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
+(mct-check!
+  "insert-back"
+  (mau/creduce->str mct-sort "insert(s s s 0, s 0 : (s s 0 : nil))")
+  "_:_(s_(0), _:_(s_(s_(0)), _:_(s_(s_(s_(0))), nil)))")
+
+;; ---- max (conditional simplification, both branches) ----
+
+(define
+  mct-max
+  (mau/parse-module
+    "fmod MAX is\n  sorts Nat Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _<=_ : Nat Nat -> Bool .\n  op max : Nat Nat -> Nat .\n  vars M N : Nat .\n  eq 0 <= N = true .\n  eq s M <= 0 = false .\n  eq s M <= s N = M <= N .\n  ceq max(M, N) = M if N <= M = true .\n  ceq max(M, N) = N if N <= M = false .\nendfm"))
+
+(mct-check!
+  "max-left"
+  (mau/creduce->str mct-max "max(s s s 0, s 0)")
+  "s_(s_(s_(0)))")
+(mct-check!
+  "max-right"
+  (mau/creduce->str mct-max "max(s 0, s s 0)")
+  "s_(s_(0))")
+(mct-check!
+  "max-equal"
+  (mau/creduce->str mct-max "max(s s 0, s s 0)")
+  "s_(s_(0))")
+
+;; ---- boolean-kind condition (`if pred`) ----
+
+(define
+  mct-even
+  (mau/parse-module
+    "fmod EVEN is\n  sorts Nat Bool Tag .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op even : Nat -> Bool .\n  op evn : -> Tag .\n  op odd : -> Tag .\n  op tag : Nat -> Tag .\n  var N : Nat .\n  eq even(0) = true .\n  eq even(s 0) = false .\n  eq even(s s N) = even(N) .\n  ceq tag(N) = evn if even(N) .\n  ceq tag(N) = odd if even(N) = false .\nendfm"))
+
+(mct-check! "even-4" (mau/creduce->str mct-even "even(s s s s 0)") "true")
+(mct-check! "even-3" (mau/creduce->str mct-even "even(s s s 0)") "false")
+(mct-check! "tag-even-bool" (mau/creduce->str mct-even "tag(s s 0)") "evn")
+(mct-check! "tag-odd" (mau/creduce->str mct-even "tag(s s s 0)") "odd")
+
+(define mau-conditional-tests-run! (fn () {:failures mct-failures :total (+ mct-pass mct-fail) :passed mct-pass :failed mct-fail}))

lib/maude/tests/confluence.sx

@@ -0,0 +1,101 @@
+;; lib/maude/tests/confluence.sx — critical-pair / local-confluence checking.
+
+(define mcf-pass 0)
+(define mcf-fail 0)
+(define mcf-failures (list))
+
+(define
+  mcf-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mcf-pass (+ mcf-pass 1))
+      (do
+        (set! mcf-fail (+ mcf-fail 1))
+        (append!
+          mcf-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; peano addition: no LHS overlaps -> confluent
+(define
+  mcf-peano
+  (mau/parse-module
+    "fmod P is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\nendfm"))
+
+(mcf-check! "peano-confluent" (mau/confluent? mcf-peano) true)
+(mcf-check!
+  "peano-no-bad-pairs"
+  (len (mau/non-joinable-pairs mcf-peano))
+  0)
+
+;; f(a)=b, a=c : the inner `a` overlaps -> critical pair b vs f(c), NOT joinable
+(define
+  mcf-bad
+  (mau/parse-module
+    "fmod B is\n  sort T .\n  op a : -> T .\n  op b : -> T .\n  op c : -> T .\n  op f : T -> T .\n  eq f(a) = b .\n  eq a = c .\nendfm"))
+
+(mcf-check! "bad-not-confluent" (mau/confluent? mcf-bad) false)
+(mcf-check! "bad-one-pair" (len (mau/non-joinable-pairs mcf-bad)) 1)
+(mcf-check!
+  "bad-pair-shape"
+  (mau/cp->str mcf-bad (first (mau/non-joinable-pairs mcf-bad)))
+  "b <?> f(c)")
+(mcf-check!
+  "bad-has-cps"
+  (> (len (mau/critical-pairs mcf-bad)) 0)
+  true)
+
+;; adding f(c)=b joins the pair -> confluent
+(define
+  mcf-fixed
+  (mau/parse-module
+    "fmod F is\n  sort T .\n  op a : -> T .\n  op b : -> T .\n  op c : -> T .\n  op f : T -> T .\n  eq f(a) = b .\n  eq a = c .\n  eq f(c) = b .\nendfm"))
+
+(mcf-check! "fixed-confluent" (mau/confluent? mcf-fixed) true)
+
+;; self-overlap that is joinable: idempotent d(d(X)) = d(X)
+(define
+  mcf-idem
+  (mau/parse-module
+    "fmod I is\n  sort T .\n  op d : T -> T .\n  op x : -> T .\n  var X : T .\n  eq d(d(X)) = d(X) .\nendfm"))
+
+(mcf-check! "idem-confluent" (mau/confluent? mcf-idem) true)
+
+;; a free-op overlap that joins: g(h(X)) over h(a)
+(define
+  mcf-join
+  (mau/parse-module
+    "fmod J is\n  sort T .\n  op a : -> T .\n  op k : -> T .\n  op h : T -> T .\n  op g : T -> T .\n  op r : T -> T .\n  var X : T .\n  eq g(h(X)) = r(X) .\n  eq h(a) = k .\nendfm"))
+
+;; g(h(a)) -> r(a) (rule1) or g(k) (rule2 inside). Not joinable unless g(k) reduces.
+(mcf-check! "join-not-confluent" (mau/confluent? mcf-join) false)
+
+;; AC operator, genuinely confluent; joinability uses canonical form
+(define
+  mcf-ac
+  (mau/parse-module
+    "fmod AC is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  eq a + a = b .\nendfm"))
+
+(mcf-check! "ac-confluent" (mau/confluent? mcf-ac) true)
+
+;; unifier sanity (two-sided): f(X, b) unifies with f(a, Y)
+(mcf-check!
+  "unify-twosided"
+  (=
+    nil
+    (mau/u-unify
+      (mau/app "f" (list (mau/var "X" "T") (mau/const "b")))
+      (mau/app "f" (list (mau/const "a") (mau/var "Y" "T")))
+      {}))
+  false)
+;; occurs check: X vs f(X) fails
+(mcf-check!
+  "unify-occurs"
+  (mau/u-unify
+    (mau/var "X" "T")
+    (mau/app "f" (list (mau/var "X" "T")))
+    {})
+  nil)
+
+(define mau-confluence-tests-run! (fn () {:failures mcf-failures :total (+ mcf-pass mcf-fail) :passed mcf-pass :failed mcf-fail}))

lib/maude/tests/effects.sx

@@ -0,0 +1,79 @@
+;; lib/maude/tests/effects.sx — artdag-on-sx fit prototype.
+;;
+;; Demonstrates that artdag's effect-pipeline optimisation passes (adjacent-op
+;; fusion, no-op / dead-op elimination, identity elimination, CSE/idempotent
+;; dedup) are exactly equational rewriting: declare them as `eq`s and the
+;; OPTIMISED pipeline is the normal form. Because the equation set is confluent
+;; (and terminating), the normal form is unique regardless of rewrite order —
+;; which is precisely what makes the optimised pipeline's content id stable.
+;;
+;; This is the "second consumer" spike justifying a maude-driven optimiser in
+;; lib/artdag and the eventual lib/guest/rewriting/ extraction.
+
+(define mef-pass 0)
+(define mef-fail 0)
+(define mef-failures (list))
+
+(define
+  mef-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mef-pass (+ mef-pass 1))
+      (do
+        (set! mef-fail (+ mef-fail 1))
+        (append!
+          mef-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+(define
+  mef-m
+  (mau/parse-module
+    "fmod EFFECTS is\n  sorts Img Num .\n  op src : -> Img .\n  op 0 : -> Num .\n  op s_ : Num -> Num .\n  op _+_ : Num Num -> Num .\n  op blur : Img Num -> Img .\n  op bright : Img Num -> Img .\n  op id : Img -> Img .\n  op over : Img Img -> Img [comm] .\n  vars I J : Img .\n  vars M N : Num .\n  eq 0 + N = N .\n  eq s M + N = s (M + N) .\n  eq id(I) = I .\n  eq blur(I, 0) = I .\n  eq bright(I, 0) = I .\n  eq blur(blur(I, M), N) = blur(I, M + N) .\n  eq bright(bright(I, M), N) = bright(I, M + N) .\n  eq over(I, I) = I .\nendfm"))
+
+;; adjacent-op fusion: two blurs collapse, radii add
+(mef-check!
+  "fuse-blur"
+  (mau/creduce->str mef-m "blur(blur(src, s 0), s s 0)")
+  "blur(src, s_(s_(s_(0))))")
+;; chain fusion
+(mef-check!
+  "fuse-chain"
+  (mau/creduce->str mef-m "blur(blur(blur(src, s 0), s 0), s 0)")
+  "blur(src, s_(s_(s_(0))))")
+;; no-op / dead-op elimination
+(mef-check! "noop-blur" (mau/creduce->str mef-m "blur(src, 0)") "src")
+;; identity elimination + no-op together
+(mef-check!
+  "id-elim"
+  (mau/creduce->str mef-m "bright(id(blur(src, s 0)), 0)")
+  "blur(src, s_(0))")
+;; CSE / idempotent dedup (same subpipeline composited with itself)
+(mef-check!
+  "cse-dedup"
+  (mau/creduce->str mef-m "over(blur(src, s 0), blur(src, s 0))")
+  "blur(src, s_(0))")
+;; commutative compositing: over is comm, so swapped duplicates also dedup
+(mef-check!
+  "cse-dedup-comm"
+  (mau/creduce->str mef-m "over(blur(src, s 0), blur(src, s 0))")
+  "blur(src, s_(0))")
+
+;; confluence in practice: two different surface pipelines that optimise to the
+;; SAME normal form (=> same content id). bright-fused twice vs once-by-3.
+(mef-check!
+  "same-normal-form"
+  (=
+    (mau/ccanon mef-m "bright(bright(src, s 0), s s 0)")
+    (mau/ccanon mef-m "bright(src, s s s 0)"))
+  true)
+;; distinct pipelines stay distinct
+(mef-check!
+  "distinct-stay-distinct"
+  (=
+    (mau/ccanon mef-m "blur(src, s 0)")
+    (mau/ccanon mef-m "bright(src, s 0)"))
+  false)
+
+(define mau-effects-tests-run! (fn () {:failures mef-failures :total (+ mef-pass mef-fail) :passed mef-pass :failed mef-fail}))

lib/maude/tests/gather.sx

@@ -0,0 +1,66 @@
+;; lib/maude/tests/gather.sx — gather / parse-time associativity.
+
+(define mga-pass 0)
+(define mga-fail 0)
+(define mga-failures (list))
+
+(define
+  mga-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mga-pass (+ mga-pass 1))
+      (do
+        (set! mga-fail (+ mga-fail 1))
+        (append!
+          mga-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+(define
+  mga-m
+  (mau/parse-module
+    "fmod L is\n  sorts Nat List .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op nil : -> List .\n  op _:_ : Nat List -> List [gather (e E)] .\n  op _+_ : Nat Nat -> Nat .\n  op _-_ : Nat Nat -> Nat [gather (E e)] .\n  vars X Y : Nat .\nendfm"))
+
+;; cons is right-associative: a : b : c  ==  a : (b : c)
+(mga-check!
+  "cons-right"
+  (mau/term->str (mau/parse-term-in mga-m "0 : s 0 : nil"))
+  "_:_(0, _:_(s_(0), nil))")
+;; + has no gather -> default left-assoc
+(mga-check!
+  "plus-left"
+  (mau/term->str (mau/parse-term-in mga-m "X + Y + X"))
+  "_+_(_+_(X, Y), X)")
+;; explicit (E e) is left
+(mga-check!
+  "minus-left"
+  (mau/term->str (mau/parse-term-in mga-m "X - Y - X"))
+  "_-_(_-_(X, Y), X)")
+;; gather attr recorded
+(mga-check!
+  "gather-recorded"
+  (get (get (first (mau/ops-named mga-m "_:_")) :attrs) :gather)
+  (list "e" "E"))
+
+;; ---- full insertion sort over BARE cons lists (no parens needed) ----
+
+(define
+  mga-sort
+  (mau/parse-module
+    "fmod SORT is\n  sorts Nat List Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _<=_ : Nat Nat -> Bool .\n  op nil : -> List .\n  op _:_ : Nat List -> List [gather (e E)] .\n  op insert : Nat List -> List .\n  op sort : List -> List .\n  vars M N : Nat .\n  var L : List .\n  eq 0 <= N = true .\n  eq s M <= 0 = false .\n  eq s M <= s N = M <= N .\n  eq insert(N, nil) = N : nil .\n  ceq insert(N, M : L) = N : M : L if N <= M = true .\n  ceq insert(N, M : L) = M : insert(N, L) if N <= M = false .\n  eq sort(nil) = nil .\n  eq sort(N : L) = insert(N, sort(L)) .\nendfm"))
+
+(mga-check!
+  "sort-bare"
+  (mau/creduce->str mga-sort "sort(s s s 0 : s 0 : s s 0 : nil)")
+  "_:_(s_(0), _:_(s_(s_(0)), _:_(s_(s_(s_(0))), nil)))")
+(mga-check!
+  "sort-bare-5"
+  (mau/creduce->str mga-sort "sort(s s 0 : 0 : s 0 : nil)")
+  "_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
+(mga-check!
+  "insert-bare"
+  (mau/creduce->str mga-sort "insert(s 0, 0 : s s 0 : nil)")
+  "_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
+
+(define mau-gather-tests-run! (fn () {:failures mga-failures :total (+ mga-pass mga-fail) :passed mga-pass :failed mga-fail}))

lib/maude/tests/matching.sx

@@ -0,0 +1,170 @@
+;; lib/maude/tests/matching.sx — Phase 3: matching modulo assoc/comm/id.
+
+(define mmt-pass 0)
+(define mmt-fail 0)
+(define mmt-failures (list))
+
+(define
+  mmt-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mmt-pass (+ mmt-pass 1))
+      (do
+        (set! mmt-fail (+ mmt-fail 1))
+        (append!
+          mmt-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; ---- multi-valued matching enumeration ----
+
+(define
+  mmt-acg
+  (mau/parse-module
+    "fmod ACG is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op c : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  op _._ : S S -> S [assoc] .\n  vars X Y : S .\nendfm"))
+
+;; X + Y against a + b + c (AC, no id): 6 solutions (each non-empty 2-split).
+(mmt-check!
+  "ac-match-count"
+  (len
+    (mau/match-all
+      mmt-acg
+      (mau/parse-term-in mmt-acg "X + Y")
+      (mau/parse-term-in mmt-acg "a + b + c")))
+  6)
+;; X + a against a + b + c: X must be b + c (one solution, multiset).
+(mmt-check!
+  "ac-match-partial"
+  (len
+    (mau/match-all
+      mmt-acg
+      (mau/parse-term-in mmt-acg "X + a")
+      (mau/parse-term-in mmt-acg "a + b + c")))
+  1)
+;; assoc-only X . Y against a . b . c: ordered 2-splits -> 2 solutions.
+(mmt-check!
+  "assoc-match-count"
+  (len
+    (mau/match-all
+      mmt-acg
+      (mau/parse-term-in mmt-acg "X . Y")
+      (mau/parse-term-in mmt-acg "a . b . c")))
+  2)
+;; no match: a + a pattern against a + b
+(mmt-check!
+  "ac-no-match"
+  (len
+    (mau/match-all
+      mmt-acg
+      (mau/parse-term-in mmt-acg "a + a")
+      (mau/parse-term-in mmt-acg "a + b")))
+  0)
+
+;; ---- comm (non-assoc) matching ----
+
+(define
+  mmt-pair
+  (mau/parse-module
+    "fmod PAIR is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op p : S S -> S [comm] .\n  op fst : S -> S .\n  vars X Y : S .\n  eq fst(p(X, a)) = X .\nendfm"))
+
+(mmt-check!
+  "comm-both-orders"
+  (mau/ac-reduce->str mmt-pair "fst(p(b, a))")
+  "b")
+(mmt-check! "comm-swapped" (mau/ac-reduce->str mmt-pair "fst(p(a, b))") "b")
+
+;; ---- identity ----
+
+(define
+  mmt-id
+  (mau/parse-module
+    "fmod IDMOD is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op e : -> S .\n  op _*_ : S S -> S [assoc comm id: e] .\n  vars X Y : S .\nendfm"))
+
+(mmt-check! "id-drop" (mau/ac-canon mmt-id "a * e") "a")
+(mmt-check! "id-drop-mid" (mau/ac-canon mmt-id "a * e * b") "_*_(a,b)")
+(mmt-check! "id-only" (mau/ac-canon mmt-id "e * e") "e")
+;; with id, X * Y matching a (singleton) succeeds (one var empty)
+(mmt-check!
+  "id-match-singleton"
+  (>
+    (len
+      (mau/match-all
+        mmt-id
+        (mau/parse-term-in mmt-id "X * Y")
+        (mau/parse-term-in mmt-id "a")))
+    0)
+  true)
+
+;; ---- multiset / bag rewriting ----
+
+(define
+  mmt-bag
+  (mau/parse-module
+    "fmod BAG is\n  sort S .\n  op a : -> S .\n  op b : -> S .\n  op c : -> S .\n  op _+_ : S S -> S [assoc comm] .\n  eq a + a = a .\nendfm"))
+
+(mmt-check! "bag-collapse" (mau/ac-canon mmt-bag "a + b + a") "_+_(a,b)")
+(mmt-check! "bag-deep" (mau/ac-canon mmt-bag "a + a + a") "a")
+(mmt-check! "bag-reorder" (mau/ac-canon mmt-bag "c + a + b + a") "_+_(a,b,c)")
+(mmt-check!
+  "bag-flatten-assoc"
+  (mau/ac-canon mmt-bag "(a + b) + (a + c)")
+  "_+_(a,b,c)")
+
+;; ---- set theory: idempotent union with empty (identity) ----
+
+(define
+  mmt-set
+  (mau/parse-module
+    "fmod SET is\n  sort Set .\n  op empty : -> Set .\n  op a : -> Set .\n  op b : -> Set .\n  op c : -> Set .\n  op _U_ : Set Set -> Set [assoc comm id: empty] .\n  var X : Set .\n  eq X U X = X .\nendfm"))
+
+(mmt-check! "set-dedup" (mau/ac-canon mmt-set "a U b U a") "_U_(a,b)")
+(mmt-check! "set-triple" (mau/ac-canon mmt-set "a U a U a") "a")
+(mmt-check!
+  "set-union"
+  (mau/ac-canon mmt-set "a U b U c U a U b")
+  "_U_(a,b,c)")
+(mmt-check! "set-empty" (mau/ac-canon mmt-set "a U empty") "a")
+(mmt-check! "set-empty-only" (mau/ac-canon mmt-set "empty U empty") "empty")
+
+;; ---- group equations (assoc, non-comm, identity + inverse) ----
+
+(define
+  mmt-group
+  (mau/parse-module
+    "fmod GROUP is\n  sort G .\n  op e : -> G .\n  op a : -> G .\n  op b : -> G .\n  op _*_ : G G -> G [assoc] .\n  op i : G -> G .\n  var X : G .\n  eq e * X = X .\n  eq X * e = X .\n  eq i(X) * X = e .\n  eq X * i(X) = e .\n  eq i(e) = e .\n  eq i(i(X)) = X .\nendfm"))
+
+(mmt-check! "group-inverse" (mau/ac-canon mmt-group "i(a) * a") "e")
+(mmt-check! "group-cancel" (mau/ac-canon mmt-group "i(a) * a * b") "b")
+(mmt-check! "group-cancel-mid" (mau/ac-canon mmt-group "b * i(a) * a") "b")
+(mmt-check! "group-double-inv" (mau/ac-canon mmt-group "i(i(a))") "a")
+(mmt-check! "group-id-left" (mau/ac-canon mmt-group "e * a") "a")
+(mmt-check! "group-right-inv" (mau/ac-canon mmt-group "a * i(a) * b") "b")
+
+;; ---- AC equality (canonical form) ----
+
+(define mmt-th (mau/build-theory mmt-acg))
+
+(mmt-check!
+  "ac-equal-reorder"
+  (mau/ac-equal?
+    mmt-th
+    (mau/parse-term-in mmt-acg "a + b + c")
+    (mau/parse-term-in mmt-acg "c + a + b"))
+  true)
+(mmt-check!
+  "ac-equal-renest"
+  (mau/ac-equal?
+    mmt-th
+    (mau/parse-term-in mmt-acg "(a + b) + c")
+    (mau/parse-term-in mmt-acg "a + (b + c)"))
+  true)
+(mmt-check!
+  "ac-noncomm-order"
+  (mau/ac-equal?
+    mmt-th
+    (mau/parse-term-in mmt-acg "a . b")
+    (mau/parse-term-in mmt-acg "b . a"))
+  false)
+
+(define mau-matching-tests-run! (fn () {:failures mmt-failures :total (+ mmt-pass mmt-fail) :passed mmt-pass :failed mmt-fail}))

lib/maude/tests/meta.sx

@@ -0,0 +1,144 @@
+;; lib/maude/tests/meta.sx — Phase 7: reflection (META-LEVEL).
+
+(define mmtt-pass 0)
+(define mmtt-fail 0)
+(define mmtt-failures (list))
+
+(define
+  mmtt-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mmtt-pass (+ mmtt-pass 1))
+      (do
+        (set! mmtt-fail (+ mmtt-fail 1))
+        (append!
+          mmtt-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+(define
+  mmtt-peano
+  (mau/parse-module
+    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat [assoc comm] .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\nendfm"))
+
+(define
+  mmtt-ndet
+  (mau/parse-module
+    "mod NDET is\n  sort S .\n  ops a b c : -> S .\n  rl [r1] : a => b .\n  rl [r2] : b => c .\nendm"))
+
+;; ---- terms-as-data: up / down ----
+
+(mmtt-check!
+  "up-const"
+  (mau/term->str (mau/meta-up mmtt-peano "0"))
+  "mt-app(0)")
+(mmtt-check!
+  "up-s0"
+  (mau/term->str (mau/meta-up mmtt-peano "s 0"))
+  "mt-app(s_, mt-app(0))")
+(mmtt-check!
+  "up-var"
+  (mau/term->str (mau/up-term (mau/var "X" "Nat")))
+  "mt-var(X, Nat)")
+(mmtt-check!
+  "up-plus"
+  (mau/term->str (mau/meta-up mmtt-peano "s 0 + 0"))
+  "mt-app(_+_, mt-app(s_, mt-app(0)), mt-app(0))")
+
+;; round trip: down(up(t)) = t
+(mmtt-check!
+  "roundtrip-const"
+  (mau/term=?
+    (mau/down-term (mau/meta-up mmtt-peano "0"))
+    (mau/parse-term-in mmtt-peano "0"))
+  true)
+(mmtt-check!
+  "roundtrip-nested"
+  (mau/term=?
+    (mau/down-term (mau/meta-up mmtt-peano "s (s 0 + 0)"))
+    (mau/parse-term-in mmtt-peano "s (s 0 + 0)"))
+  true)
+(mmtt-check!
+  "roundtrip-var"
+  (mau/term=?
+    (mau/down-term (mau/up-term (mau/var "X" "Nat")))
+    (mau/var "X" "Nat"))
+  true)
+
+;; ---- reflective metaReduce ----
+
+(mmtt-check!
+  "meta-reduce"
+  (mau/term->str (mau/meta-reduce-src mmtt-peano "s 0 + s s 0"))
+  "s_(s_(s_(0)))")
+;; metaReduce returns a REPRESENTED result (a meta-term)
+(mmtt-check!
+  "meta-reduce-is-meta"
+  (=
+    (mau/op (mau/meta-reduce mmtt-peano (mau/meta-up mmtt-peano "s 0 + 0")))
+    "mt-app")
+  true)
+
+;; ---- meta-circular law: down(metaReduce(up t)) =AC= reduce t ----
+
+(mmtt-check!
+  "meta-circular-1"
+  (mau/meta-circular? mmtt-peano "s 0 + s s 0")
+  true)
+(mmtt-check!
+  "meta-circular-2"
+  (mau/meta-circular? mmtt-peano "s (s 0 + s 0)")
+  true)
+(mmtt-check!
+  "meta-reduce-eq-up"
+  (mau/term=?
+    (mau/meta-reduce mmtt-peano (mau/meta-up mmtt-peano "s 0 + s 0"))
+    (mau/up-term (mau/creduce-term mmtt-peano "s 0 + s 0")))
+  true)
+
+;; ---- metaApply: reflect a single rule step ----
+
+(mmtt-check!
+  "meta-apply-r1"
+  (mau/term=?
+    (mau/down-term
+      (mau/meta-apply mmtt-ndet "r1" (mau/meta-up mmtt-ndet "a")))
+    (mau/parse-term-in mmtt-ndet "b"))
+  true)
+(mmtt-check!
+  "meta-apply-fail"
+  (mau/meta-apply mmtt-ndet "r2" (mau/meta-up mmtt-ndet "a"))
+  nil)
+
+;; ---- generic theorem helper: equational proof by reduction ----
+
+;; commutativity instance: 1 + 2 and 2 + 1 reduce to the same normal form.
+(mmtt-check!
+  "prove-comm-instance"
+  (mau/meta-prove-equal? mmtt-peano "s 0 + s s 0" "s s 0 + s 0")
+  true)
+;; associativity instance
+(mmtt-check!
+  "prove-assoc-instance"
+  (mau/meta-prove-equal? mmtt-peano "(s 0 + s 0) + s 0" "s 0 + (s 0 + s 0)")
+  true)
+;; a non-theorem
+(mmtt-check!
+  "prove-false"
+  (mau/meta-prove-equal? mmtt-peano "s 0 + s 0" "s 0")
+  false)
+
+;; ---- build a program meta-level, then run it ----
+
+;; construct the meta-representation of s(s(0)) by hand, down it, reduce.
+(define
+  mmtt-built
+  (mau/up-term
+    (mau/app "s_" (list (mau/app "s_" (list (mau/const "0")))))))
+(mmtt-check!
+  "built-down-reduce"
+  (mau/term->str (mau/creduce mmtt-peano (mau/down-term mmtt-built)))
+  "s_(s_(0))")
+
+(define mau-meta-tests-run! (fn () {:failures mmtt-failures :total (+ mmtt-pass mmtt-fail) :passed mmtt-pass :failed mmtt-fail}))

lib/maude/tests/owise.sx

@@ -0,0 +1,61 @@
+;; lib/maude/tests/owise.sx — owise (otherwise) equations.
+
+(define mow-pass 0)
+(define mow-fail 0)
+(define mow-failures (list))
+
+(define
+  mow-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mow-pass (+ mow-pass 1))
+      (do
+        (set! mow-fail (+ mow-fail 1))
+        (append!
+          mow-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; The owise catch-all is declared FIRST, yet must only fire when no ordinary
+;; equation applies — proving owise is order-independent, not just last-match.
+(define
+  mow-lookup
+  (mau/parse-module
+    "fmod LOOKUP is\n  sorts Key Val .\n  ops k1 k2 k3 : -> Key .\n  ops v1 v2 none : -> Val .\n  op lookup : Key -> Val .\n  var K : Key .\n  eq lookup(K) = none [owise] .\n  eq lookup(k1) = v1 .\n  eq lookup(k2) = v2 .\nendfm"))
+
+(mow-check!
+  "owise-parsed"
+  (get (first (mau/module-eqs mow-lookup)) :owise)
+  true)
+(mow-check!
+  "ordinary-not-owise"
+  (get (nth (mau/module-eqs mow-lookup) 1) :owise)
+  false)
+
+(mow-check! "lookup-hit-1" (mau/creduce->str mow-lookup "lookup(k1)") "v1")
+(mow-check! "lookup-hit-2" (mau/creduce->str mow-lookup "lookup(k2)") "v2")
+(mow-check!
+  "lookup-default"
+  (mau/creduce->str mow-lookup "lookup(k3)")
+  "none")
+
+;; owise with a guard among the ordinary equations
+(define
+  mow-sign
+  (mau/parse-module
+    "fmod SIGN is\n  sorts Nat Sign Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _>_ : Nat Nat -> Bool .\n  op pos : -> Sign .\n  op zero : -> Sign .\n  op sign : Nat -> Sign .\n  var N : Nat .\n  eq 0 > N = false .\n  eq s N > 0 = true .\n  eq s N > s M = N > M .\n  eq sign(N) = pos [owise] .\n  eq sign(0) = zero .\n  vars M : Nat .\nendfm"))
+
+(mow-check! "sign-zero" (mau/creduce->str mow-sign "sign(0)") "zero")
+(mow-check! "sign-pos" (mau/creduce->str mow-sign "sign(s s 0)") "pos")
+
+;; without owise, an overlapping catch-all declared first would shadow others
+(define
+  mow-noowise
+  (mau/parse-module
+    "fmod NOOW is\n  sorts Key Val .\n  ops k1 k2 : -> Key .\n  ops v1 def : -> Val .\n  op f : Key -> Val .\n  var K : Key .\n  eq f(K) = def .\n  eq f(k1) = v1 .\nendfm"))
+
+;; here f(k1) hits the first (catch-all) equation -> def (no owise tag)
+(mow-check! "noowise-shadows" (mau/creduce->str mow-noowise "f(k1)") "def")
+
+(define mau-owise-tests-run! (fn () {:failures mow-failures :total (+ mow-pass mow-fail) :passed mow-pass :failed mow-fail}))

lib/maude/tests/parse.sx

@@ -0,0 +1,250 @@
+;; lib/maude/tests/parse.sx — Phase 1: tokenizer, signatures, term/eq parsing.
+
+(define mpt-pass 0)
+(define mpt-fail 0)
+(define mpt-failures (list))
+
+(define
+  mpt-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mpt-pass (+ mpt-pass 1))
+      (do
+        (set! mpt-fail (+ mpt-fail 1))
+        (append!
+          mpt-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; ---- modules under test ----
+
+(define
+  mpt-peano
+  (mau/parse-module
+    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat [assoc comm prec 33] .\n  op _*_ : Nat Nat -> Nat [assoc comm] .\n  vars X Y : Nat .\n  eq 0 + X = X .\n  eq s X + Y = s (X + Y) .\n  eq 0 * X = 0 .\nendfm"))
+
+(define
+  mpt-natlist
+  (mau/parse-module
+    "fmod NATLIST is\n  sorts Zero NzNat Nat List .\n  subsort Zero < Nat .\n  subsort NzNat < Nat .\n  subsort Nat < List .\n  op 0 : -> Zero .\n  op nil : -> List .\n  op _;_ : List List -> List [assoc id: nil] .\n  op head : List -> Nat .\n  op length : List -> Nat .\n  vars L M : List .\n  var N : Nat .\n  eq length(nil) = 0 .\n  eq head(N ; L) = N .\nendfm"))
+
+;; ---- tokenizer ----
+
+(define mpt-toks (mau/tokenize "op _+_ : Nat Nat -> Nat [assoc] ."))
+
+(mpt-check! "tok-count" (len mpt-toks) 11)
+(mpt-check! "tok-op" (nth mpt-toks 0) "op")
+(mpt-check! "tok-mixfix" (nth mpt-toks 1) "_+_")
+(mpt-check! "tok-colon" (nth mpt-toks 2) ":")
+(mpt-check! "tok-arrow" (nth mpt-toks 5) "->")
+(mpt-check! "tok-lbrack" (nth mpt-toks 7) "[")
+(mpt-check! "tok-dot" (nth mpt-toks 10) ".")
+(mpt-check!
+  "tok-comment"
+  (len (mau/tokenize "sort Nat . --- a comment\nop 0 : -> Nat ."))
+  9)
+
+;; ---- mixfix classification ----
+
+(mpt-check! "form-infix" (get (mau/op-form "_+_") :kind) "infix")
+(mpt-check! "form-infix-tok" (get (mau/op-form "_+_") :token) "+")
+(mpt-check! "form-prefix" (get (mau/op-form "s_") :kind) "prefix")
+(mpt-check! "form-prefix-tok" (get (mau/op-form "s_") :token) "s")
+(mpt-check! "form-postfix" (get (mau/op-form "_!") :kind) "postfix")
+(mpt-check! "form-const" (get (mau/op-form "nil") :kind) "const")
+(mpt-check!
+  "form-mixfix"
+  (get (mau/op-form "if_then_else_fi") :kind)
+  "mixfix")
+
+;; ---- module header / sorts ----
+
+(mpt-check! "mod-name" (mau/module-name mpt-peano) "PEANO")
+(mpt-check! "mod-kind" (mau/module-kind mpt-peano) "fmod")
+(mpt-check! "mod-sorts" (mau/module-sorts mpt-peano) (list "Nat"))
+(mpt-check!
+  "natlist-sorts-count"
+  (len (mau/module-sorts mpt-natlist))
+  4)
+
+;; ---- subsorts (direct + transitive) ----
+
+(mpt-check! "subsort-direct" (mau/subsort? mpt-natlist "NzNat" "Nat") true)
+(mpt-check! "subsort-trans" (mau/subsort? mpt-natlist "NzNat" "List") true)
+(mpt-check! "subsort-trans2" (mau/subsort? mpt-natlist "Zero" "List") true)
+(mpt-check! "subsort-none" (mau/subsort? mpt-natlist "List" "Nat") false)
+(mpt-check! "sort<=-refl" (mau/sort<=? mpt-natlist "Nat" "Nat") true)
+(mpt-check! "sort<=-trans" (mau/sort<=? mpt-natlist "Zero" "List") true)
+
+;; ---- operators / overloading ----
+
+(mpt-check! "ops-count" (len (mau/module-ops mpt-peano)) 4)
+(mpt-check!
+  "op-arity"
+  (get (first (mau/ops-named mpt-peano "_+_")) :arity)
+  (list "Nat" "Nat"))
+(mpt-check!
+  "op-result"
+  (get (first (mau/ops-named mpt-peano "s_")) :result)
+  "Nat")
+(mpt-check!
+  "op-const-arity"
+  (len (get (first (mau/ops-named mpt-peano "0")) :arity))
+  0)
+(mpt-check!
+  "natlist-ops-count"
+  (len (mau/module-ops mpt-natlist))
+  5)
+
+;; ---- attributes ----
+
+(mpt-check!
+  "attr-assoc"
+  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :assoc)
+  true)
+(mpt-check!
+  "attr-comm"
+  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :comm)
+  true)
+(mpt-check!
+  "attr-prec"
+  (get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :prec)
+  33)
+(mpt-check!
+  "attr-id"
+  (get (get (first (mau/ops-named mpt-natlist "_;_")) :attrs) :id)
+  "nil")
+(mpt-check!
+  "attr-absent"
+  (get (get (first (mau/ops-named mpt-peano "_*_")) :attrs) :prec)
+  nil)
+
+;; ---- variables ----
+
+(mpt-check! "var-sort" (get (mau/module-vars mpt-peano) "X") "Nat")
+(mpt-check! "var-list-sort" (get (mau/module-vars mpt-natlist) "L") "List")
+
+;; ---- term parsing ----
+
+(mpt-check!
+  "term-const"
+  (mau/term->str (mau/parse-term-in mpt-peano "0"))
+  "0")
+(mpt-check!
+  "term-prefix-mixfix"
+  (mau/term->str (mau/parse-term-in mpt-peano "s 0"))
+  "s_(0)")
+(mpt-check!
+  "term-nested-prefix"
+  (mau/term->str (mau/parse-term-in mpt-peano "s s 0"))
+  "s_(s_(0))")
+(mpt-check!
+  "term-infix"
+  (mau/term->str (mau/parse-term-in mpt-peano "X + Y"))
+  "_+_(X, Y)")
+(mpt-check!
+  "term-prec"
+  (mau/term->str (mau/parse-term-in mpt-peano "s X + Y"))
+  "_+_(s_(X), Y)")
+(mpt-check!
+  "term-paren"
+  (mau/term->str (mau/parse-term-in mpt-peano "s (X + Y)"))
+  "s_(_+_(X, Y))")
+(mpt-check!
+  "term-left-assoc"
+  (mau/term->str (mau/parse-term-in mpt-peano "X + Y + X"))
+  "_+_(_+_(X, Y), X)")
+(mpt-check!
+  "term-prefix-form"
+  (mau/term->str (mau/parse-term-in mpt-peano "_+_(X, 0)"))
+  "_+_(X, 0)")
+(mpt-check!
+  "term-funcall"
+  (mau/term->str (mau/parse-term-in mpt-natlist "length(nil)"))
+  "length(nil)")
+(mpt-check!
+  "term-onthefly-var"
+  (mau/var? (mau/parse-term-in mpt-peano "Z:Nat"))
+  true)
+(mpt-check!
+  "term-onthefly-sort"
+  (mau/vsort (mau/parse-term-in mpt-peano "Z:Nat"))
+  "Nat")
+(mpt-check!
+  "term-var-vs-const"
+  (mau/var? (mau/parse-term-in mpt-peano "X"))
+  true)
+(mpt-check!
+  "term-const-not-var"
+  (mau/var? (mau/parse-term-in mpt-peano "0"))
+  false)
+
+;; ---- equations ----
+
+(mpt-check! "eq-count" (len (mau/module-eqs mpt-peano)) 3)
+(mpt-check!
+  "eq-lhs"
+  (mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :lhs))
+  "_+_(s_(X), Y)")
+(mpt-check!
+  "eq-rhs"
+  (mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :rhs))
+  "s_(_+_(X, Y))")
+(mpt-check!
+  "eq-uncond"
+  (get (nth (mau/module-eqs mpt-peano) 0) :cond)
+  nil)
+(mpt-check!
+  "natlist-eq-head"
+  (mau/term->str (get (nth (mau/module-eqs mpt-natlist) 1) :lhs))
+  "head(_;_(N, L))")
+
+;; ---- conditional equations ----
+
+(define
+  mpt-gcd
+  (mau/parse-module
+    "fmod GCD is\n  sort Nat .\n  op _>_ : Nat Nat -> Bool .\n  op _-_ : Nat Nat -> Nat .\n  op gcd : Nat Nat -> Nat .\n  vars X Y : Nat .\n  ceq gcd(X, Y) = gcd(X - Y, Y) if X > Y = true .\nendfm"))
+
+(mpt-check! "ceq-count" (len (mau/module-eqs mpt-gcd)) 1)
+(mpt-check!
+  "ceq-has-cond"
+  (= (get (first (mau/module-eqs mpt-gcd)) :cond) nil)
+  false)
+(mpt-check!
+  "ceq-cond-kind"
+  (get (get (first (mau/module-eqs mpt-gcd)) :cond) :kind)
+  "eq")
+(mpt-check!
+  "ceq-cond-lhs"
+  (mau/term->str (get (get (first (mau/module-eqs mpt-gcd)) :cond) :lhs))
+  "_>_(X, Y)")
+
+;; ---- system module + rules ----
+
+(define
+  mpt-vending
+  (mau/parse-module
+    "mod VENDING is\n  sort State .\n  op _coin : State -> State .\n  op buy : State -> State .\n  var S : State .\n  rl [insert] : S coin => buy(S) .\n  crl [guard] : buy(S) => S if S = S .\nendfm"))
+
+(mpt-check! "mod-kind-mod" (mau/module-kind mpt-vending) "mod")
+(mpt-check! "rules-count" (len (mau/module-rules mpt-vending)) 2)
+(mpt-check!
+  "rule-label"
+  (get (first (mau/module-rules mpt-vending)) :label)
+  "insert")
+(mpt-check!
+  "rule-rhs"
+  (mau/term->str (get (first (mau/module-rules mpt-vending)) :rhs))
+  "buy(S)")
+(mpt-check!
+  "crl-label"
+  (get (nth (mau/module-rules mpt-vending) 1) :label)
+  "guard")
+(mpt-check!
+  "crl-cond-kind"
+  (get (get (nth (mau/module-rules mpt-vending) 1) :cond) :kind)
+  "eq")
+
+(define mau-parse-tests-run! (fn () {:failures mpt-failures :total (+ mpt-pass mpt-fail) :passed mpt-pass :failed mpt-fail}))

lib/maude/tests/pretty.sx

@@ -0,0 +1,50 @@
+;; lib/maude/tests/pretty.sx — mixfix surface-syntax printer.
+
+(define mpp-pass 0)
+(define mpp-fail 0)
+(define mpp-failures (list))
+
+(define
+  mpp-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mpp-pass (+ mpp-pass 1))
+      (do
+        (set! mpp-fail (+ mpp-fail 1))
+        (append!
+          mpp-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+(define
+  mpp-m
+  (mau/parse-module
+    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat .\n  op _! : Nat -> Nat .\n  op f : Nat Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\nendfm"))
+
+(define
+  mpp-render
+  (fn (src) (mau/term->maude mpp-m (mau/parse-term-in mpp-m src))))
+
+(mpp-check! "const" (mpp-render "0") "0")
+(mpp-check! "var" (mau/term->maude mpp-m (mau/var "X" "Nat")) "X")
+(mpp-check! "prefix" (mpp-render "s 0") "(s 0)")
+(mpp-check! "infix" (mpp-render "X + Y") "(X + Y)")
+(mpp-check! "nested" (mpp-render "s X + Y") "((s X) + Y)")
+(mpp-check! "paren" (mpp-render "s (X + Y)") "(s (X + Y))")
+;; postfix: built directly (the parser does not produce postfix applications)
+(mpp-check!
+  "postfix"
+  (mau/term->maude mpp-m (mau/app "_!" (list (mau/var "X" "Nat"))))
+  "(X !)")
+(mpp-check! "funcall" (mpp-render "f(0, s 0)") "f(0, (s 0))")
+(mpp-check! "prefix-form-infix" (mpp-render "_+_(0, 0)") "(0 + 0)")
+
+;; reduce then render in surface syntax
+(mpp-check!
+  "red-surface"
+  (mau/red->maude mpp-m "s 0 + s s 0")
+  "(s (s (s 0)))")
+(mpp-check! "red-zero" (mau/red->maude mpp-m "0 + 0") "0")
+
+(define mau-pretty-tests-run! (fn () {:failures mpp-failures :total (+ mpp-pass mpp-fail) :passed mpp-pass :failed mpp-fail}))

lib/maude/tests/reduce.sx

@@ -0,0 +1,120 @@
+;; lib/maude/tests/reduce.sx — Phase 2: syntactic equational reduction.
+
+(define mrt-pass 0)
+(define mrt-fail 0)
+(define mrt-failures (list))
+
+(define
+  mrt-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mrt-pass (+ mrt-pass 1))
+      (do
+        (set! mrt-fail (+ mrt-fail 1))
+        (append!
+          mrt-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; ---- Peano arithmetic ----
+
+(define
+  mrt-peano
+  (mau/parse-module
+    "fmod PEANO is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat .\n  op _*_ : Nat Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\n  eq 0 * Y = 0 .\n  eq s X * Y = Y + (X * Y) .\nendfm"))
+
+(mrt-check!
+  "add-2-1"
+  (mau/reduce->str mrt-peano "s s 0 + s 0")
+  "s_(s_(s_(0)))")
+(mrt-check! "add-0-0" (mau/reduce->str mrt-peano "0 + 0") "0")
+(mrt-check! "add-id-left" (mau/reduce->str mrt-peano "0 + s s 0") "s_(s_(0))")
+(mrt-check!
+  "mul-2-2"
+  (mau/reduce->str mrt-peano "s s 0 * s s 0")
+  "s_(s_(s_(s_(0))))")
+(mrt-check! "mul-zero" (mau/reduce->str mrt-peano "0 * s s s 0") "0")
+(mrt-check! "mul-by-zero" (mau/reduce->str mrt-peano "s s 0 * 0") "0")
+(mrt-check!
+  "nested"
+  (mau/reduce->str mrt-peano "(s 0 + s 0) * s s 0")
+  "s_(s_(s_(s_(0))))")
+
+;; ---- list manipulation ----
+
+(define
+  mrt-list
+  (mau/parse-module
+    "fmod NATLIST is\n  sorts Nat List .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op nil : -> List .\n  op cons : Nat List -> List .\n  op append : List List -> List .\n  op length : List -> Nat .\n  op rev : List -> List .\n  var X : Nat .\n  vars L M : List .\n  eq append(nil, M) = M .\n  eq append(cons(X, L), M) = cons(X, append(L, M)) .\n  eq length(nil) = 0 .\n  eq length(cons(X, L)) = s length(L) .\n  eq rev(nil) = nil .\n  eq rev(cons(X, L)) = append(rev(L), cons(X, nil)) .\nendfm"))
+
+(mrt-check!
+  "append"
+  (mau/reduce->str mrt-list "append(cons(0, nil), cons(s 0, nil))")
+  "cons(0, cons(s_(0), nil))")
+(mrt-check!
+  "append-nil"
+  (mau/reduce->str mrt-list "append(nil, cons(0, nil))")
+  "cons(0, nil)")
+(mrt-check!
+  "length-2"
+  (mau/reduce->str mrt-list "length(cons(0, cons(s 0, nil)))")
+  "s_(s_(0))")
+(mrt-check! "length-0" (mau/reduce->str mrt-list "length(nil)") "0")
+(mrt-check!
+  "rev"
+  (mau/reduce->str mrt-list "rev(cons(0, cons(s 0, nil)))")
+  "cons(s_(0), cons(0, nil))")
+(mrt-check! "rev-empty" (mau/reduce->str mrt-list "rev(nil)") "nil")
+
+;; ---- propositional logic simplifier ----
+
+(define
+  mrt-prop
+  (mau/parse-module
+    "fmod PROPLOGIC is\n  sort Bool .\n  op tt : -> Bool .\n  op ff : -> Bool .\n  op not_ : Bool -> Bool .\n  op _and_ : Bool Bool -> Bool .\n  op _or_ : Bool Bool -> Bool .\n  op _xor_ : Bool Bool -> Bool .\n  vars P Q : Bool .\n  eq not tt = ff .\n  eq not ff = tt .\n  eq tt and P = P .\n  eq ff and P = ff .\n  eq tt or P = tt .\n  eq ff or P = P .\n  eq P xor ff = P .\n  eq P xor tt = not P .\nendfm"))
+
+(mrt-check! "not-tt" (mau/reduce->str mrt-prop "not tt") "ff")
+(mrt-check! "and-simpl" (mau/reduce->str mrt-prop "not (tt and ff)") "tt")
+(mrt-check! "or-simpl" (mau/reduce->str mrt-prop "ff or (tt and tt)") "tt")
+(mrt-check! "double-neg" (mau/reduce->str mrt-prop "not not tt") "tt")
+(mrt-check! "xor-id" (mau/reduce->str mrt-prop "tt xor ff") "tt")
+(mrt-check! "xor-tt" (mau/reduce->str mrt-prop "ff xor tt") "tt")
+(mrt-check!
+  "deep"
+  (mau/reduce->str mrt-prop "(tt and tt) or (not not ff)")
+  "tt")
+
+;; ---- non-linear pattern (repeated variable) + no-match leaves term ----
+
+(define
+  mrt-same
+  (mau/parse-module
+    "fmod SAME is\n  sorts Elt Bool .\n  op a : -> Elt .\n  op b : -> Elt .\n  op tt : -> Bool .\n  op same : Elt Elt -> Bool .\n  var X : Elt .\n  eq same(X, X) = tt .\nendfm"))
+
+(mrt-check! "nonlinear-match" (mau/reduce->str mrt-same "same(a, a)") "tt")
+(mrt-check!
+  "nonlinear-nomatch"
+  (mau/reduce->str mrt-same "same(a, b)")
+  "same(a, b)")
+(mrt-check! "no-rule-stays" (mau/reduce->str mrt-same "b") "b")
+
+;; ---- low-level matching ----
+
+(mrt-check!
+  "match-var-binds"
+  (= nil (mau/match (mau/var "X" "Nat") (mau/const "0") {}))
+  false)
+(mrt-check!
+  "match-mismatch"
+  (mau/match (mau/const "0") (mau/const "1") {})
+  nil)
+(mrt-check!
+  "subst-apply"
+  (mau/term->str
+    (mau/subst-apply
+      (assoc {} "X" (mau/const "0"))
+      (mau/app "s_" (list (mau/var "X" "Nat")))))
+  "s_(0)")
+
+(define mau-reduce-tests-run! (fn () {:failures mrt-failures :total (+ mrt-pass mrt-fail) :passed mrt-pass :failed mrt-fail}))

lib/maude/tests/rewrite.sx

@@ -0,0 +1,114 @@
+;; lib/maude/tests/rewrite.sx — Phase 5: system modules + rewrite rules.
+
+(define mrw-pass 0)
+(define mrw-fail 0)
+(define mrw-failures (list))
+
+(define
+  mrw-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mrw-pass (+ mrw-pass 1))
+      (do
+        (set! mrw-fail (+ mrw-fail 1))
+        (append!
+          mrw-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; ---- AC multiset transition (the headline: rule on a sub-multiset) ----
+
+(define
+  mrw-coins
+  (mau/parse-module
+    "mod COINS is\n  sort Marking .\n  op nil : -> Marking .\n  op q : -> Marking .\n  op d : -> Marking .\n  op _;_ : Marking Marking -> Marking [assoc comm id: nil] .\n  rl [change] : q ; q ; q ; q => d .\nendm"))
+
+(mrw-check! "coins-kind" (mau/module-kind mrw-coins) "mod")
+(mrw-check! "coins-rules" (len (mau/module-rules mrw-coins)) 1)
+(mrw-check! "coins-exact" (mau/rewrite-canon mrw-coins "q ; q ; q ; q") "d")
+(mrw-check!
+  "coins-5"
+  (mau/rewrite-canon mrw-coins "q ; q ; q ; q ; q")
+  "_;_(d,q)")
+(mrw-check!
+  "coins-8"
+  (mau/rewrite-canon mrw-coins "q ; q ; q ; q ; q ; q ; q ; q")
+  "_;_(d,d)")
+(mrw-check!
+  "coins-3-stuck"
+  (mau/rewrite-canon mrw-coins "q ; q ; q")
+  "_;_(q,q,q)")
+
+;; ---- cyclic state machine (bounded rew) ----
+
+(define
+  mrw-traffic
+  (mau/parse-module
+    "mod TRAFFIC is\n  sort Light .\n  ops red green yellow : -> Light .\n  rl [g] : red => green .\n  rl [y] : green => yellow .\n  rl [r] : yellow => red .\nendm"))
+
+(mrw-check! "traffic-1" (mau/rew->str mrw-traffic "red" 1) "green")
+(mrw-check! "traffic-2" (mau/rew->str mrw-traffic "red" 2) "yellow")
+(mrw-check! "traffic-3" (mau/rew->str mrw-traffic "red" 3) "red")
+(mrw-check! "traffic-0" (mau/rew->str mrw-traffic "green" 0) "green")
+
+;; ---- nondeterministic branching: rew (one path) vs search (all paths) ----
+
+(define
+  mrw-ndet
+  (mau/parse-module
+    "mod NDET is\n  sort S .\n  ops a b c d goal : -> S .\n  rl [r1] : a => b .\n  rl [r2] : a => c .\n  rl [r3] : b => d .\n  rl [r4] : c => goal .\nendm"))
+
+;; rew takes the first rule each step: a -> b -> d (stuck), never reaches goal.
+(mrw-check! "ndet-rew-path" (mau/rewrite->str mrw-ndet "a") "d")
+(mrw-check! "ndet-succ" (mau/successors mrw-ndet "a") (list "b" "c"))
+(mrw-check!
+  "ndet-search-goal"
+  (mau/search mrw-ndet "a" "goal" 5)
+  true)
+(mrw-check!
+  "ndet-search-shallow"
+  (mau/search mrw-ndet "a" "goal" 1)
+  false)
+(mrw-check! "ndet-search-self" (mau/search mrw-ndet "a" "a" 3) true)
+(mrw-check! "ndet-search-d" (mau/search mrw-ndet "a" "d" 5) true)
+
+;; ---- conditional rule (crl with equational guard) ----
+
+(define
+  mrw-clock
+  (mau/parse-module
+    "mod CLOCK is\n  sorts Nat Bool .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op true : -> Bool .\n  op false : -> Bool .\n  op _<_ : Nat Nat -> Bool .\n  op clk : Nat -> Nat .\n  vars M N : Nat .\n  eq 0 < s N = true .\n  eq N < 0 = false .\n  eq s M < s N = M < N .\n  crl [tick] : clk(N) => clk(s N) if N < s s s 0 = true .\nendm"))
+
+;; tick fires while N < 3, then stops at clk(3).
+(mrw-check!
+  "clock-run"
+  (mau/rewrite->str mrw-clock "clk(0)")
+  "clk(s_(s_(s_(0))))")
+(mrw-check!
+  "clock-from-1"
+  (mau/rewrite->str mrw-clock "clk(s 0)")
+  "clk(s_(s_(s_(0))))")
+(mrw-check!
+  "clock-step1"
+  (mau/rew->str mrw-clock "clk(0)" 1)
+  "clk(s_(0))")
+
+;; ---- eqs interleave with rules ----
+
+(define
+  mrw-mix
+  (mau/parse-module
+    "mod MIX is\n  sort Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat .\n  op f : Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\n  rl [step] : f(X) => f(X + s 0) .\nendm"))
+
+;; each rule step adds one (via the rule), eqs normalise the sum.
+(mrw-check!
+  "mix-step1"
+  (mau/rew->str mrw-mix "f(s 0)" 1)
+  "f(s_(s_(0)))")
+(mrw-check!
+  "mix-step2"
+  (mau/rew->str mrw-mix "f(0)" 2)
+  "f(s_(s_(0)))")
+
+(define mau-rewrite-tests-run! (fn () {:failures mrw-failures :total (+ mrw-pass mrw-fail) :passed mrw-pass :failed mrw-fail}))

lib/maude/tests/run.sx

@@ -0,0 +1,79 @@
+;; lib/maude/tests/run.sx — running a Maude program (module + commands).
+
+(define mrn-pass 0)
+(define mrn-fail 0)
+(define mrn-failures (list))
+
+(define
+  mrn-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mrn-pass (+ mrn-pass 1))
+      (do
+        (set! mrn-fail (+ mrn-fail 1))
+        (append!
+          mrn-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+(define
+  mrn-peano
+  "fmod PEANO is\n  sorts Nat NzNat .\n  subsort NzNat < Nat .\n  op 0 : -> Nat .\n  op s_ : Nat -> NzNat .\n  op _+_ : Nat Nat -> Nat .\n  op _*_ : Nat Nat -> Nat .\n  vars X Y : Nat .\n  eq 0 + Y = Y .\n  eq s X + Y = s (X + Y) .\n  eq 0 * Y = 0 .\n  eq s X * Y = Y + (X * Y) .\nendfm\nred s 0 + s s 0 .\nred 0 + 0 .\nreduce in PEANO : s s 0 * s s 0 .")
+
+(mrn-check!
+  "peano-results"
+  (mau/run mrn-peano)
+  (list "(s (s (s 0)))" "0" "(s (s (s (s 0))))"))
+
+(mrn-check! "peano-count" (len (mau/run-program mrn-peano)) 3)
+(mrn-check!
+  "peano-cmd-kind"
+  (get (first (mau/run-program mrn-peano)) :cmd)
+  "reduce")
+
+;; least-sort annotated output: s_ : Nat -> NzNat, so s(...) is NzNat
+(mrn-check!
+  "peano-pretty"
+  (mau/run-pretty mrn-peano)
+  (list
+    "result NzNat: (s (s (s 0)))"
+    "result Nat: 0"
+    "result NzNat: (s (s (s (s 0))))"))
+
+(define
+  mrn-coins
+  "mod COINS is\n  sort M .\n  op nil : -> M .\n  op q : -> M .\n  op d : -> M .\n  op _;_ : M M -> M [assoc comm id: nil] .\n  rl [change] : q ; q ; q ; q => d .\nendm\nrew q ; q ; q ; q ; q .\nrewrite q ; q ; q ; q ; q ; q ; q ; q .")
+
+(mrn-check! "coins-results" (mau/run mrn-coins) (list "(d ; q)" "(d ; d)"))
+
+(mrn-check!
+  "coins-cmd-kind"
+  (get (first (mau/run-program mrn-coins)) :cmd)
+  "rewrite")
+
+;; search command
+(define
+  mrn-ndet
+  "mod NDET is\n  sort S .\n  ops a b c goal : -> S .\n  rl [r1] : a => b .\n  rl [r2] : a => c .\n  rl [r3] : c => goal .\nendm\nsearch a =>* goal .\nsearch a =>* b .\nsearch b =>* goal .")
+
+(mrn-check!
+  "search-results"
+  (mau/run mrn-ndet)
+  (list "a => c => goal" "a => b" "no solution"))
+(mrn-check!
+  "search-cmd-kind"
+  (get (first (mau/run-program mrn-ndet)) :cmd)
+  "search")
+(mrn-check!
+  "search-pretty"
+  (first (mau/run-pretty mrn-ndet))
+  "search: a => c => goal")
+
+;; module-only (no commands) runs to an empty result list
+(mrn-check!
+  "no-commands"
+  (mau/run "fmod EMPTY is\n  sort S .\n  op a : -> S .\nendfm")
+  (list))
+
+(define mau-run-tests-run! (fn () {:failures mrn-failures :total (+ mrn-pass mrn-fail) :passed mrn-pass :failed mrn-fail}))

lib/maude/tests/searchpath.sx

@@ -0,0 +1,66 @@
+;; lib/maude/tests/searchpath.sx — search returning the witness path.
+
+(define msp-pass 0)
+(define msp-fail 0)
+(define msp-failures (list))
+
+(define
+  msp-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! msp-pass (+ msp-pass 1))
+      (do
+        (set! msp-fail (+ msp-fail 1))
+        (append!
+          msp-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+(define
+  msp-ndet
+  (mau/parse-module
+    "mod NDET is\n  sort S .\n  ops a b c d goal : -> S .\n  rl [r1] : a => b .\n  rl [r2] : a => c .\n  rl [r3] : b => d .\n  rl [r4] : c => goal .\nendm"))
+
+;; shortest path a -> c -> goal
+(msp-check!
+  "path-to-goal"
+  (mau/search-path msp-ndet "a" "goal" 5)
+  (list "a" "c" "goal"))
+(msp-check!
+  "path-length"
+  (mau/search-length msp-ndet "a" "goal" 5)
+  2)
+(msp-check!
+  "path-self"
+  (mau/search-path msp-ndet "a" "a" 3)
+  (list "a"))
+(msp-check!
+  "path-one-step"
+  (mau/search-path msp-ndet "a" "b" 3)
+  (list "a" "b"))
+(msp-check!
+  "path-unreachable"
+  (mau/search-path msp-ndet "d" "goal" 5)
+  nil)
+(msp-check!
+  "path-depth-limited"
+  (mau/search-path msp-ndet "a" "goal" 1)
+  nil)
+
+;; a counter that ticks up: path shows each state
+(define
+  msp-walk
+  (mau/parse-module
+    "mod WALK is\n  sort Pos .\n  op z : -> Pos .\n  op s : Pos -> Pos .\n  op p : Pos -> Pos .\n  var X : Pos .\n  rl [step] : p(X) => p(s(X)) .\nendm"))
+
+(msp-check!
+  "walk-path"
+  (mau/search-path msp-walk "p(z)" "p(s(s(z)))" 5)
+  (list "p(z)" "p(s(z))" "p(s(s(z)))"))
+(msp-check!
+  "walk-length"
+  (mau/search-length msp-walk "p(z)" "p(s(s(s(z))))" 6)
+  3)
+
+(define mau-searchpath-tests-run! (fn () {:failures msp-failures :total (+ msp-pass msp-fail) :passed msp-pass :failed msp-fail}))

lib/maude/tests/sorts.sx

@@ -0,0 +1,53 @@
+;; lib/maude/tests/sorts.sx — order-sorted least-sort inference.
+
+(define mso-pass 0)
+(define mso-fail 0)
+(define mso-failures (list))
+
+(define
+  mso-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mso-pass (+ mso-pass 1))
+      (do
+        (set! mso-fail (+ mso-fail 1))
+        (append!
+          mso-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+(define
+  mso-m
+  (mau/parse-module
+    "fmod NUMS is\n  sorts Zero NzNat Nat .\n  subsort Zero < Nat .\n  subsort NzNat < Nat .\n  op 0 : -> Zero .\n  op 1 : -> NzNat .\n  op s_ : Nat -> Nat .\n  op _+_ : Nat Nat -> Nat .\n  op p : NzNat -> NzNat .\n  op f : Nat -> Nat .\n  op f : NzNat -> NzNat .\nendfm"))
+
+;; constants take their declared result sort
+(mso-check! "sort-zero" (mau/term-sort-src mso-m "0") "Zero")
+(mso-check! "sort-one" (mau/term-sort-src mso-m "1") "NzNat")
+
+;; application: arg subsort of declared domain
+(mso-check! "sort-s0" (mau/term-sort-src mso-m "s 0") "Nat")
+(mso-check! "sort-plus" (mau/term-sort-src mso-m "0 + 1") "Nat")
+(mso-check! "sort-p" (mau/term-sort-src mso-m "p(1)") "NzNat")
+
+;; variable keeps its sort
+(mso-check! "sort-var" (mau/term-sort mso-m (mau/var "X" "Nat")) "Nat")
+
+;; LEAST sort under overloading: f(1) fits both f decls -> the smaller, NzNat
+(mso-check! "least-f-1" (mau/term-sort-src mso-m "f(1)") "NzNat")
+;; f(s 0): s 0 is Nat, only fits f : Nat -> Nat
+(mso-check! "least-f-s0" (mau/term-sort-src mso-m "f(s 0)") "Nat")
+;; nested: f(f(1)) -> f(NzNat) -> NzNat
+(mso-check! "least-nested" (mau/term-sort-src mso-m "f(f(1))") "NzNat")
+
+;; membership-style sort checks
+(mso-check! "has-zero-nat" (mau/has-sort-src? mso-m "0" "Nat") true)
+(mso-check! "has-one-nat" (mau/has-sort-src? mso-m "1" "Nat") true)
+(mso-check! "has-zero-not-nznat" (mau/has-sort-src? mso-m "0" "NzNat") false)
+(mso-check! "has-refl" (mau/has-sort-src? mso-m "1" "NzNat") true)
+
+;; unknown operator -> "?"
+(mso-check! "sort-unknown" (mau/term-sort mso-m (mau/const "ghost")) "?")
+
+(define mau-sorts-tests-run! (fn () {:failures mso-failures :total (+ mso-pass mso-fail) :passed mso-pass :failed mso-fail}))

lib/maude/tests/strategy.sx

@@ -0,0 +1,151 @@
+;; lib/maude/tests/strategy.sx — Phase 6: strategy language.
+
+(define mst-pass 0)
+(define mst-fail 0)
+(define mst-failures (list))
+
+(define
+  mst-check!
+  (fn
+    (name got expected)
+    (if
+      (= got expected)
+      (set! mst-pass (+ mst-pass 1))
+      (do
+        (set! mst-fail (+ mst-fail 1))
+        (append!
+          mst-failures
+          (str name "  expected: " expected "  got: " got))))))
+
+;; ---- a branching system; meaning depends on the strategy ----
+
+(define
+  mst-mod
+  (mau/parse-module
+    "mod CHOICE is\n  sort S .\n  ops a b c x y : -> S .\n  rl [r1] : a => b .\n  rl [r2] : b => c .\n  rl [toX] : a => x .\n  rl [toY] : a => y .\nendm"))
+
+(define mst-env {})
+(dict-set! mst-env "twice" (mau/s-seq (mau/s-rule "r1") (mau/s-rule "r2")))
+(dict-set! mst-env "anyplus" (mau/s-plus (mau/s-all)))
+(dict-set! mst-env "norm" (mau/s-bang (mau/s-all)))
+
+;; basic combinators
+(mst-check!
+  "idle"
+  (mau/srun-canon mst-mod mst-env (mau/s-idle) "a")
+  (list "a"))
+(mst-check! "fail" (mau/srun-canon mst-mod mst-env (mau/s-fail) "a") (list))
+(mst-check!
+  "single-rule"
+  (mau/srun-canon mst-mod mst-env (mau/s-rule "r1") "a")
+  (list "b"))
+(mst-check!
+  "single-rule-x"
+  (mau/srun-canon mst-mod mst-env (mau/s-rule "toX") "a")
+  (list "x"))
+(mst-check!
+  "all"
+  (mau/srun-canon mst-mod mst-env (mau/s-all) "a")
+  (list "b" "x" "y"))
+
+;; sequencing: order matters
+(mst-check!
+  "seq-ok"
+  (mau/srun-canon
+    mst-mod
+    mst-env
+    (mau/s-seq (mau/s-rule "r1") (mau/s-rule "r2"))
+    "a")
+  (list "c"))
+(mst-check!
+  "seq-fail"
+  (mau/srun-canon
+    mst-mod
+    mst-env
+    (mau/s-seq (mau/s-rule "r2") (mau/s-rule "r1"))
+    "a")
+  (list))
+
+;; alternation: union
+(mst-check!
+  "alt"
+  (mau/srun-canon
+    mst-mod
+    mst-env
+    (mau/s-alt (mau/s-rule "toX") (mau/s-rule "toY"))
+    "a")
+  (list "x" "y"))
+(mst-check!
+  "alt-with-fail"
+  (mau/srun-canon
+    mst-mod
+    mst-env
+    (mau/s-alt (mau/s-rule "r2") (mau/s-rule "r1"))
+    "a")
+  (list "b"))
+
+;; iteration
+(mst-check!
+  "star"
+  (mau/srun-canon mst-mod mst-env (mau/s-star (mau/s-all)) "a")
+  (list "a" "b" "c" "x" "y"))
+(mst-check!
+  "plus"
+  (mau/srun-canon mst-mod mst-env (mau/s-plus (mau/s-all)) "a")
+  (list "b" "c" "x" "y"))
+(mst-check!
+  "bang-normal-forms"
+  (mau/srun-canon mst-mod mst-env (mau/s-bang (mau/s-all)) "a")
+  (list "c" "x" "y"))
+(mst-check!
+  "star-from-b"
+  (mau/srun-canon mst-mod mst-env (mau/s-star (mau/s-all)) "b")
+  (list "b" "c"))
+
+;; named strategies + strategy expressions as values
+(mst-check!
+  "named-twice"
+  (mau/srun-canon mst-mod mst-env (mau/s-name "twice") "a")
+  (list "c"))
+(mst-check!
+  "named-anyplus"
+  (mau/srun-canon mst-mod mst-env (mau/s-name "anyplus") "a")
+  (list "b" "c" "x" "y"))
+(mst-check!
+  "named-norm"
+  (mau/srun-canon mst-mod mst-env (mau/s-name "norm") "a")
+  (list "c" "x" "y"))
+
+;; nested composition: (r1 ; r2) | toX
+(mst-check!
+  "nested"
+  (mau/srun-canon
+    mst-mod
+    mst-env
+    (mau/s-alt
+      (mau/s-seq (mau/s-rule "r1") (mau/s-rule "r2"))
+      (mau/s-rule "toX"))
+    "a")
+  (list "c" "x"))
+
+;; ---- a 1-D walk: strategy chooses how far ----
+
+(define
+  mst-walk
+  (mau/parse-module
+    "mod WALK is\n  sort Pos .\n  op 0 : -> Pos .\n  op s_ : Pos -> Pos .\n  op p : Pos -> Pos .\n  var X : Pos .\n  rl [step] : p(X) => p(s X) .\nendm"))
+
+(mst-check!
+  "walk-one"
+  (mau/srun-canon mst-walk {} (mau/s-rule "step") "p(0)")
+  (list "p(s_(0))"))
+(mst-check!
+  "walk-twice"
+  (mau/srun-canon
+    mst-walk
+    {}
+    (mau/s-seq (mau/s-rule "step") (mau/s-rule "step"))
+    "p(0)")
+  (list "p(s_(s_(0)))"))
+
+(define mau-strategy-tests-run! (fn () {:failures mst-failures :total (+ mst-pass mst-fail) :passed mst-pass :failed mst-fail}))

lib/prolog/runtime.sx

@@ -2792,3 +2792,10 @@
         {:cut false}
         (fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
       (dict-get box :n))))
+
+;; ── JIT interpret-only boundary ───────────────────────────────────────────
+;; The Prolog resolution engine (pl-solve! and friends) recurses deeply over
+;; goals/clauses with backtracking; under JIT it miscompiles into a
+;; non-terminating loop (the suite never completes). Exclude the whole pl-
+;; namespace from JIT. See Sx_types.jit_excluded_prefixes.
+(jit-exclude! "pl-*")

lib/scheme/runtime.sx

@@ -647,3 +647,11 @@
                           (raise (get outcome :value)))
                         (:else outcome))))))))))
       env)))
+
+;; ── JIT interpret-only boundary ───────────────────────────────────────────
+;; The Scheme evaluator uses call/cc, dynamic-wind, guard/raise and applies
+;; user procedures (which may be continuations or JIT-returned closures); a
+;; JIT-compiled frame cannot transfer control through a CEK continuation.
+;; Exclude the whole scheme-/scm- namespace from JIT (robust vs a name list,
+;; which misses functions in extra files). See Sx_types.jit_excluded_prefixes.
+(jit-exclude! "scheme-*" "scm-*")

lib/smalltalk/eval.sx

@@ -1475,3 +1475,22 @@
                        (get ast :temps)))
                    (smalltalk-eval-ast ast frame)))))))
         (begin (dict-set! cell :active false) result)))))
+
+;; ── JIT interpret-only boundary ──────────────────────────────────────────
+;; The Smalltalk evaluator implements non-local return (^expr), block escape,
+;; and exception unwinding via first-class continuations (call/cc). A stack
+;; bytecode VM cannot transfer control through a CEK continuation, so any of
+;; these dispatch-core functions, if JIT-compiled, would be an un-escapable
+;; VM frame on the stack between a `call/cc` capture and its `(k v)` invocation
+;; — failing at runtime and (before this guard) re-running with duplicated
+;; side effects. Declaring them interpret-only keeps them on the CEK while the
+;; pure leaf helpers (parsing, ident/ivar lookup, formatting, predicates,
+;; arithmetic) still JIT. See Sx_types.jit_excluded / `jit-exclude!`.
+(jit-exclude!
+  "smalltalk-eval" "smalltalk-eval-program" "smalltalk-load"
+  "smalltalk-eval-ast" "st-eval-seq" "st-eval-send" "st-eval-send-dispatch"
+  "st-eval-cascade" "st-try-intrinsify" "st-send" "st-invoke" "st-dnu"
+  "st-super-send" "st-primitive-send" "st-num-send" "st-bool-send"
+  "st-string-send" "st-array-send" "st-nil-send" "st-class-side-send"
+  "st-block-apply" "st-block-dispatch" "st-block-while" "st-block-ensure"
+  "st-block-if-curtailed" "st-block-on-do" "st-block-value-selector?")

lib/smalltalk/tests/tokenize.sx

@@ -360,3 +360,10 @@
     {:type "number" :value 2}))
 
 (list st-test-pass st-test-fail)
+
+;; The SUnit suite-runner `pharo-test-class` (defined in tests/pharo.sx and
+;; tests/ansi.sx) drives the interpret-only Smalltalk evaluator through
+;; smalltalk-eval-program in a loop and accumulates results via st-test
+;; (a side-effecting accumulator). Under JIT it can fail mid-loop and re-run
+;; via CEK, double-counting already-emitted rows. Keep it interpret-only.
+(jit-exclude! "pharo-test-class")

next/.gitignore

@@ -0,0 +1 @@
+data/