plans: lib-guest-reflective extraction kicked off — Tcl uplevel as second consumer

The kernel-on-sx loop documented six candidate reflective API files
gated on the two-consumer rule. This plan opens that block by
selecting Tcl's existing uplevel/upvar machinery as the second
consumer for env.sx specifically (the highest-fit candidate).

Discovery: Kernel and Tcl have identical scope-chain semantics but
diverge on mutable-vs-functional update. Solution: adapter-cfg
pattern, same as lib/guest/match.sx. Canonical wire shape with
mutable defaults for Kernel; Tcl provides its own cfg keeping
the functional model.

Roadmap: env.sx extracted, both consumers migrated, all tests green.
The other five candidate files (combiner, evaluator, hygiene,
quoting, short-circuit) stay deferred — Tcl has no operatives.

hosts/ocaml/bin/run_tests.ml

@@ -1279,7 +1279,7 @@ let run_foundation_tests () =
   assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
   assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
   assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
-  let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
+  let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None; l_call_count = 0 } in
   assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
   ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
   assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))

hosts/ocaml/bootstrap_vm.py

@@ -355,7 +355,9 @@ let vm_create_closure vm_val frame_val code_val =
   let f = unwrap_frame frame_val in
   let uv_count = match code_val with
     | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-        | Some (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

hosts/ocaml/browser/sx_browser.ml

@@ -715,8 +715,10 @@ let () =
         | List (Symbol "code" :: rest) ->
           let d = Hashtbl.create 8 in
           let rec parse_kv = function
-            | Keyword "arity" :: Number n :: rest -> Hashtbl.replace d "arity" (Number n); parse_kv rest
-            | Keyword "upvalue-count" :: Number n :: rest -> Hashtbl.replace d "upvalue-count" (Number n); parse_kv rest
+            | Keyword "arity" :: (Number _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest
+            | Keyword "arity" :: (Integer _ as n) :: rest -> Hashtbl.replace d "arity" n; parse_kv rest
+            | Keyword "upvalue-count" :: (Number _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest
+            | Keyword "upvalue-count" :: (Integer _ as n) :: rest -> Hashtbl.replace d "upvalue-count" n; parse_kv rest
             | Keyword "bytecode" :: List nums :: rest ->
               Hashtbl.replace d "bytecode" (List nums); parse_kv rest
             | Keyword "constants" :: List consts :: rest ->

hosts/ocaml/lib/sx_primitives.ml

@@ -528,6 +528,183 @@ let () =
     | [Rational (_, d)] -> Integer d
     | [Integer _]       -> Integer 1
     | _ -> raise (Eval_error "denominator: expected rational or integer"));
+  (* printf-spec: apply one Tcl/printf format spec to one arg.
+     spec is like "%5.2f", "%-10s", "%x", "%c", "%d". Always starts with %
+     and ends with the conversion char.  Supports d i u x X o c s f e g.
+     Coerces arg to the right type per conversion. *)
+  register "printf-spec" (fun args ->
+    let spec_str, arg = match args with
+      | [String s; v] -> (s, v)
+      | _ -> raise (Eval_error "printf-spec: (spec arg)")
+    in
+    let n = String.length spec_str in
+    if n < 2 || spec_str.[0] <> '%' then
+      raise (Eval_error ("printf-spec: invalid spec " ^ spec_str));
+    let type_char = spec_str.[n - 1] in
+    let to_int v = match v with
+      | Integer i -> i
+      | Number f -> int_of_float f
+      | String s ->
+        let s = String.trim s in
+        (try int_of_string s
+         with _ ->
+           try int_of_float (float_of_string s)
+           with _ -> 0)
+      | Bool true -> 1 | Bool false -> 0
+      | _ -> 0
+    in
+    let to_float v = match v with
+      | Number f -> f
+      | Integer i -> float_of_int i
+      | String s ->
+        let s = String.trim s in
+        (try float_of_string s with _ -> 0.0)
+      | _ -> 0.0
+    in
+    let to_string v = match v with
+      | String s -> s
+      | Integer i -> string_of_int i
+      | Number f -> Sx_types.format_number f
+      | Bool true -> "1" | Bool false -> "0"
+      | Nil -> ""
+      | _ -> Sx_types.inspect v
+    in
+    try
+      match type_char with
+      | 'd' | 'i' ->
+        let fmt = Scanf.format_from_string spec_str "%d" in
+        String (Printf.sprintf fmt (to_int arg))
+      | 'u' ->
+        let fmt = Scanf.format_from_string spec_str "%u" in
+        String (Printf.sprintf fmt (to_int arg))
+      | 'x' ->
+        let fmt = Scanf.format_from_string spec_str "%x" in
+        String (Printf.sprintf fmt (to_int arg))
+      | 'X' ->
+        let fmt = Scanf.format_from_string spec_str "%X" in
+        String (Printf.sprintf fmt (to_int arg))
+      | 'o' ->
+        let fmt = Scanf.format_from_string spec_str "%o" in
+        String (Printf.sprintf fmt (to_int arg))
+      | 'c' ->
+        let n_val = to_int arg in
+        let body = String.sub spec_str 0 (n - 1) in
+        let fmt = Scanf.format_from_string (body ^ "s") "%s" in
+        String (Printf.sprintf fmt (String.make 1 (Char.chr (n_val land 0xff))))
+      | 's' ->
+        let fmt = Scanf.format_from_string spec_str "%s" in
+        String (Printf.sprintf fmt (to_string arg))
+      | 'f' ->
+        let fmt = Scanf.format_from_string spec_str "%f" in
+        String (Printf.sprintf fmt (to_float arg))
+      | 'e' ->
+        let fmt = Scanf.format_from_string spec_str "%e" in
+        String (Printf.sprintf fmt (to_float arg))
+      | 'E' ->
+        let fmt = Scanf.format_from_string spec_str "%E" in
+        String (Printf.sprintf fmt (to_float arg))
+      | 'g' ->
+        let fmt = Scanf.format_from_string spec_str "%g" in
+        String (Printf.sprintf fmt (to_float arg))
+      | 'G' ->
+        let fmt = Scanf.format_from_string spec_str "%G" in
+        String (Printf.sprintf fmt (to_float arg))
+      | _ -> raise (Eval_error ("printf-spec: unsupported conversion " ^ String.make 1 type_char))
+    with
+    | Eval_error _ as e -> raise e
+    | _ -> raise (Eval_error ("printf-spec: invalid format " ^ spec_str)));
+
+  (* scan-spec: apply one Tcl/scanf format spec to a string.
+     Returns (consumed-count . parsed-value), or nil on failure. *)
+  register "scan-spec" (fun args ->
+    let spec_str, str = match args with
+      | [String s; String input] -> (s, input)
+      | _ -> raise (Eval_error "scan-spec: (spec input)")
+    in
+    let n = String.length spec_str in
+    if n < 2 || spec_str.[0] <> '%' then
+      raise (Eval_error ("scan-spec: invalid spec " ^ spec_str));
+    let type_char = spec_str.[n - 1] in
+    let len = String.length str in
+    (* skip leading whitespace for non-%c/%s conversions *)
+    let i = ref 0 in
+    if type_char <> 'c' then
+      while !i < len && (str.[!i] = ' ' || str.[!i] = '\t' || str.[!i] = '\n') do incr i done;
+    let start = !i in
+    try
+      match type_char with
+      | 'd' | 'i' ->
+        let j = ref !i in
+        if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
+        while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done;
+        if !j > start && (str.[start] >= '0' && str.[start] <= '9'
+                         || (!j > start + 1 && (str.[start] = '-' || str.[start] = '+'))) then
+          let n_val = int_of_string (String.sub str start (!j - start)) in
+          let d = Hashtbl.create 2 in
+          Hashtbl.replace d "value" (Integer n_val);
+          Hashtbl.replace d "consumed" (Integer !j);
+          Dict d
+        else Nil
+      | 'x' | 'X' ->
+        let j = ref !i in
+        while !j < len &&
+              ((str.[!j] >= '0' && str.[!j] <= '9') ||
+               (str.[!j] >= 'a' && str.[!j] <= 'f') ||
+               (str.[!j] >= 'A' && str.[!j] <= 'F')) do incr j done;
+        if !j > start then
+          let n_val = int_of_string ("0x" ^ String.sub str start (!j - start)) in
+          let d = Hashtbl.create 2 in
+          Hashtbl.replace d "value" (Integer n_val);
+          Hashtbl.replace d "consumed" (Integer !j);
+          Dict d
+        else Nil
+      | 'o' ->
+        let j = ref !i in
+        while !j < len && str.[!j] >= '0' && str.[!j] <= '7' do incr j done;
+        if !j > start then
+          let n_val = int_of_string ("0o" ^ String.sub str start (!j - start)) in
+          let d = Hashtbl.create 2 in
+          Hashtbl.replace d "value" (Integer n_val);
+          Hashtbl.replace d "consumed" (Integer !j);
+          Dict d
+        else Nil
+      | 'f' | 'e' | 'g' ->
+        let j = ref !i in
+        if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
+        while !j < len && ((str.[!j] >= '0' && str.[!j] <= '9') || str.[!j] = '.') do incr j done;
+        if !j < len && (str.[!j] = 'e' || str.[!j] = 'E') then begin
+          incr j;
+          if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
+          while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done
+        end;
+        if !j > start then
+          let f_val = float_of_string (String.sub str start (!j - start)) in
+          let d = Hashtbl.create 2 in
+          Hashtbl.replace d "value" (Number f_val);
+          Hashtbl.replace d "consumed" (Integer !j);
+          Dict d
+        else Nil
+      | 's' ->
+        let j = ref !i in
+        while !j < len && str.[!j] <> ' ' && str.[!j] <> '\t' && str.[!j] <> '\n' do incr j done;
+        if !j > start then
+          let d = Hashtbl.create 2 in
+          Hashtbl.replace d "value" (String (String.sub str start (!j - start)));
+          Hashtbl.replace d "consumed" (Integer !j);
+          Dict d
+        else Nil
+      | 'c' ->
+        if !i < len then
+          let d = Hashtbl.create 2 in
+          Hashtbl.replace d "value" (Integer (Char.code str.[!i]));
+          Hashtbl.replace d "consumed" (Integer (!i + 1));
+          Dict d
+        else Nil
+      | _ -> raise (Eval_error ("scan-spec: unsupported conversion " ^ String.make 1 type_char))
+    with
+    | Eval_error _ as e -> raise e
+    | _ -> Nil);
+
   register "parse-int" (fun args ->
     let parse_leading_int s =
       let len = String.length s in
@@ -3124,6 +3301,640 @@ let () =
     | [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
     | _ -> raise (Eval_error "file-glob: (pattern)"));
 
+  (* === File metadata + ops (Phase 5d) === *)
+  let stat_or = function
+    | String path -> (try Some (Unix.stat path) with _ -> None)
+    | _ -> raise (Eval_error "file: path must be a string")
+  in
+  register "file-size" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Integer s.Unix.st_size | None -> Integer 0)
+    | _ -> raise (Eval_error "file-size: (path)"));
+  register "file-mtime" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Integer (int_of_float s.Unix.st_mtime) | None -> Integer 0)
+    | _ -> raise (Eval_error "file-mtime: (path)"));
+  register "file-isfile?" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_REG) | None -> Bool false)
+    | _ -> raise (Eval_error "file-isfile?: (path)"));
+  register "file-isdir?" (fun args ->
+    match args with
+    | [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_DIR) | None -> Bool false)
+    | _ -> raise (Eval_error "file-isdir?: (path)"));
+  register "file-readable?" (fun args ->
+    match args with
+    | [String path] ->
+      Bool (try Unix.access path [Unix.R_OK]; true with _ -> false)
+    | _ -> raise (Eval_error "file-readable?: (path)"));
+  register "file-writable?" (fun args ->
+    match args with
+    | [String path] ->
+      Bool (try Unix.access path [Unix.W_OK]; true with _ -> false)
+    | _ -> raise (Eval_error "file-writable?: (path)"));
+  register "file-stat" (fun args ->
+    match args with
+    | [v] ->
+      (match stat_or v with
+       | None -> Nil
+       | Some s ->
+         let d = Hashtbl.create 6 in
+         Hashtbl.replace d "size" (Integer s.Unix.st_size);
+         Hashtbl.replace d "mtime" (Integer (int_of_float s.Unix.st_mtime));
+         Hashtbl.replace d "atime" (Integer (int_of_float s.Unix.st_atime));
+         Hashtbl.replace d "ctime" (Integer (int_of_float s.Unix.st_ctime));
+         Hashtbl.replace d "mode" (Integer s.Unix.st_perm);
+         Hashtbl.replace d "type" (String (match s.Unix.st_kind with
+           | Unix.S_REG -> "file" | Unix.S_DIR -> "directory"
+           | Unix.S_LNK -> "link" | Unix.S_CHR -> "characterSpecial"
+           | Unix.S_BLK -> "blockSpecial" | Unix.S_FIFO -> "fifo"
+           | Unix.S_SOCK -> "socket"));
+         Dict d)
+    | _ -> raise (Eval_error "file-stat: (path)"));
+  register "file-delete" (fun args ->
+    match args with
+    | [String path] ->
+      (try
+        if Sys.is_directory path then Unix.rmdir path
+        else Unix.unlink path
+      with
+      | Unix.Unix_error (Unix.ENOENT, _, _) -> ()  (* tolerate missing *)
+      | Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-delete: " ^ Unix.error_message e)));
+      Nil
+    | _ -> raise (Eval_error "file-delete: (path)"));
+  register "file-mkdir" (fun args ->
+    match args with
+    | [String path] ->
+      let rec mk p =
+        if p = "" || p = "." || p = "/" then ()
+        else if Sys.file_exists p then ()
+        else begin
+          mk (Filename.dirname p);
+          (try Unix.mkdir p 0o755
+           with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
+        end
+      in
+      (try mk path
+       with Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-mkdir: " ^ Unix.error_message e)));
+      Nil
+    | _ -> raise (Eval_error "file-mkdir: (path)"));
+  register "file-copy" (fun args ->
+    match args with
+    | [String src; String dst] ->
+      (try
+        let ic = open_in_bin src in
+        let oc = open_out_bin dst in
+        let buf = Bytes.create 8192 in
+        let rec loop () =
+          let n = input ic buf 0 (Bytes.length buf) in
+          if n > 0 then (output oc buf 0 n; loop ())
+        in
+        loop ();
+        close_in ic;
+        close_out oc;
+        Nil
+      with
+      | Sys_error msg -> raise (Eval_error ("file-copy: " ^ msg)))
+    | _ -> raise (Eval_error "file-copy: (src dst)"));
+  register "file-rename" (fun args ->
+    match args with
+    | [String src; String dst] ->
+      (try Sys.rename src dst with Sys_error msg -> raise (Eval_error ("file-rename: " ^ msg)));
+      Nil
+    | _ -> raise (Eval_error "file-rename: (src dst)"));
+
+  (* === Channels (random-access + blocking control) === *)
+  let channel_table : (string, Unix.file_descr * string * bool ref * bool ref) Hashtbl.t = Hashtbl.create 16 in
+  let channel_next_id = ref 0 in
+  let parse_open_mode mode =
+    match mode with
+    | "r"  -> [Unix.O_RDONLY]
+    | "w"  -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC]
+    | "a"  -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND]
+    | "r+" -> [Unix.O_RDWR]
+    | "w+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC]
+    | "a+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_APPEND]
+    | _ -> raise (Eval_error ("channel-open: invalid mode " ^ mode))
+  in
+  let chan_get name =
+    match Hashtbl.find_opt channel_table name with
+    | Some c -> c
+    | None -> raise (Eval_error ("channel: no such channel " ^ name))
+  in
+  register "channel-open" (fun args ->
+    match args with
+    | [String path; String mode] ->
+      (try
+        let fd = Unix.openfile path (parse_open_mode mode) 0o644 in
+        let id = !channel_next_id in
+        incr channel_next_id;
+        let name = Printf.sprintf "file%d" id in
+        Hashtbl.replace channel_table name (fd, mode, ref false, ref true);
+        String name
+      with Unix.Unix_error (e, _, _) -> raise (Eval_error ("channel-open: " ^ Unix.error_message e)))
+    | _ -> raise (Eval_error "channel-open: (path mode)"));
+
+  register "channel-close" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, _, _) = chan_get name in
+      (try Unix.close fd with _ -> ());
+      Hashtbl.remove channel_table name;
+      Nil
+    | _ -> raise (Eval_error "channel-close: (channel)"));
+
+  register "channel-read" (fun args ->
+    let (name, max_n) = match args with
+      | [String n] -> (n, -1)
+      | [String n; Integer m] -> (n, m)
+      | [String n; Number m] -> (n, int_of_float m)
+      | _ -> raise (Eval_error "channel-read: (channel ?n?)")
+    in
+    let (fd, _, eof, _) = chan_get name in
+    let chunk = 8192 in
+    let buf = Bytes.create chunk in
+    let buffer = Buffer.create chunk in
+    let total = ref 0 in
+    let stop = ref false in
+    while not !stop do
+      let want = if max_n < 0 then chunk else min chunk (max_n - !total) in
+      if want <= 0 then stop := true
+      else begin
+        try
+          let r = Unix.read fd buf 0 want in
+          if r = 0 then begin eof := true; stop := true end
+          else begin
+            Buffer.add_subbytes buffer buf 0 r;
+            total := !total + r
+          end
+        with
+        | Unix.Unix_error (Unix.EAGAIN, _, _)
+        | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
+      end
+    done;
+    String (Buffer.contents buffer));
+
+  register "channel-read-line" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, eof, _) = chan_get name in
+      let buf = Buffer.create 80 in
+      let one = Bytes.create 1 in
+      let got_data = ref false in
+      let stop = ref false in
+      while not !stop do
+        try
+          let r = Unix.read fd one 0 1 in
+          if r = 0 then begin eof := true; stop := true end
+          else begin
+            got_data := true;
+            let c = Bytes.get one 0 in
+            if c = '\n' then stop := true
+            else Buffer.add_char buf c
+          end
+        with
+        | Unix.Unix_error (Unix.EAGAIN, _, _)
+        | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
+      done;
+      if !got_data then String (Buffer.contents buf) else Nil
+    | _ -> raise (Eval_error "channel-read-line: (channel)"));
+
+  register "channel-write" (fun args ->
+    match args with
+    | [String name; String s] ->
+      let (fd, _, _, _) = chan_get name in
+      let b = Bytes.of_string s in
+      let n = Bytes.length b in
+      let written = ref 0 in
+      while !written < n do
+        (try
+          let w = Unix.write fd b !written (n - !written) in
+          written := !written + w
+        with
+        | Unix.Unix_error (Unix.EAGAIN, _, _)
+        | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) ->
+          (* short write — let caller retry *)
+          written := n)
+      done;
+      Nil
+    | _ -> raise (Eval_error "channel-write: (channel string)"));
+
+  register "channel-flush" (fun args ->
+    match args with
+    | [String name] -> let _ = chan_get name in Nil  (* no userspace buffer *)
+    | _ -> raise (Eval_error "channel-flush: (channel)"));
+
+  register "channel-seek" (fun args ->
+    let (name, offset, whence) = match args with
+      | [String n; Integer o] -> (n, o, "start")
+      | [String n; Number o] -> (n, int_of_float o, "start")
+      | [String n; Integer o; String w] -> (n, o, w)
+      | [String n; Number o; String w] -> (n, int_of_float o, w)
+      | _ -> raise (Eval_error "channel-seek: (channel offset ?whence?)")
+    in
+    let (fd, _, eof, _) = chan_get name in
+    let cmd = match whence with
+      | "start" -> Unix.SEEK_SET
+      | "current" -> Unix.SEEK_CUR
+      | "end" -> Unix.SEEK_END
+      | _ -> raise (Eval_error ("channel-seek: invalid whence " ^ whence))
+    in
+    let _ = Unix.lseek fd offset cmd in
+    eof := false;
+    Nil);
+
+  register "channel-tell" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, _, _) = chan_get name in
+      Integer (Unix.lseek fd 0 Unix.SEEK_CUR)
+    | _ -> raise (Eval_error "channel-tell: (channel)"));
+
+  register "channel-eof?" (fun args ->
+    match args with
+    | [String name] ->
+      let (_, _, eof, _) = chan_get name in
+      Bool !eof
+    | _ -> raise (Eval_error "channel-eof?: (channel)"));
+
+  register "channel-blocking?" (fun args ->
+    match args with
+    | [String name] ->
+      let (_, _, _, blocking) = chan_get name in
+      Bool !blocking
+    | _ -> raise (Eval_error "channel-blocking?: (channel)"));
+
+  register "channel-set-blocking!" (fun args ->
+    match args with
+    | [String name; Bool b] ->
+      let (fd, _, _, blocking) = chan_get name in
+      blocking := b;
+      (try
+        if b then Unix.clear_nonblock fd
+        else Unix.set_nonblock fd
+      with _ -> ());
+      Nil
+    | _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
+
+  (* === Exec === run an external process; capture stdout *)
+  register "exec-process" (fun args ->
+    let items = match args with
+      | [List xs] | [ListRef { contents = xs }] -> xs
+      | _ -> raise (Eval_error "exec-process: (cmd-list)")
+    in
+    let argv = Array.of_list (List.map (function
+      | String s -> s
+      | v -> Sx_types.inspect v
+    ) items) in
+    if Array.length argv = 0 then raise (Eval_error "exec: empty command");
+    let (out_r, out_w) = Unix.pipe () in
+    let (err_r, err_w) = Unix.pipe () in
+    let pid =
+      try Unix.create_process argv.(0) argv Unix.stdin out_w err_w
+      with Unix.Unix_error (e, _, _) ->
+        Unix.close out_r; Unix.close out_w;
+        Unix.close err_r; Unix.close err_w;
+        raise (Eval_error ("exec: " ^ Unix.error_message e))
+    in
+    Unix.close out_w;
+    Unix.close err_w;
+    let buf = Buffer.create 256 in
+    let errbuf = Buffer.create 64 in
+    let chunk = Bytes.create 4096 in
+    let read_all fd target =
+      try
+        let stop = ref false in
+        while not !stop do
+          let n = Unix.read fd chunk 0 (Bytes.length chunk) in
+          if n = 0 then stop := true
+          else Buffer.add_subbytes target chunk 0 n
+        done
+      with _ -> ()
+    in
+    read_all out_r buf;
+    read_all err_r errbuf;
+    Unix.close out_r;
+    Unix.close err_r;
+    let (_, status) = Unix.waitpid [] pid in
+    let exit_code = match status with
+      | Unix.WEXITED n -> n
+      | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 1
+    in
+    let s = Buffer.contents buf in
+    let trimmed =
+      if String.length s > 0 && s.[String.length s - 1] = '\n'
+      then String.sub s 0 (String.length s - 1) else s
+    in
+    if exit_code <> 0 then
+      raise (Eval_error ("exec: child exited " ^ string_of_int exit_code
+                         ^ (if Buffer.length errbuf > 0
+                            then ": " ^ Buffer.contents errbuf
+                            else "")))
+    else String trimmed);
+
+  (* exec-pipeline: takes a list of words like Tcl `exec` would receive.
+     Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
+     `2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
+     stage; raises Eval_error if the last stage exits non-zero. *)
+  register "exec-pipeline" (fun args ->
+    let items = match args with
+      | [List xs] | [ListRef { contents = xs }] -> xs
+      | _ -> raise (Eval_error "exec-pipeline: (word-list)")
+    in
+    let words = List.map (function
+      | String s -> s
+      | v -> Sx_types.inspect v
+    ) items in
+    if words = [] then raise (Eval_error "exec: empty command");
+    let split_stages ws =
+      let rec loop acc cur = function
+        | [] -> List.rev (List.rev cur :: acc)
+        | "|" :: rest -> loop (List.rev cur :: acc) [] rest
+        | w :: rest -> loop acc (w :: cur) rest
+      in
+      loop [] [] ws
+    in
+    let extract_redirs ws =
+      let in_path = ref None in
+      let out_path = ref None in
+      let out_append = ref false in
+      let err_path = ref None in
+      let merge_err = ref false in
+      let cleaned = ref [] in
+      let rec loop = function
+        | [] -> ()
+        | "<" :: p :: rest -> in_path := Some p; loop rest
+        | ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
+        | ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
+        | "2>@1" :: rest -> merge_err := true; loop rest
+        | "2>" :: p :: rest -> err_path := Some p; loop rest
+        | w :: rest -> cleaned := w :: !cleaned; loop rest
+      in
+      loop ws;
+      (List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
+    in
+    let stages = List.map extract_redirs (split_stages words) in
+    if stages = [] then raise (Eval_error "exec: no stages");
+    let n = List.length stages in
+    let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
+    let (final_r, final_w) = Unix.pipe () in
+    let (errstash_r, errstash_w) = Unix.pipe () in
+    let pids = ref [] in
+    let close_safe fd = try Unix.close fd with _ -> () in
+    let open_in_redir = function
+      | None -> Unix.stdin
+      | Some path ->
+        (try Unix.openfile path [Unix.O_RDONLY] 0o644
+         with Unix.Unix_error (e, _, _) ->
+           raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
+    in
+    let open_out_redir path append =
+      let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
+      try Unix.openfile path flags 0o644
+      with Unix.Unix_error (e, _, _) ->
+        raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
+    in
+    let stages_arr = Array.of_list stages in
+    (try
+      Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
+        if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
+        let argv = Array.of_list cleaned in
+        let stdin_fd =
+          if i = 0 then open_in_redir ip
+          else fst pipes.(i - 1)
+        in
+        let stdout_fd =
+          if i = n - 1 then
+            (match op with
+             | None -> final_w
+             | Some path -> open_out_redir path app)
+          else snd pipes.(i)
+        in
+        let stderr_fd =
+          if merge then stdout_fd
+          else (match ep with
+                | None -> if i = n - 1 then errstash_w else Unix.stderr
+                | Some path -> open_out_redir path false)
+        in
+        let pid =
+          try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
+          with Unix.Unix_error (e, _, _) ->
+            raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
+        in
+        pids := pid :: !pids;
+        if i > 0 then close_safe (fst pipes.(i - 1));
+        if i < n - 1 then close_safe (snd pipes.(i));
+        if i = 0 && ip <> None then close_safe stdin_fd;
+        if i = n - 1 && op <> None then close_safe stdout_fd;
+        if not merge && ep <> None then close_safe stderr_fd
+      ) stages_arr
+    with e ->
+      close_safe final_r; close_safe final_w;
+      close_safe errstash_r; close_safe errstash_w;
+      Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
+      raise e);
+    close_safe final_w;
+    close_safe errstash_w;
+    let buf = Buffer.create 256 in
+    let errbuf = Buffer.create 64 in
+    let chunk = Bytes.create 4096 in
+    let read_all fd target =
+      try
+        let stop = ref false in
+        while not !stop do
+          let r = Unix.read fd chunk 0 (Bytes.length chunk) in
+          if r = 0 then stop := true
+          else Buffer.add_subbytes target chunk 0 r
+        done
+      with _ -> ()
+    in
+    read_all final_r buf;
+    read_all errstash_r errbuf;
+    close_safe final_r;
+    close_safe errstash_r;
+    let exit_codes = List.rev_map (fun pid ->
+      let (_, st) = Unix.waitpid [] pid in
+      match st with
+      | Unix.WEXITED c -> c
+      | _ -> 1
+    ) !pids in
+    let final_code = match List.rev exit_codes with
+      | [] -> 0
+      | last :: _ -> last
+    in
+    let s = Buffer.contents buf in
+    let trimmed =
+      if String.length s > 0 && s.[String.length s - 1] = '\n'
+      then String.sub s 0 (String.length s - 1) else s
+    in
+    if final_code <> 0 then
+      raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
+                         ^ (if Buffer.length errbuf > 0
+                            then ": " ^ Buffer.contents errbuf
+                            else "")))
+    else String trimmed);
+
+  (* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
+  let resolve_inet_addr host =
+    if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
+    else if host = "localhost" then Unix.inet_addr_loopback
+    else
+      try Unix.inet_addr_of_string host
+      with _ ->
+        try
+          let entry = Unix.gethostbyname host in
+          if Array.length entry.Unix.h_addr_list = 0 then
+            raise (Eval_error ("socket: cannot resolve " ^ host))
+          else entry.Unix.h_addr_list.(0)
+        with Not_found -> raise (Eval_error ("socket: cannot resolve " ^ host))
+  in
+  let port_of v = match v with
+    | Integer n -> n
+    | Number n -> int_of_float n
+    | _ -> raise (Eval_error "socket: port must be a number")
+  in
+  let alloc_chan_name () =
+    let id = !channel_next_id in
+    incr channel_next_id;
+    Printf.sprintf "sock%d" id
+  in
+
+  register "socket-connect" (fun args ->
+    match args with
+    | [String host; port_v] ->
+      let port = port_of port_v in
+      let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
+      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      (try Unix.connect sock addr
+       with Unix.Unix_error (e, _, _) ->
+         (try Unix.close sock with _ -> ());
+         raise (Eval_error ("socket-connect: " ^ Unix.error_message e)));
+      let name = alloc_chan_name () in
+      Hashtbl.replace channel_table name (sock, "rw", ref false, ref true);
+      String name
+    | _ -> raise (Eval_error "socket-connect: (host port)"));
+
+  (* Non-blocking connect: returns channel immediately. Connection completes
+     when the channel becomes writable; query channel-async-error? after to
+     confirm success or get the error. *)
+  register "socket-connect-async" (fun args ->
+    match args with
+    | [String host; port_v] ->
+      let port = port_of port_v in
+      let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
+      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      Unix.set_nonblock sock;
+      (try Unix.connect sock addr
+       with
+       | Unix.Unix_error (Unix.EINPROGRESS, _, _)
+       | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> ()
+       | Unix.Unix_error (e, _, _) ->
+         (try Unix.close sock with _ -> ());
+         raise (Eval_error ("socket-connect-async: " ^ Unix.error_message e)));
+      let name = alloc_chan_name () in
+      Hashtbl.replace channel_table name (sock, "rw", ref false, ref false);
+      String name
+    | _ -> raise (Eval_error "socket-connect-async: (host port)"));
+
+  (* After a non-blocking connect completes (channel writable), check whether
+     the connect succeeded. Returns "" on success, error message on failure. *)
+  register "channel-async-error" (fun args ->
+    match args with
+    | [String name] ->
+      let (fd, _, _, _) = chan_get name in
+      (try
+        let err = Unix.getsockopt_error fd in
+        match err with
+        | None -> String ""
+        | Some e -> String (Unix.error_message e)
+      with
+      | Unix.Unix_error (e, _, _) -> String (Unix.error_message e))
+    | _ -> raise (Eval_error "channel-async-error: (channel)"));
+
+  register "socket-server" (fun args ->
+    let (host, port) = match args with
+      | [port_v] -> ("", port_of port_v)
+      | [String h; port_v] -> (h, port_of port_v)
+      | _ -> raise (Eval_error "socket-server: (port) or (host port)")
+    in
+    let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
+    let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+    Unix.setsockopt sock Unix.SO_REUSEADDR true;
+    (try Unix.bind sock addr
+     with Unix.Unix_error (e, _, _) ->
+       (try Unix.close sock with _ -> ());
+       raise (Eval_error ("socket-server: bind: " ^ Unix.error_message e)));
+    Unix.listen sock 8;
+    let name = alloc_chan_name () in
+    Hashtbl.replace channel_table name (sock, "server", ref false, ref true);
+    String name);
+
+  register "socket-accept" (fun args ->
+    match args with
+    | [String name] ->
+      let (sock, _, _, _) = chan_get name in
+      let (client_sock, client_addr) =
+        try Unix.accept sock
+        with Unix.Unix_error (e, _, _) ->
+          raise (Eval_error ("socket-accept: " ^ Unix.error_message e))
+      in
+      let (host_str, port) = match client_addr with
+        | Unix.ADDR_INET (addr, p) -> (Unix.string_of_inet_addr addr, p)
+        | Unix.ADDR_UNIX path -> (path, 0)
+      in
+      let client_name = alloc_chan_name () in
+      Hashtbl.replace channel_table client_name (client_sock, "rw", ref false, ref true);
+      let d = Hashtbl.create 3 in
+      Hashtbl.replace d "channel" (String client_name);
+      Hashtbl.replace d "host" (String host_str);
+      Hashtbl.replace d "port" (Integer port);
+      Dict d
+    | _ -> raise (Eval_error "socket-accept: (server-channel)"));
+
+  (* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]}
+     timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *)
+  register "io-select-channels" (fun args ->
+    let to_ms v = match v with
+      | Integer n -> n
+      | Number n -> int_of_float n
+      | _ -> raise (Eval_error "io-select-channels: timeout must be a number")
+    in
+    let to_list v = match v with
+      | List xs | ListRef { contents = xs } -> xs
+      | Nil -> []
+      | _ -> raise (Eval_error "io-select-channels: expected list")
+    in
+    let chan_name_of v = match v with
+      | String s -> s
+      | _ -> raise (Eval_error "io-select-channels: channel must be a string")
+    in
+    let (read_list, write_list, timeout_ms) = match args with
+      | [r; w; t] -> (to_list r, to_list w, to_ms t)
+      | _ -> raise (Eval_error "io-select-channels: (read-list write-list timeout-ms)")
+    in
+    let read_pairs = List.map (fun v ->
+      let name = chan_name_of v in
+      let (fd, _, _, _) = chan_get name in (name, fd)) read_list in
+    let write_pairs = List.map (fun v ->
+      let name = chan_name_of v in
+      let (fd, _, _, _) = chan_get name in (name, fd)) write_list in
+    let read_fds = List.map snd read_pairs in
+    let write_fds = List.map snd write_pairs in
+    let timeout = if timeout_ms < 0 then -1.0 else float_of_int timeout_ms /. 1000.0 in
+    let (ready_r, ready_w, _) =
+      try Unix.select read_fds write_fds [] timeout
+      with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
+    in
+    let names_of pairs ready =
+      List.filter_map (fun (n, fd) ->
+        if List.exists (fun rfd -> rfd = fd) ready then Some (String n) else None
+      ) pairs
+    in
+    let d = Hashtbl.create 2 in
+    Hashtbl.replace d "readable" (List (names_of read_pairs ready_r));
+    Hashtbl.replace d "writable" (List (names_of write_pairs ready_w));
+    Dict d);
+
   (* === Clock === *)
   register "clock-seconds" (fun args ->
     match args with
@@ -3135,11 +3946,8 @@ let () =
     | [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0))
     | _ -> raise (Eval_error "clock-milliseconds: no args"));
 
-  register "clock-format" (fun args ->
-    match args with
-    | [Integer t] | [Integer t; String _] ->
-      let fmt = (match args with [_; String f] -> f | _ -> "%a %b %e %H:%M:%S %Z %Y") in
-      let tm = Unix.gmtime (float_of_int t) in
+  let format_tm tm tz_label =
+    fun fmt ->
       let buf = Buffer.create 32 in
       let n = String.length fmt in
       let i = ref 0 in
@@ -3147,14 +3955,19 @@ let () =
         if fmt.[!i] = '%' && !i + 1 < n then begin
           (match fmt.[!i + 1] with
            | 'Y' -> Buffer.add_string buf (Printf.sprintf "%04d" (1900 + tm.Unix.tm_year))
+           | 'y' -> Buffer.add_string buf (Printf.sprintf "%02d" ((1900 + tm.Unix.tm_year) mod 100))
            | 'm' -> Buffer.add_string buf (Printf.sprintf "%02d" (tm.Unix.tm_mon + 1))
            | 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday)
            | 'e' -> Buffer.add_string buf (Printf.sprintf "%2d"  tm.Unix.tm_mday)
            | 'H' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_hour)
+           | 'I' -> let h = tm.Unix.tm_hour mod 12 in
+                    Buffer.add_string buf (Printf.sprintf "%02d" (if h = 0 then 12 else h))
+           | 'p' -> Buffer.add_string buf (if tm.Unix.tm_hour < 12 then "AM" else "PM")
            | 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min)
            | 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec)
            | 'j' -> Buffer.add_string buf (Printf.sprintf "%03d" (tm.Unix.tm_yday + 1))
-           | 'Z' -> Buffer.add_string buf "UTC"
+           | 'w' -> Buffer.add_string buf (string_of_int tm.Unix.tm_wday)
+           | 'Z' -> Buffer.add_string buf tz_label
            | 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in
                     Buffer.add_string buf days.(tm.Unix.tm_wday)
            | 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in
@@ -3163,6 +3976,7 @@ let () =
                     Buffer.add_string buf mons.(tm.Unix.tm_mon)
            | 'B' -> let mons = [|"January";"February";"March";"April";"May";"June";"July";"August";"September";"October";"November";"December"|] in
                     Buffer.add_string buf mons.(tm.Unix.tm_mon)
+           | '%' -> Buffer.add_char buf '%'
            | c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
           i := !i + 2
         end else begin
@@ -3170,8 +3984,100 @@ let () =
           incr i
         end
       done;
-      String (Buffer.contents buf)
-    | _ -> raise (Eval_error "clock-format: (seconds [format])"));
+      Buffer.contents buf
+  in
+  register "clock-format" (fun args ->
+    let (t, fmt, tz) = match args with
+      | [Integer t] -> (t, "%a %b %e %H:%M:%S %Z %Y", "utc")
+      | [Integer t; String f] -> (t, f, "utc")
+      | [Integer t; String f; String z] -> (t, f, z)
+      | _ -> raise (Eval_error "clock-format: (seconds [format [tz]])")
+    in
+    let tm =
+      if tz = "local" then Unix.localtime (float_of_int t)
+      else Unix.gmtime (float_of_int t)
+    in
+    let label = if tz = "local" then "" else "UTC" in
+    String (format_tm tm label fmt));
+
+  (* clock-scan: parse a date string with format, return seconds.
+     Supports the same format specifiers as clock-format (fixed-width ones).
+     tz: "utc" (default) or "local". *)
+  let timegm (tm : Unix.tm) =
+    let is_leap y = y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) in
+    let days_in_month = [|31;28;31;30;31;30;31;31;30;31;30;31|] in
+    let year = tm.Unix.tm_year + 1900 in
+    let mon = tm.Unix.tm_mon in
+    let mday = tm.Unix.tm_mday in
+    let total_days = ref 0 in
+    if year >= 1970 then begin
+      for y = 1970 to year - 1 do
+        total_days := !total_days + (if is_leap y then 366 else 365)
+      done
+    end else begin
+      for y = year to 1969 do
+        total_days := !total_days - (if is_leap y then 366 else 365)
+      done
+    end;
+    for m = 0 to mon - 1 do
+      total_days := !total_days + days_in_month.(m);
+      if m = 1 && is_leap year then incr total_days
+    done;
+    total_days := !total_days + mday - 1;
+    !total_days * 86400
+    + tm.Unix.tm_hour * 3600
+    + tm.Unix.tm_min * 60
+    + tm.Unix.tm_sec
+  in
+  register "clock-scan" (fun args ->
+    let (str, fmt, tz) = match args with
+      | [String s; String f] -> (s, f, "utc")
+      | [String s; String f; String z] -> (s, f, z)
+      | _ -> raise (Eval_error "clock-scan: (str fmt [tz])")
+    in
+    let n = String.length fmt and sn = String.length str in
+    let tm = ref { Unix.tm_year = 70; tm_mon = 0; tm_mday = 1;
+                   tm_hour = 0; tm_min = 0; tm_sec = 0;
+                   tm_wday = 0; tm_yday = 0; tm_isdst = false } in
+    let i = ref 0 and j = ref 0 in
+    let read_n_digits k =
+      let s = ref "" in
+      let cnt = ref 0 in
+      while !cnt < k && !j < sn && str.[!j] >= '0' && str.[!j] <= '9' do
+        s := !s ^ String.make 1 str.[!j];
+        incr j; incr cnt
+      done;
+      if !s = "" then 0 else int_of_string !s
+    in
+    let skip_ws () =
+      while !j < sn && (str.[!j] = ' ' || str.[!j] = '\t') do incr j done
+    in
+    while !i < n do
+      if fmt.[!i] = '%' && !i + 1 < n then begin
+        (match fmt.[!i + 1] with
+         | 'Y' -> tm := { !tm with tm_year = read_n_digits 4 - 1900 }
+         | 'y' -> let y = read_n_digits 2 in
+                  tm := { !tm with tm_year = (if y < 70 then 100 + y else y) }
+         | 'm' -> tm := { !tm with tm_mon = read_n_digits 2 - 1 }
+         | 'd' | 'e' -> skip_ws (); tm := { !tm with tm_mday = read_n_digits 2 }
+         | 'H' | 'I' -> tm := { !tm with tm_hour = read_n_digits 2 }
+         | 'M' -> tm := { !tm with tm_min = read_n_digits 2 }
+         | 'S' -> tm := { !tm with tm_sec = read_n_digits 2 }
+         | '%' -> if !j < sn && str.[!j] = '%' then incr j
+         | _ -> ()  (* unsupported specifier — skip *)
+        );
+        i := !i + 2
+      end else begin
+        if fmt.[!i] = ' ' then skip_ws ()
+        else if !j < sn && str.[!j] = fmt.[!i] then incr j;
+        incr i
+      end
+    done;
+    let secs =
+      if tz = "local" then int_of_float (fst (Unix.mktime !tm))
+      else timegm !tm
+    in
+    Integer secs);
 
   (* === Env-as-value (Phase 4) === *)
 
@@ -3203,4 +4109,25 @@ let () =
         | k :: v :: rest -> ignore (env_bind child (value_to_string k) v); add_bindings rest
         | [_] -> raise (Eval_error "env-extend: odd number of key-val pairs") in
       add_bindings pairs;
-      Env child)
+      Env child);
+
+  (* JIT cache control & observability — backed by refs in sx_types.ml to
+     avoid creating a sx_primitives → sx_vm dependency cycle. sx_vm reads
+     these refs to decide when to JIT. *)
+  register "jit-stats" (fun _args ->
+    let d = Hashtbl.create 8 in
+    Hashtbl.replace d "threshold"        (Number (float_of_int !Sx_types.jit_threshold));
+    Hashtbl.replace d "compiled"         (Number (float_of_int !Sx_types.jit_compiled_count));
+    Hashtbl.replace d "compile-failed"   (Number (float_of_int !Sx_types.jit_skipped_count));
+    Hashtbl.replace d "below-threshold"  (Number (float_of_int !Sx_types.jit_threshold_skipped_count));
+    Dict d);
+  register "jit-set-threshold!" (fun args ->
+    match args with
+    | [Number n] -> Sx_types.jit_threshold := int_of_float n; Nil
+    | [Integer n] -> Sx_types.jit_threshold := n; Nil
+    | _ -> raise (Eval_error "jit-set-threshold!: (n) where n is integer"));
+  register "jit-reset-counters!" (fun _args ->
+    Sx_types.jit_compiled_count := 0;
+    Sx_types.jit_skipped_count := 0;
+    Sx_types.jit_threshold_skipped_count := 0;
+    Nil)

hosts/ocaml/lib/sx_types.ml

@@ -138,6 +138,7 @@ and lambda = {
   l_closure : env;
   mutable l_name : string option;
   mutable l_compiled : vm_closure option;  (** Lazy JIT cache *)
+  mutable l_call_count : int;              (** Tiered-compilation counter — JIT after threshold calls *)
 }
 
 and component = {
@@ -449,7 +450,20 @@ let make_lambda params body closure =
     | List items -> List.map value_to_string items
     | _ -> value_to_string_list params
   in
-  Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
+  Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0 }
+
+(** {1 JIT cache control}
+
+    Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
+    times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
+    so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].
+
+    These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
+    them without creating a sx_primitives → sx_vm dependency cycle. *)
+let jit_threshold = ref 4
+let jit_compiled_count = ref 0
+let jit_skipped_count = ref 0
+let jit_threshold_skipped_count = ref 0
 
 let make_component name params has_children body closure affinity =
   let n = value_to_string name in

hosts/ocaml/lib/sx_vm.ml

@@ -57,6 +57,9 @@ let () = Sx_types._convert_vm_suspension := (fun exn ->
 let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
   ref (fun _ _ -> None)
 
+(* JIT threshold and counters live in Sx_types so primitives can read them
+   without creating a sx_primitives → sx_vm dependency cycle. *)
+
 (** Sentinel closure indicating JIT compilation was attempted and failed.
     Prevents retrying compilation on every call. *)
 let jit_failed_sentinel = {
@@ -364,13 +367,21 @@ and vm_call vm f args =
      | None ->
        if l.l_name <> None
        then begin
-         l.l_compiled <- Some jit_failed_sentinel;
-         match !jit_compile_ref l vm.globals with
-         | Some cl ->
-           l.l_compiled <- Some cl;
-           push_closure_frame vm cl args
-         | None ->
+         l.l_call_count <- l.l_call_count + 1;
+         if l.l_call_count >= !Sx_types.jit_threshold then begin
+           l.l_compiled <- Some jit_failed_sentinel;
+           match !jit_compile_ref l vm.globals with
+           | Some cl ->
+             incr Sx_types.jit_compiled_count;
+             l.l_compiled <- Some cl;
+             push_closure_frame vm cl args
+           | None ->
+             incr Sx_types.jit_skipped_count;
+             push vm (cek_call_or_suspend vm f (List args))
+         end else begin
+           incr Sx_types.jit_threshold_skipped_count;
            push vm (cek_call_or_suspend vm f (List args))
+         end
        end
        else
          push vm (cek_call_or_suspend vm f (List args)))
@@ -642,7 +653,9 @@ and run vm =
           (* Read upvalue descriptors from bytecode *)
           let uv_count = match code_val with
             | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-                | Some (Number n) -> int_of_float n | _ -> 0)
+                | Some (Integer n) -> n
+                | Some (Number n) -> int_of_float n
+                | _ -> 0)
             | _ -> 0
           in
           let upvalues = Array.init uv_count (fun _ ->
@@ -1307,7 +1320,9 @@ let trace_run src globals =
             let code_val2 = frame.closure.vm_code.vc_constants.(idx) in
             let uv_count = match code_val2 with
               | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-                  | Some (Number n) -> int_of_float n | _ -> 0)
+                  | Some (Integer n) -> n
+                  | Some (Number n) -> int_of_float n
+                  | _ -> 0)
               | _ -> 0 in
             let upvalues = Array.init uv_count (fun _ ->
               let is_local = read_u8 frame in
@@ -1428,7 +1443,9 @@ let disassemble (code : vm_code) =
         if op = 51 && idx < Array.length consts then begin
           let uv_count = match consts.(idx) with
             | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-                | Some (Number n) -> int_of_float n | _ -> 0)
+                | Some (Integer n) -> n
+                | Some (Number n) -> int_of_float n
+                | _ -> 0)
             | _ -> 0 in
           ip := !ip + uv_count * 2
         end

hosts/ocaml/lib/sx_vm_ref.ml

@@ -270,7 +270,9 @@ let vm_create_closure vm_val frame_val code_val =
   let f = unwrap_frame frame_val in
   let uv_count = match code_val with
     | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-        | Some (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

hosts/ocaml/sx_vm_ref.ml

@@ -265,7 +265,9 @@ let vm_create_closure vm_val frame_val code_val =
   let f = unwrap_frame frame_val in
   let uv_count = match code_val with
     | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
-        | Some (Number n) -> int_of_float n | _ -> 0)
+        | Some (Integer n) -> n
+        | Some (Number n) -> int_of_float n
+        | _ -> 0)
     | _ -> 0
   in
   let upvalues = Array.init uv_count (fun _ ->

lib/apl/conformance.sh

@@ -0,0 +1,116 @@
+#!/usr/bin/env bash
+# lib/apl/conformance.sh — run APL test suites, emit scoreboard.json + scoreboard.md.
+
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then
+  echo "ERROR: sx_server.exe not found." >&2
+  exit 1
+fi
+
+SUITES=(structural operators dfn tradfn valence programs system idioms eval-ops pipeline)
+
+OUT_JSON="lib/apl/scoreboard.json"
+OUT_MD="lib/apl/scoreboard.md"
+
+run_suite() {
+  local suite=$1
+  local file="lib/apl/tests/${suite}.sx"
+  local TMP
+  TMP=$(mktemp)
+  cat > "$TMP" << EPOCHS
+(epoch 1)
+(load "spec/stdlib.sx")
+(load "lib/r7rs.sx")
+(load "lib/apl/runtime.sx")
+(load "lib/apl/tokenizer.sx")
+(load "lib/apl/parser.sx")
+(load "lib/apl/transpile.sx")
+(epoch 2)
+(eval "(define apl-test-pass 0)")
+(eval "(define apl-test-fail 0)")
+(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (set! apl-test-fail (+ apl-test-fail 1)))))")
+(epoch 3)
+(load "${file}")
+(epoch 4)
+(eval "(list apl-test-pass apl-test-fail)")
+EPOCHS
+
+  local OUTPUT
+  OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null)
+  rm -f "$TMP"
+
+  local LINE
+  LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
+  if [ -z "$LINE" ]; then
+    LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
+            | sed -E 's/^\(ok 4 //; s/\)$//')
+  fi
+
+  local P F
+  P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
+  F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
+  P=${P:-0}
+  F=${F:-0}
+  echo "${P} ${F}"
+}
+
+declare -A SUITE_PASS
+declare -A SUITE_FAIL
+TOTAL_PASS=0
+TOTAL_FAIL=0
+
+echo "Running APL conformance suite..." >&2
+for s in "${SUITES[@]}"; do
+  read -r p f < <(run_suite "$s")
+  SUITE_PASS[$s]=$p
+  SUITE_FAIL[$s]=$f
+  TOTAL_PASS=$((TOTAL_PASS + p))
+  TOTAL_FAIL=$((TOTAL_FAIL + f))
+  printf "  %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
+done
+
+# scoreboard.json
+{
+  printf '{\n'
+  printf '  "suites": {\n'
+  first=1
+  for s in "${SUITES[@]}"; do
+    if [ $first -eq 0 ]; then printf ',\n'; fi
+    printf '    "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
+    first=0
+  done
+  printf '\n  },\n'
+  printf '  "total_pass": %d,\n' "$TOTAL_PASS"
+  printf '  "total_fail": %d,\n' "$TOTAL_FAIL"
+  printf '  "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
+  printf '}\n'
+} > "$OUT_JSON"
+
+# scoreboard.md
+{
+  printf '# APL Conformance Scoreboard\n\n'
+  printf '_Generated by `lib/apl/conformance.sh`_\n\n'
+  printf '| Suite | Pass | Fail | Total |\n'
+  printf '|-------|-----:|-----:|------:|\n'
+  for s in "${SUITES[@]}"; do
+    p=${SUITE_PASS[$s]}
+    f=${SUITE_FAIL[$s]}
+    printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
+  done
+  printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
+  printf '\n'
+  printf '## Notes\n\n'
+  printf '%s\n' '- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.'
+  printf '%s\n' '- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.'
+} > "$OUT_MD"
+
+echo "Wrote $OUT_JSON and $OUT_MD" >&2
+echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
+
+[ "$TOTAL_FAIL" -eq 0 ]

lib/apl/parser.sx

@@ -0,0 +1,701 @@
+; APL Parser — right-to-left expression parser
+;
+; Takes a token list (output of apl-tokenize) and produces an AST.
+; APL evaluates right-to-left with no precedence among functions.
+; Operators bind to the function immediately to their left in the source.
+;
+; AST node types:
+;   (:num n)                     number literal
+;   (:str s)                     string literal
+;   (:vec n1 n2 ...)             strand (juxtaposed literals)
+;   (:name "x")                  name reference / alpha / omega
+;   (:assign "x" expr)           assignment  x←expr
+;   (:monad fn arg)              monadic function call
+;   (:dyad fn left right)        dyadic function call
+;   (:derived-fn op fn)          derived function: f/ f¨ f⍨
+;   (:derived-fn2 "." f g)       inner product: f.g
+;   (:outer "∘." fn)             outer product: ∘.f
+;   (:fn-glyph "⍳")             function reference
+;   (:fn-name "foo")             named-function reference (dfn variable)
+;   (:dfn stmt...)               {⍺+⍵} anonymous function
+;   (:guard cond expr)           cond:expr guard inside dfn
+;   (:program stmt...)           multi-statement sequence
+
+; ============================================================
+; Glyph classification sets
+; ============================================================
+
+(define
+  apl-parse-op-glyphs
+  (list "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@"))
+
+(define
+  apl-parse-fn-glyphs
+  (list
+    "+"
+    "-"
+    "×"
+    "÷"
+    "*"
+    "⍟"
+    "⌈"
+    "⌊"
+    "|"
+    "!"
+    "?"
+    "○"
+    "~"
+    "<"
+    "≤"
+    "="
+    "≥"
+    ">"
+    "≠"
+    "≢"
+    "≡"
+    "∊"
+    "∧"
+    "∨"
+    "⍱"
+    "⍲"
+    ","
+    "⍪"
+    "⍴"
+    "⌽"
+    "⊖"
+    "⍉"
+    "↑"
+    "↓"
+    "⊂"
+    "⊃"
+    "⊆"
+    "∪"
+    "∩"
+    "⍳"
+    "⍸"
+    "⌷"
+    "⍋"
+    "⍒"
+    "⊥"
+    "⊤"
+    "⊣"
+    "⊢"
+    "⍎"
+    "⍕"))
+
+(define apl-quad-fn-names (list "⎕FMT" "⎕←"))
+
+(define apl-known-fn-names (list))
+
+; ============================================================
+; Token accessors
+; ============================================================
+
+(define
+  apl-collect-fn-bindings
+  (fn
+    (stmt-groups)
+    (set! apl-known-fn-names (list))
+    (for-each
+      (fn
+        (toks)
+        (when
+          (and
+            (>= (len toks) 3)
+            (= (tok-type (nth toks 0)) :name)
+            (= (tok-type (nth toks 1)) :assign)
+            (= (tok-type (nth toks 2)) :lbrace))
+          (set!
+            apl-known-fn-names
+            (cons (tok-val (nth toks 0)) apl-known-fn-names))))
+      stmt-groups)))
+
+(define
+  apl-parse-op-glyph?
+  (fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs)))
+
+(define
+  apl-parse-fn-glyph?
+  (fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs)))
+
+(define tok-type (fn (tok) (get tok :type)))
+
+; ============================================================
+; Collect trailing operators starting at index i
+; Returns {:ops (op ...) :end new-i}
+; ============================================================
+
+(define tok-val (fn (tok) (get tok :value)))
+
+(define
+  is-op-tok?
+  (fn
+    (tok)
+    (and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok)))))
+
+; ============================================================
+; Build a derived-fn node by chaining operators left-to-right
+; (+/¨  →  (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+"))))
+; ============================================================
+
+(define
+  is-fn-tok?
+  (fn
+    (tok)
+    (or
+      (and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok)))
+      (and
+        (= (tok-type tok) :name)
+        (or
+          (some (fn (q) (= q (tok-val tok))) apl-quad-fn-names)
+          (some (fn (q) (= q (tok-val tok))) apl-known-fn-names))))))
+
+; ============================================================
+; Find matching close bracket/paren/brace
+; Returns the index of the matching close token
+; ============================================================
+
+(define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list))))
+
+(define
+  collect-ops-loop
+  (fn
+    (tokens i acc)
+    (if
+      (>= i (len tokens))
+      {:end i :ops acc}
+      (let
+        ((tok (nth tokens i)))
+        (if
+          (is-op-tok? tok)
+          (collect-ops-loop tokens (+ i 1) (append acc (tok-val tok)))
+          {:end i :ops acc})))))
+
+; ============================================================
+; Segment collection: scan tokens left-to-right, building
+; a list of {:kind "val"/"fn" :node ast} segments.
+; Operators following function glyphs are merged into
+; derived-fn nodes during this pass.
+; ============================================================
+
+(define
+  build-derived-fn
+  (fn
+    (fn-node ops)
+    (if
+      (= (len ops) 0)
+      fn-node
+      (build-derived-fn (list :derived-fn (first ops) fn-node) (rest ops)))))
+
+(define
+  find-matching-close
+  (fn
+    (tokens start open-type close-type)
+    (find-matching-close-loop tokens start open-type close-type 1)))
+
+; ============================================================
+; Build tree from segment list
+;
+; The segments are in left-to-right order.
+; APL evaluates right-to-left, so the LEFTMOST function is
+; the outermost (last-evaluated) node.
+;
+; Patterns:
+;   [val]              → val node
+;   [fn val ...]       → (:monad fn (build-tree rest))
+;   [val fn val ...]   → (:dyad fn val (build-tree rest))
+;   [val val ...]      → (:vec val1 val2 ...) — strand
+; ============================================================
+
+; Find the index of the first function segment (returns -1 if none)
+(define
+  find-matching-close-loop
+  (fn
+    (tokens i open-type close-type depth)
+    (if
+      (>= i (len tokens))
+      (len tokens)
+      (let
+        ((tt (tok-type (nth tokens i))))
+        (cond
+          ((= tt open-type)
+            (find-matching-close-loop
+              tokens
+              (+ i 1)
+              open-type
+              close-type
+              (+ depth 1)))
+          ((= tt close-type)
+            (if
+              (= depth 1)
+              i
+              (find-matching-close-loop
+                tokens
+                (+ i 1)
+                open-type
+                close-type
+                (- depth 1))))
+          (true
+            (find-matching-close-loop
+              tokens
+              (+ i 1)
+              open-type
+              close-type
+              depth)))))))
+
+(define
+  collect-segments
+  (fn (tokens) (collect-segments-loop tokens 0 (list))))
+
+; Build an array node from 0..n value segments
+; If n=1 → return that segment's node
+; If n>1 → return (:vec node1 node2 ...)
+(define
+  collect-segments-loop
+  (fn
+    (tokens i acc)
+    (if
+      (>= i (len tokens))
+      acc
+      (let
+        ((tok (nth tokens i)) (n (len tokens)))
+        (let
+          ((tt (tok-type tok)) (tv (tok-val tok)))
+          (cond
+            ((or (= tt :diamond) (= tt :newline) (= tt :semi))
+              (collect-segments-loop tokens (+ i 1) acc))
+            ((= tt :num)
+              (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :num tv)})))
+            ((= tt :str)
+              (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)})))
+            ((= tt :name)
+              (cond
+                ((and (< (+ i 1) (len tokens)) (= (tok-type (nth tokens (+ i 1))) :assign))
+                  (let
+                    ((rhs-tokens (slice tokens (+ i 2) (len tokens))))
+                    (let
+                      ((rhs-expr (parse-apl-expr rhs-tokens)))
+                      (collect-segments-loop
+                        tokens
+                        (len tokens)
+                        (append acc {:kind "val" :node (list :assign-expr tv rhs-expr)})))))
+                ((some (fn (q) (= q tv)) apl-quad-fn-names)
+                  (let
+                    ((op-result (collect-ops tokens (+ i 1))))
+                    (let
+                      ((ops (get op-result :ops))
+                        (ni (get op-result :end)))
+                      (let
+                        ((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
+                        (collect-segments-loop
+                          tokens
+                          ni
+                          (append acc {:kind "fn" :node fn-node}))))))
+                ((some (fn (q) (= q tv)) apl-known-fn-names)
+                  (let
+                    ((op-result (collect-ops tokens (+ i 1))))
+                    (let
+                      ((ops (get op-result :ops))
+                        (ni (get op-result :end)))
+                      (let
+                        ((fn-node (build-derived-fn (list :fn-name tv) ops)))
+                        (collect-segments-loop
+                          tokens
+                          ni
+                          (append acc {:kind "fn" :node fn-node}))))))
+                (else
+                  (let
+                    ((br (maybe-bracket (list :name tv) tokens (+ i 1))))
+                    (collect-segments-loop
+                      tokens
+                      (nth br 1)
+                      (append acc {:kind "val" :node (nth br 0)}))))))
+            ((= tt :lparen)
+              (let
+                ((end (find-matching-close tokens (+ i 1) :lparen :rparen)))
+                (let
+                  ((inner-tokens (slice tokens (+ i 1) end))
+                    (after (+ end 1)))
+                  (let
+                    ((inner-segs (collect-segments inner-tokens)))
+                    (if
+                      (and
+                        (>= (len inner-segs) 2)
+                        (every? (fn (s) (= (get s :kind) "fn")) inner-segs))
+                      (let
+                        ((train-node (cons :train (map (fn (s) (get s :node)) inner-segs))))
+                        (collect-segments-loop
+                          tokens
+                          after
+                          (append acc {:kind "fn" :node train-node})))
+                      (let
+                        ((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after)))
+                        (collect-segments-loop
+                          tokens
+                          (nth br 1)
+                          (append acc {:kind "val" :node (nth br 0)}))))))))
+            ((= tt :lbrace)
+              (let
+                ((end (find-matching-close tokens (+ i 1) :lbrace :rbrace)))
+                (let
+                  ((inner-tokens (slice tokens (+ i 1) end))
+                    (after (+ end 1)))
+                  (collect-segments-loop tokens after (append acc {:kind "fn" :node (parse-dfn inner-tokens)})))))
+            ((= tt :glyph)
+              (cond
+                ((or (= tv "⍺") (= tv "⍵"))
+                  (if
+                    (and
+                      (< (+ i 1) (len tokens))
+                      (= (tok-type (nth tokens (+ i 1))) :assign))
+                    (let
+                      ((rhs-tokens (slice tokens (+ i 2) (len tokens))))
+                      (let
+                        ((rhs-expr (parse-apl-expr rhs-tokens)))
+                        (collect-segments-loop
+                          tokens
+                          (len tokens)
+                          (append acc {:kind "val" :node (list :assign-expr tv rhs-expr)}))))
+                    (collect-segments-loop
+                      tokens
+                      (+ i 1)
+                      (append acc {:kind "val" :node (list :name tv)}))))
+                ((= tv "∇")
+                  (collect-segments-loop
+                    tokens
+                    (+ i 1)
+                    (append acc {:kind "fn" :node (list :fn-glyph "∇")})))
+                ((and (= tv "∘") (< (+ i 1) n) (= (tok-val (nth tokens (+ i 1))) "."))
+                  (if
+                    (and (< (+ i 2) n) (is-fn-tok? (nth tokens (+ i 2))))
+                    (let
+                      ((fn-tv (tok-val (nth tokens (+ i 2)))))
+                      (let
+                        ((op-result (collect-ops tokens (+ i 3))))
+                        (let
+                          ((ops (get op-result :ops))
+                            (ni (get op-result :end)))
+                          (let
+                            ((fn-node (build-derived-fn (list :fn-glyph fn-tv) ops)))
+                            (collect-segments-loop
+                              tokens
+                              ni
+                              (append acc {:kind "fn" :node (list :outer "∘." fn-node)}))))))
+                    (collect-segments-loop tokens (+ i 1) acc)))
+                ((apl-parse-fn-glyph? tv)
+                  (let
+                    ((op-result (collect-ops tokens (+ i 1))))
+                    (let
+                      ((ops (get op-result :ops))
+                        (ni (get op-result :end)))
+                      (if
+                        (and
+                          (= (len ops) 1)
+                          (= (first ops) ".")
+                          (< ni n)
+                          (is-fn-tok? (nth tokens ni)))
+                        (let
+                          ((g-tv (tok-val (nth tokens ni))))
+                          (let
+                            ((op-result2 (collect-ops tokens (+ ni 1))))
+                            (let
+                              ((ops2 (get op-result2 :ops))
+                                (ni2 (get op-result2 :end)))
+                              (let
+                                ((g-node (build-derived-fn (list :fn-glyph g-tv) ops2)))
+                                (collect-segments-loop
+                                  tokens
+                                  ni2
+                                  (append acc {:kind "fn" :node (list :derived-fn2 "." (list :fn-glyph tv) g-node)}))))))
+                        (let
+                          ((fn-node (build-derived-fn (list :fn-glyph tv) ops)))
+                          (collect-segments-loop
+                            tokens
+                            ni
+                            (append acc {:kind "fn" :node fn-node})))))))
+                ((apl-parse-op-glyph? tv)
+                  (if
+                    (or (= tv "/") (= tv "⌿") (= tv "\\") (= tv "⍀"))
+                    (collect-segments-loop
+                      tokens
+                      (+ i 1)
+                      (append acc {:kind "fn" :node (list :fn-glyph tv)}))
+                    (collect-segments-loop tokens (+ i 1) acc)))
+                (true (collect-segments-loop tokens (+ i 1) acc))))
+            (true (collect-segments-loop tokens (+ i 1) acc))))))))
+
+(define find-first-fn (fn (segs) (find-first-fn-loop segs 0)))
+
+
+; ============================================================
+; Split token list on statement separators (diamond / newline)
+; Only splits at depth 0 (ignores separators inside { } or ( ) )
+; ============================================================
+
+(define
+  find-first-fn-loop
+  (fn
+    (segs i)
+    (if
+      (>= i (len segs))
+      -1
+      (if
+        (= (get (nth segs i) :kind) "fn")
+        i
+        (find-first-fn-loop segs (+ i 1))))))
+
+(define
+  segs-to-array
+  (fn
+    (segs)
+    (if
+      (= (len segs) 1)
+      (get (first segs) :node)
+      (cons :vec (map (fn (s) (get s :node)) segs)))))
+
+; ============================================================
+; Parse a dfn body (tokens between { and })
+; Handles guard expressions: cond : expr
+; ============================================================
+
+(define
+  build-tree
+  (fn
+    (segs)
+    (cond
+      ((= (len segs) 0) nil)
+      ((= (len segs) 1) (get (first segs) :node))
+      ((every? (fn (s) (= (get s :kind) "val")) segs)
+        (segs-to-array segs))
+      (true
+        (let
+          ((fn-idx (find-first-fn segs)))
+          (cond
+            ((= fn-idx -1) (segs-to-array segs))
+            ((= fn-idx 0)
+              (list
+                :monad (get (first segs) :node)
+                (build-tree (rest segs))))
+            (true
+              (let
+                ((left-segs (slice segs 0 fn-idx))
+                  (fn-seg (nth segs fn-idx))
+                  (right-segs (slice segs (+ fn-idx 1))))
+                (list
+                  :dyad (get fn-seg :node)
+                  (segs-to-array left-segs)
+                  (build-tree right-segs))))))))))
+
+(define
+  split-statements
+  (fn (tokens) (split-statements-loop tokens (list) (list) 0)))
+
+(define
+  split-statements-loop
+  (fn
+    (tokens current-stmt acc depth)
+    (if
+      (= (len tokens) 0)
+      (if (> (len current-stmt) 0) (append acc (list current-stmt)) acc)
+      (let
+        ((tok (first tokens))
+          (rest-toks (rest tokens))
+          (tt (tok-type (first tokens))))
+        (cond
+          ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
+            (split-statements-loop
+              rest-toks
+              (append current-stmt tok)
+              acc
+              (+ depth 1)))
+          ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
+            (split-statements-loop
+              rest-toks
+              (append current-stmt tok)
+              acc
+              (- depth 1)))
+          ((and (> depth 0) (or (= tt :diamond) (= tt :newline)))
+            (split-statements-loop
+              rest-toks
+              (append current-stmt tok)
+              acc
+              depth))
+          ((and (= depth 0) (or (= tt :diamond) (= tt :newline)))
+            (if
+              (> (len current-stmt) 0)
+              (split-statements-loop
+                rest-toks
+                (list)
+                (append acc (list current-stmt))
+                depth)
+              (split-statements-loop rest-toks (list) acc depth)))
+          (true
+            (split-statements-loop
+              rest-toks
+              (append current-stmt tok)
+              acc
+              depth)))))))
+
+(define
+  parse-dfn
+  (fn
+    (tokens)
+    (let
+      ((stmt-groups (split-statements tokens)))
+      (let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts)))))
+
+; ============================================================
+; Parse a single statement (assignment or expression)
+; ============================================================
+
+(define
+  parse-dfn-stmt
+  (fn
+    (tokens)
+    (let
+      ((colon-idx (find-top-level-colon tokens 0)))
+      (if
+        (>= colon-idx 0)
+        (let
+          ((cond-tokens (slice tokens 0 colon-idx))
+            (body-tokens (slice tokens (+ colon-idx 1))))
+          (list
+            :guard (parse-apl-expr cond-tokens)
+            (parse-apl-expr body-tokens)))
+        (parse-stmt tokens)))))
+
+; ============================================================
+; Parse an expression from a flat token list
+; ============================================================
+
+(define
+  find-top-level-colon
+  (fn (tokens i) (find-top-level-colon-loop tokens i 0)))
+
+; ============================================================
+; Main entry point
+; parse-apl: string → AST
+; ============================================================
+
+(define
+  find-top-level-colon-loop
+  (fn
+    (tokens i depth)
+    (if
+      (>= i (len tokens))
+      -1
+      (let
+        ((tok (nth tokens i)) (tt (tok-type (nth tokens i))))
+        (cond
+          ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
+            (find-top-level-colon-loop tokens (+ i 1) (+ depth 1)))
+          ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
+            (find-top-level-colon-loop tokens (+ i 1) (- depth 1)))
+          ((and (= tt :colon) (= depth 0)) i)
+          (true (find-top-level-colon-loop tokens (+ i 1) depth)))))))
+
+(define
+  parse-stmt
+  (fn
+    (tokens)
+    (if
+      (and
+        (>= (len tokens) 2)
+        (= (tok-type (nth tokens 0)) :name)
+        (= (tok-type (nth tokens 1)) :assign))
+      (list
+        :assign (tok-val (nth tokens 0))
+        (parse-apl-expr (slice tokens 2)))
+      (parse-apl-expr tokens))))
+
+(define
+  parse-apl-expr
+  (fn
+    (tokens)
+    (let
+      ((segs (collect-segments tokens)))
+      (if (= (len segs) 0) nil (build-tree segs)))))
+
+(define
+  parse-apl
+  (fn
+    (src)
+    (let
+      ((tokens (apl-tokenize src)))
+      (let
+        ((stmt-groups (split-statements tokens)))
+        (begin
+          (apl-collect-fn-bindings stmt-groups)
+          (if
+            (= (len stmt-groups) 0)
+            nil
+            (if
+              (= (len stmt-groups) 1)
+              (parse-stmt (first stmt-groups))
+              (cons :program (map parse-stmt stmt-groups)))))))))
+
+(define
+  split-bracket-loop
+  (fn
+    (tokens current acc depth)
+    (if
+      (= (len tokens) 0)
+      (append acc (list current))
+      (let
+        ((tok (first tokens)) (more (rest tokens)))
+        (let
+          ((tt (tok-type tok)))
+          (cond
+            ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket))
+              (split-bracket-loop
+                more
+                (append current (list tok))
+                acc
+                (+ depth 1)))
+            ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket))
+              (split-bracket-loop
+                more
+                (append current (list tok))
+                acc
+                (- depth 1)))
+            ((and (= tt :semi) (= depth 0))
+              (split-bracket-loop
+                more
+                (list)
+                (append acc (list current))
+                depth))
+            (else
+              (split-bracket-loop more (append current (list tok)) acc depth))))))))
+
+(define
+  split-bracket-content
+  (fn (tokens) (split-bracket-loop tokens (list) (list) 0)))
+
+(define
+  maybe-bracket
+  (fn
+    (val-node tokens after)
+    (if
+      (and
+        (< after (len tokens))
+        (= (tok-type (nth tokens after)) :lbracket))
+      (let
+        ((end (find-matching-close tokens (+ after 1) :lbracket :rbracket)))
+        (let
+          ((inner-tokens (slice tokens (+ after 1) end))
+            (next-after (+ end 1)))
+          (let
+            ((sections (split-bracket-content inner-tokens)))
+            (if
+              (= (len sections) 1)
+              (let
+                ((idx-expr (parse-apl-expr inner-tokens)))
+                (let
+                  ((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node)))
+                  (maybe-bracket indexed tokens next-after)))
+              (let
+                ((axis-exprs (map (fn (toks) (if (= (len toks) 0) :all (parse-apl-expr toks))) sections)))
+                (let
+                  ((indexed (cons :bracket (cons val-node axis-exprs))))
+                  (maybe-bracket indexed tokens next-after)))))))
+      (list val-node after))))

lib/apl/scoreboard.json

@@ -0,0 +1,17 @@
+{
+  "suites": {
+    "structural": {"pass": 94, "fail": 0},
+    "operators": {"pass": 117, "fail": 0},
+    "dfn": {"pass": 24, "fail": 0},
+    "tradfn": {"pass": 25, "fail": 0},
+    "valence": {"pass": 14, "fail": 0},
+    "programs": {"pass": 45, "fail": 0},
+    "system": {"pass": 13, "fail": 0},
+    "idioms": {"pass": 64, "fail": 0},
+    "eval-ops": {"pass": 14, "fail": 0},
+    "pipeline": {"pass": 40, "fail": 0}
+  },
+  "total_pass": 450,
+  "total_fail": 0,
+  "total": 450
+}

lib/apl/scoreboard.md

@@ -0,0 +1,22 @@
+# APL Conformance Scoreboard
+
+_Generated by `lib/apl/conformance.sh`_
+
+| Suite | Pass | Fail | Total |
+|-------|-----:|-----:|------:|
+| structural | 94 | 0 | 94 |
+| operators | 117 | 0 | 117 |
+| dfn | 24 | 0 | 24 |
+| tradfn | 25 | 0 | 25 |
+| valence | 14 | 0 | 14 |
+| programs | 45 | 0 | 45 |
+| system | 13 | 0 | 13 |
+| idioms | 64 | 0 | 64 |
+| eval-ops | 14 | 0 | 14 |
+| pipeline | 40 | 0 | 40 |
+| **Total** | **450** | **0** | **450** |
+
+## Notes
+
+- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.
+- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.

lib/apl/test.sh

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

lib/apl/tests/dfn.sx

@@ -0,0 +1,227 @@
+; Tests for apl-eval-ast and apl-call-dfn (manual AST construction).
+
+(define rv (fn (arr) (get arr :ravel)))
+(define sh (fn (arr) (get arr :shape)))
+
+(define mknum (fn (n) (list :num n)))
+(define mkname (fn (s) (list :name s)))
+(define mkfg (fn (g) (list :fn-glyph g)))
+(define mkmon (fn (g a) (list :monad (mkfg g) a)))
+(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
+(define mkdfn1 (fn (body) (list :dfn body)))
+(define mkprog (fn (stmts) (cons :program stmts)))
+
+(define mkasg (fn (mkname expr) (list :assign mkname expr)))
+
+(define mkgrd (fn (c e) (list :guard c e)))
+
+(define mkdfn (fn (stmts) (cons :dfn stmts)))
+
+(apl-test
+  "eval :num literal"
+  (rv (apl-eval-ast (mknum 42) {}))
+  (list 42))
+
+(apl-test
+  "eval :num literal shape"
+  (sh (apl-eval-ast (mknum 42) {}))
+  (list))
+
+(apl-test
+  "eval :dyad +"
+  (rv (apl-eval-ast (mkdyd "+" (mknum 2) (mknum 3)) {}))
+  (list 5))
+
+(apl-test
+  "eval :dyad ×"
+  (rv (apl-eval-ast (mkdyd "×" (mknum 6) (mknum 7)) {}))
+  (list 42))
+
+(apl-test
+  "eval :monad - (negate)"
+  (rv (apl-eval-ast (mkmon "-" (mknum 7)) {}))
+  (list -7))
+
+(apl-test
+  "eval :monad ⌊ (floor)"
+  (rv (apl-eval-ast (mkmon "⌊" (mknum 3)) {}))
+  (list 3))
+
+(apl-test
+  "eval :name ⍵ from env"
+  (rv (apl-eval-ast (mkname "⍵") {:omega (apl-scalar 99) :alpha nil}))
+  (list 99))
+
+(apl-test
+  "eval :name ⍺ from env"
+  (rv (apl-eval-ast (mkname "⍺") {:omega nil :alpha (apl-scalar 7)}))
+  (list 7))
+
+(apl-test
+  "dfn {⍵+1} called monadic"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn1 (mkdyd "+" (mkname "⍵") (mknum 1)))
+      (apl-scalar 5)))
+  (list 6))
+
+(apl-test
+  "dfn {⍺+⍵} called dyadic"
+  (rv
+    (apl-call-dfn
+      (mkdfn1 (mkdyd "+" (mkname "⍺") (mkname "⍵")))
+      (apl-scalar 4)
+      (apl-scalar 9)))
+  (list 13))
+
+(apl-test
+  "dfn {⍺×⍵} dyadic on vectors"
+  (rv
+    (apl-call-dfn
+      (mkdfn1 (mkdyd "×" (mkname "⍺") (mkname "⍵")))
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 10 20 30))))
+  (list 10 40 90))
+
+(apl-test
+  "dfn {-⍵} monadic negate"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn1 (mkmon "-" (mkname "⍵")))
+      (make-array (list 3) (list 1 2 3))))
+  (list -1 -2 -3))
+
+(apl-test
+  "dfn {⍺-⍵} dyadic subtract scalar"
+  (rv
+    (apl-call-dfn
+      (mkdfn1 (mkdyd "-" (mkname "⍺") (mkname "⍵")))
+      (apl-scalar 10)
+      (apl-scalar 3)))
+  (list 7))
+
+(apl-test
+  "dfn {⌈⍺,⍵} not used (just verify : missing) — ceiling of right"
+  (rv
+    (apl-call-dfn-m (mkdfn1 (mkmon "⌈" (mkname "⍵"))) (apl-scalar 5)))
+  (list 5))
+
+(apl-test
+  "dfn nested dyad"
+  (rv
+    (apl-call-dfn
+      (mkdfn1
+        (mkdyd "+" (mkname "⍺") (mkdyd "×" (mkname "⍵") (mknum 2))))
+      (apl-scalar 1)
+      (apl-scalar 3)))
+  (list 7))
+
+(apl-test
+  "dfn local assign x←⍵+1; ⍺×x"
+  (rv
+    (apl-call-dfn
+      (mkdfn
+        (list
+          (mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 1)))
+          (mkdyd "×" (mkname "⍺") (mkname "x"))))
+      (apl-scalar 3)
+      (apl-scalar 4)))
+  (list 15))
+
+(apl-test
+  "dfn guard: 0=⍵:99; ⍵×2 (true branch)"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn
+        (list
+          (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99))
+          (mkdyd "×" (mkname "⍵") (mknum 2))))
+      (apl-scalar 0)))
+  (list 99))
+
+(apl-test
+  "dfn guard: 0=⍵:99; ⍵×2 (false branch)"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn
+        (list
+          (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99))
+          (mkdyd "×" (mkname "⍵") (mknum 2))))
+      (apl-scalar 5)))
+  (list 10))
+
+(apl-test
+  "dfn default ⍺←10 used (monadic call)"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn
+        (list
+          (mkasg "⍺" (mknum 10))
+          (mkdyd "+" (mkname "⍺") (mkname "⍵"))))
+      (apl-scalar 5)))
+  (list 15))
+
+(apl-test
+  "dfn default ⍺←10 ignored when ⍺ given (dyadic call)"
+  (rv
+    (apl-call-dfn
+      (mkdfn
+        (list
+          (mkasg "⍺" (mknum 10))
+          (mkdyd "+" (mkname "⍺") (mkname "⍵"))))
+      (apl-scalar 100)
+      (apl-scalar 5)))
+  (list 105))
+
+(apl-test
+  "dfn ∇ recursion: factorial via guard"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn
+        (list
+          (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1))
+          (mkdyd
+            "×"
+            (mkname "⍵")
+            (mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1))))))
+      (apl-scalar 5)))
+  (list 120))
+
+(apl-test
+  "dfn ∇ recursion: 3 → 6 (factorial)"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn
+        (list
+          (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1))
+          (mkdyd
+            "×"
+            (mkname "⍵")
+            (mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1))))))
+      (apl-scalar 3)))
+  (list 6))
+
+(apl-test
+  "dfn local: x←⍵+10; y←x×2; y"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn
+        (list
+          (mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 10)))
+          (mkasg "y" (mkdyd "×" (mkname "x") (mknum 2)))
+          (mkname "y")))
+      (apl-scalar 5)))
+  (list 30))
+
+(apl-test
+  "dfn first guard wins: many guards"
+  (rv
+    (apl-call-dfn-m
+      (mkdfn
+        (list
+          (mkgrd (mkdyd "=" (mknum 1) (mkname "⍵")) (mknum 100))
+          (mkgrd (mkdyd "=" (mknum 2) (mkname "⍵")) (mknum 200))
+          (mkgrd (mkdyd "=" (mknum 3) (mkname "⍵")) (mknum 300))
+          (mknum 0)))
+      (apl-scalar 2)))
+  (list 200))

lib/apl/tests/eval-ops.sx

@@ -0,0 +1,147 @@
+; Tests for operator handling in apl-eval-ast (Phase 7).
+; Manual AST construction; verifies :derived-fn / :outer / :derived-fn2
+; route through apl-resolve-monadic / apl-resolve-dyadic correctly.
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+(define mknum (fn (n) (list :num n)))
+(define mkfg (fn (g) (list :fn-glyph g)))
+(define mkmon (fn (g a) (list :monad g a)))
+(define mkdyd (fn (g l r) (list :dyad g l r)))
+(define mkder (fn (op f) (list :derived-fn op f)))
+(define mkdr2 (fn (op f g) (list :derived-fn2 op f g)))
+(define mkout (fn (f) (list :outer "∘." f)))
+
+; helper: literal vector AST via :vec (from list of values)
+(define mkvec (fn (xs) (cons :vec (map (fn (n) (mknum n)) xs))))
+
+; ---------- monadic operators ----------
+
+(apl-test
+  "eval-ast +/ ⍳5 → 15"
+  (mkrv
+    (apl-eval-ast
+      (mkmon (mkder "/" (mkfg "+")) (mkmon (mkfg "⍳") (mknum 5)))
+      {}))
+  (list 15))
+
+(apl-test
+  "eval-ast ×/ ⍳5 → 120"
+  (mkrv
+    (apl-eval-ast
+      (mkmon (mkder "/" (mkfg "×")) (mkmon (mkfg "⍳") (mknum 5)))
+      {}))
+  (list 120))
+
+(apl-test
+  "eval-ast ⌈/ — max reduce"
+  (mkrv
+    (apl-eval-ast
+      (mkmon (mkder "/" (mkfg "⌈")) (mkvec (list 3 1 4 1 5 9 2 6)))
+      {}))
+  (list 9))
+
+(apl-test
+  "eval-ast +\\ scan"
+  (mkrv
+    (apl-eval-ast
+      (mkmon (mkder "\\" (mkfg "+")) (mkvec (list 1 2 3 4 5)))
+      {}))
+  (list 1 3 6 10 15))
+
+(apl-test
+  "eval-ast +⌿ first-axis reduce on vector"
+  (mkrv
+    (apl-eval-ast
+      (mkmon (mkder "⌿" (mkfg "+")) (mkvec (list 1 2 3 4 5)))
+      {}))
+  (list 15))
+
+(apl-test
+  "eval-ast -¨ each-negate"
+  (mkrv
+    (apl-eval-ast
+      (mkmon (mkder "¨" (mkfg "-")) (mkvec (list 1 2 3 4)))
+      {}))
+  (list -1 -2 -3 -4))
+
+(apl-test
+  "eval-ast +⍨ commute (double via x+x)"
+  (mkrv
+    (apl-eval-ast (mkmon (mkder "⍨" (mkfg "+")) (mknum 7)) {}))
+  (list 14))
+
+; ---------- dyadic operators ----------
+
+(apl-test
+  "eval-ast outer ∘.× — multiplication table"
+  (mkrv
+    (apl-eval-ast
+      (mkdyd
+        (mkout (mkfg "×"))
+        (mkvec (list 1 2 3))
+        (mkvec (list 1 2 3)))
+      {}))
+  (list 1 2 3 2 4 6 3 6 9))
+
+(apl-test
+  "eval-ast outer ∘.× shape (3 3)"
+  (mksh
+    (apl-eval-ast
+      (mkdyd
+        (mkout (mkfg "×"))
+        (mkvec (list 1 2 3))
+        (mkvec (list 1 2 3)))
+      {}))
+  (list 3 3))
+
+(apl-test
+  "eval-ast inner +.× — dot product"
+  (mkrv
+    (apl-eval-ast
+      (mkdyd
+        (mkdr2 "." (mkfg "+") (mkfg "×"))
+        (mkvec (list 1 2 3))
+        (mkvec (list 4 5 6)))
+      {}))
+  (list 32))
+
+(apl-test
+  "eval-ast inner ∧.= equal vectors"
+  (mkrv
+    (apl-eval-ast
+      (mkdyd
+        (mkdr2 "." (mkfg "∧") (mkfg "="))
+        (mkvec (list 1 2 3))
+        (mkvec (list 1 2 3)))
+      {}))
+  (list 1))
+
+(apl-test
+  "eval-ast each-dyadic +¨"
+  (mkrv
+    (apl-eval-ast
+      (mkdyd
+        (mkder "¨" (mkfg "+"))
+        (mkvec (list 1 2 3))
+        (mkvec (list 10 20 30)))
+      {}))
+  (list 11 22 33))
+
+(apl-test
+  "eval-ast commute -⍨ (subtract swapped)"
+  (mkrv
+    (apl-eval-ast
+      (mkdyd (mkder "⍨" (mkfg "-")) (mknum 5) (mknum 3))
+      {}))
+  (list -2))
+
+; ---------- nested operators ----------
+
+(apl-test
+  "eval-ast +/¨ — sum of each"
+  (mkrv
+    (apl-eval-ast
+      (mkmon (mkder "/" (mkfg "+")) (mkvec (list 10 20 30)))
+      {}))
+  (list 60))

lib/apl/tests/idioms.sx

@@ -0,0 +1,359 @@
+; APL idiom corpus — classic Roger Hui / Phil Last idioms expressed
+; through our runtime primitives.  Each test names the APL one-liner
+; and verifies the equivalent runtime call.
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+
+; ---------- reductions ----------
+
+(apl-test
+  "+/⍵ — sum"
+  (mkrv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5))))
+  (list 15))
+
+(apl-test
+  "(+/⍵)÷⍴⍵ — mean"
+  (mkrv
+    (apl-div
+      (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5)))
+      (apl-scalar 5)))
+  (list 3))
+
+(apl-test
+  "⌈/⍵ — max"
+  (mkrv (apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9))))
+  (list 9))
+
+(apl-test
+  "⌊/⍵ — min"
+  (mkrv (apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9))))
+  (list 1))
+
+(apl-test
+  "(⌈/⍵)-⌊/⍵ — range"
+  (mkrv
+    (apl-sub
+      (apl-reduce apl-max (make-array (list 6) (list 3 1 4 1 5 9)))
+      (apl-reduce apl-min (make-array (list 6) (list 3 1 4 1 5 9)))))
+  (list 8))
+
+(apl-test
+  "×/⍵ — product"
+  (mkrv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4))))
+  (list 24))
+
+(apl-test
+  "+\\⍵ — running sum"
+  (mkrv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 3 6 10 15))
+
+; ---------- sort / order ----------
+
+(apl-test
+  "⍵[⍋⍵] — sort ascending"
+  (mkrv (apl-quicksort (make-array (list 5) (list 3 1 4 1 5))))
+  (list 1 1 3 4 5))
+
+(apl-test
+  "⌽⍵ — reverse"
+  (mkrv (apl-reverse (make-array (list 5) (list 1 2 3 4 5))))
+  (list 5 4 3 2 1))
+
+(apl-test
+  "⊃⌽⍵ — last element"
+  (mkrv
+    (apl-disclose (apl-reverse (make-array (list 4) (list 10 20 30 40)))))
+  (list 40))
+
+(apl-test
+  "1↑⍵ — first element"
+  (mkrv
+    (apl-take (apl-scalar 1) (make-array (list 4) (list 10 20 30 40))))
+  (list 10))
+
+(apl-test
+  "1↓⍵ — drop first"
+  (mkrv
+    (apl-drop (apl-scalar 1) (make-array (list 4) (list 10 20 30 40))))
+  (list 20 30 40))
+
+(apl-test
+  "¯1↓⍵ — drop last"
+  (mkrv
+    (apl-drop (apl-scalar -1) (make-array (list 4) (list 10 20 30 40))))
+  (list 10 20 30))
+
+; ---------- counts / membership ----------
+
+(apl-test
+  "≢⍵ — tally"
+  (mkrv (apl-tally (make-array (list 7) (list 9 8 7 6 5 4 3))))
+  (list 7))
+
+(apl-test
+  "+/⍵=v — count occurrences of v"
+  (mkrv
+    (apl-reduce
+      apl-add
+      (apl-eq (make-array (list 7) (list 1 2 3 2 1 3 2)) (apl-scalar 2))))
+  (list 3))
+
+(apl-test
+  "0=N|M — divisibility test"
+  (mkrv (apl-eq (apl-scalar 0) (apl-mod (apl-scalar 3) (apl-scalar 12))))
+  (list 1))
+
+; ---------- shape constructors ----------
+
+(apl-test
+  "N⍴1 — vector of N ones"
+  (mkrv (apl-reshape (apl-scalar 5) (apl-scalar 1)))
+  (list 1 1 1 1 1))
+
+(apl-test
+  "(N N)⍴0 — N×N zero matrix"
+  (mkrv (apl-reshape (make-array (list 2) (list 3 3)) (apl-scalar 0)))
+  (list 0 0 0 0 0 0 0 0 0))
+
+(apl-test
+  "⍳∘.=⍳ — N×N identity matrix"
+  (mkrv
+    (apl-outer apl-eq (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3))))
+  (list 1 0 0 0 1 0 0 0 1))
+
+(apl-test
+  "⍳∘.×⍳ — multiplication table"
+  (mkrv
+    (apl-outer apl-mul (apl-iota (apl-scalar 3)) (apl-iota (apl-scalar 3))))
+  (list 1 2 3 2 4 6 3 6 9))
+
+; ---------- numerical idioms ----------
+
+(apl-test
+  "+\\⍳N — triangular numbers"
+  (mkrv (apl-scan apl-add (apl-iota (apl-scalar 5))))
+  (list 1 3 6 10 15))
+
+(apl-test
+  "+/⍳N=N×(N+1)÷2 — sum of 1..N"
+  (mkrv (apl-reduce apl-add (apl-iota (apl-scalar 10))))
+  (list 55))
+
+(apl-test
+  "×/⍳N — factorial via iota"
+  (mkrv (apl-reduce apl-mul (apl-iota (apl-scalar 5))))
+  (list 120))
+
+(apl-test
+  "2|⍵ — parity (1=odd)"
+  (mkrv (apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 0 1 0 1))
+
+(apl-test
+  "+/2|⍵ — count odd"
+  (mkrv
+    (apl-reduce
+      apl-add
+      (apl-mod (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5)))))
+  (list 3))
+
+; ---------- boolean idioms ----------
+
+(apl-test
+  "∧/⍵ — all-true"
+  (mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 1 1))))
+  (list 1))
+
+(apl-test
+  "∧/⍵ — all-true with zero is false"
+  (mkrv (apl-reduce apl-and (make-array (list 4) (list 1 1 0 1))))
+  (list 0))
+
+(apl-test
+  "∨/⍵ — any-true"
+  (mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 1 0))))
+  (list 1))
+
+(apl-test
+  "∨/⍵ — any-true all zero is false"
+  (mkrv (apl-reduce apl-or (make-array (list 4) (list 0 0 0 0))))
+  (list 0))
+
+; ---------- selection / scaling ----------
+
+(apl-test
+  "⍵×⍵ — square each"
+  (mkrv
+    (apl-mul
+      (make-array (list 4) (list 1 2 3 4))
+      (make-array (list 4) (list 1 2 3 4))))
+  (list 1 4 9 16))
+
+(apl-test
+  "+/⍵×⍵ — sum of squares"
+  (mkrv
+    (apl-reduce
+      apl-add
+      (apl-mul
+        (make-array (list 4) (list 1 2 3 4))
+        (make-array (list 4) (list 1 2 3 4)))))
+  (list 30))
+
+(apl-test
+  "⍵-(+/⍵)÷⍴⍵ — mean-centered"
+  (mkrv
+    (apl-sub
+      (make-array (list 5) (list 2 4 6 8 10))
+      (apl-div
+        (apl-reduce apl-add (make-array (list 5) (list 2 4 6 8 10)))
+        (apl-scalar 5))))
+  (list -4 -2 0 2 4))
+
+; ---------- shape / structure ----------
+
+(apl-test
+  ",⍵ — ravel"
+  (mkrv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2 3 4 5 6))
+
+(apl-test
+  "⍴⍴⍵ — rank"
+  (mkrv
+    (apl-shape (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6)))))
+  (list 2))
+
+(apl-test
+  "src: +/⍳N → triangular(N)"
+  (mkrv (apl-run "+/⍳100"))
+  (list 5050))
+
+(apl-test "src: ×/⍳N → N!" (mkrv (apl-run "×/⍳6")) (list 720))
+
+(apl-test
+  "src: ⌈/V — max"
+  (mkrv (apl-run "⌈/3 1 4 1 5 9 2 6"))
+  (list 9))
+
+(apl-test
+  "src: ⌊/V — min"
+  (mkrv (apl-run "⌊/3 1 4 1 5 9 2 6"))
+  (list 1))
+
+(apl-test
+  "src: range = (⌈/V) - ⌊/V"
+  (mkrv (apl-run "(⌈/3 1 4 1 5 9 2 6) - ⌊/3 1 4 1 5 9 2 6"))
+  (list 8))
+
+(apl-test
+  "src: +\\V — running sum"
+  (mkrv (apl-run "+\\1 2 3 4 5"))
+  (list 1 3 6 10 15))
+
+(apl-test
+  "src: ×\\V — running product"
+  (mkrv (apl-run "×\\1 2 3 4 5"))
+  (list 1 2 6 24 120))
+
+(apl-test
+  "src: V × V — squares"
+  (mkrv (apl-run "(⍳5) × ⍳5"))
+  (list 1 4 9 16 25))
+
+(apl-test
+  "src: +/V × V — sum of squares"
+  (mkrv (apl-run "+/(⍳5) × ⍳5"))
+  (list 55))
+
+(apl-test "src: ∧/V — all-true" (mkrv (apl-run "∧/1 1 1 1")) (list 1))
+
+(apl-test "src: ∨/V — any-true" (mkrv (apl-run "∨/0 0 1 0")) (list 1))
+
+(apl-test "src: 0 = N|M — divides" (mkrv (apl-run "0 = 3 | 12")) (list 1))
+
+(apl-test
+  "src: 2 | V — parity"
+  (mkrv (apl-run "2 | 1 2 3 4 5 6"))
+  (list 1 0 1 0 1 0))
+
+(apl-test
+  "src: +/2|V — count odd"
+  (mkrv (apl-run "+/2 | 1 2 3 4 5 6"))
+  (list 3))
+
+(apl-test "src: ⍴ V" (mkrv (apl-run "⍴ 1 2 3 4 5")) (list 5))
+
+(apl-test
+  "src: ⍴⍴ M — rank"
+  (mkrv (apl-run "⍴ ⍴ (2 3) ⍴ ⍳6"))
+  (list 2))
+
+(apl-test
+  "src: N⍴1 — vector of ones"
+  (mkrv (apl-run "5 ⍴ 1"))
+  (list 1 1 1 1 1))
+
+(apl-test
+  "src: ⍳N ∘.= ⍳N — identity matrix"
+  (mkrv (apl-run "(⍳3) ∘.= ⍳3"))
+  (list 1 0 0 0 1 0 0 0 1))
+
+(apl-test
+  "src: ⍳N ∘.× ⍳N — multiplication table"
+  (mkrv (apl-run "(⍳3) ∘.× ⍳3"))
+  (list 1 2 3 2 4 6 3 6 9))
+
+(apl-test
+  "src: V +.× V — dot product"
+  (mkrv (apl-run "1 2 3 +.× 4 5 6"))
+  (list 32))
+
+(apl-test
+  "src: ∧.= V — vectors equal?"
+  (mkrv (apl-run "1 2 3 ∧.= 1 2 3"))
+  (list 1))
+
+(apl-test
+  "src: V[1] — first element"
+  (mkrv (apl-run "(10 20 30 40)[1]"))
+  (list 10))
+
+(apl-test
+  "src: 1↑V — first via take"
+  (mkrv (apl-run "1 ↑ 10 20 30 40"))
+  (list 10))
+
+(apl-test
+  "src: 1↓V — drop first"
+  (mkrv (apl-run "1 ↓ 10 20 30 40"))
+  (list 20 30 40))
+
+(apl-test
+  "src: ¯1↓V — drop last"
+  (mkrv (apl-run "¯1 ↓ 10 20 30 40"))
+  (list 10 20 30))
+
+(apl-test
+  "src: ⌽V — reverse"
+  (mkrv (apl-run "⌽ 1 2 3 4 5"))
+  (list 5 4 3 2 1))
+
+(apl-test
+  "src: ≢V — tally"
+  (mkrv (apl-run "≢ 9 8 7 6 5 4 3 2 1"))
+  (list 9))
+
+(apl-test
+  "src: ,M — ravel"
+  (mkrv (apl-run ", (2 3) ⍴ ⍳6"))
+  (list 1 2 3 4 5 6))
+
+(apl-test
+  "src: A=V — count occurrences"
+  (mkrv (apl-run "+/2 = 1 2 3 2 1 3 2"))
+  (list 3))
+
+(apl-test
+  "src: ⌈/(V × V) — max squared"
+  (mkrv (apl-run "⌈/(1 2 3 4 5) × 1 2 3 4 5"))
+  (list 25))

lib/apl/tests/operators.sx

@@ -0,0 +1,791 @@
+(define rv (fn (arr) (get arr :ravel)))
+(define sh (fn (arr) (get arr :shape)))
+
+(apl-test
+  "reduce +/ vector"
+  (rv (apl-reduce apl-add (make-array (list 5) (list 1 2 3 4 5))))
+  (list 15))
+
+(apl-test
+  "reduce x/ vector"
+  (rv (apl-reduce apl-mul (make-array (list 4) (list 1 2 3 4))))
+  (list 24))
+
+(apl-test
+  "reduce max/ vector"
+  (rv (apl-reduce apl-max (make-array (list 5) (list 3 1 4 1 5))))
+  (list 5))
+
+(apl-test
+  "reduce min/ vector"
+  (rv (apl-reduce apl-min (make-array (list 3) (list 3 1 4))))
+  (list 1))
+
+(apl-test
+  "reduce and/ all true"
+  (rv (apl-reduce apl-and (make-array (list 3) (list 1 1 1))))
+  (list 1))
+
+(apl-test
+  "reduce or/ with true"
+  (rv (apl-reduce apl-or (make-array (list 3) (list 0 0 1))))
+  (list 1))
+
+(apl-test
+  "reduce +/ single element"
+  (rv (apl-reduce apl-add (make-array (list 1) (list 42))))
+  (list 42))
+
+(apl-test
+  "reduce +/ scalar no-op"
+  (rv (apl-reduce apl-add (apl-scalar 7)))
+  (list 7))
+
+(apl-test
+  "reduce +/ shape is scalar"
+  (sh (apl-reduce apl-add (make-array (list 4) (list 1 2 3 4))))
+  (list))
+
+(apl-test
+  "reduce +/ matrix row sums shape"
+  (sh (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2))
+
+(apl-test
+  "reduce +/ matrix row sums values"
+  (rv (apl-reduce apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 6 15))
+
+(apl-test
+  "reduce max/ matrix row maxima"
+  (rv (apl-reduce apl-max (make-array (list 2 3) (list 3 1 4 1 5 9))))
+  (list 4 9))
+
+(apl-test
+  "reduce-first +/ vector same as reduce"
+  (rv (apl-reduce-first apl-add (make-array (list 5) (list 1 2 3 4 5))))
+  (list 15))
+
+(apl-test
+  "reduce-first +/ matrix col sums shape"
+  (sh
+    (apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 3))
+
+(apl-test
+  "reduce-first +/ matrix col sums values"
+  (rv
+    (apl-reduce-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 5 7 9))
+
+(apl-test
+  "reduce-first max/ matrix col maxima"
+  (rv
+    (apl-reduce-first apl-max (make-array (list 3 2) (list 1 9 2 8 3 7))))
+  (list 3 9))
+
+(apl-test
+  "scan +\\ vector"
+  (rv (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 3 6 10 15))
+
+(apl-test
+  "scan x\\ vector cumulative product"
+  (rv (apl-scan apl-mul (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 6 24 120))
+
+(apl-test
+  "scan max\\ vector running max"
+  (rv (apl-scan apl-max (make-array (list 5) (list 3 1 4 1 5))))
+  (list 3 3 4 4 5))
+
+(apl-test
+  "scan min\\ vector running min"
+  (rv (apl-scan apl-min (make-array (list 5) (list 3 1 4 1 5))))
+  (list 3 1 1 1 1))
+
+(apl-test
+  "scan +\\ single element"
+  (rv (apl-scan apl-add (make-array (list 1) (list 42))))
+  (list 42))
+
+(apl-test
+  "scan +\\ scalar no-op"
+  (rv (apl-scan apl-add (apl-scalar 7)))
+  (list 7))
+
+(apl-test
+  "scan +\\ vector preserves shape"
+  (sh (apl-scan apl-add (make-array (list 5) (list 1 2 3 4 5))))
+  (list 5))
+
+(apl-test
+  "scan +\\ matrix preserves shape"
+  (sh (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2 3))
+
+(apl-test
+  "scan +\\ matrix row-wise"
+  (rv (apl-scan apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 3 6 4 9 15))
+
+(apl-test
+  "scan max\\ matrix row-wise running max"
+  (rv (apl-scan apl-max (make-array (list 2 3) (list 3 1 4 1 5 9))))
+  (list 3 3 4 1 5 9))
+
+(apl-test
+  "scan-first +\\ vector same as scan"
+  (rv (apl-scan-first apl-add (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 3 6 10 15))
+
+(apl-test
+  "scan-first +\\ scalar no-op"
+  (rv (apl-scan-first apl-add (apl-scalar 9)))
+  (list 9))
+
+(apl-test
+  "scan-first +\\ matrix preserves shape"
+  (sh (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2 3))
+
+(apl-test
+  "scan-first +\\ matrix col-wise"
+  (rv (apl-scan-first apl-add (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2 3 5 7 9))
+
+(apl-test
+  "scan-first max\\ matrix col-wise running max"
+  (rv (apl-scan-first apl-max (make-array (list 3 2) (list 3 1 4 1 5 9))))
+  (list 3 1 4 1 5 9))
+
+(apl-test
+  "each negate vector"
+  (rv (apl-each apl-neg-m (make-array (list 3) (list 1 2 3))))
+  (list -1 -2 -3))
+
+(apl-test
+  "each negate vector preserves shape"
+  (sh (apl-each apl-neg-m (make-array (list 3) (list 1 2 3))))
+  (list 3))
+
+(apl-test
+  "each reciprocal vector"
+  (rv (apl-each apl-recip (make-array (list 3) (list 1 2 4))))
+  (list 1 (/ 1 2) (/ 1 4)))
+
+(apl-test
+  "each abs vector"
+  (rv (apl-each apl-abs (make-array (list 4) (list -1 2 -3 4))))
+  (list 1 2 3 4))
+
+(apl-test "each scalar" (rv (apl-each apl-neg-m (apl-scalar 5))) (list -5))
+
+(apl-test
+  "each scalar shape"
+  (sh (apl-each apl-neg-m (apl-scalar 5)))
+  (list))
+
+(apl-test
+  "each negate matrix shape"
+  (sh (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2 3))
+
+(apl-test
+  "each negate matrix values"
+  (rv (apl-each apl-neg-m (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list -1 -2 -3 -4 -5 -6))
+
+(apl-test
+  "each-dyadic scalar+scalar"
+  (rv (apl-each-dyadic apl-add (apl-scalar 3) (apl-scalar 4)))
+  (list 7))
+
+(apl-test
+  "each-dyadic scalar+vector"
+  (rv
+    (apl-each-dyadic
+      apl-add
+      (apl-scalar 10)
+      (make-array (list 3) (list 1 2 3))))
+  (list 11 12 13))
+
+(apl-test
+  "each-dyadic vector+scalar"
+  (rv
+    (apl-each-dyadic
+      apl-add
+      (make-array (list 3) (list 1 2 3))
+      (apl-scalar 10)))
+  (list 11 12 13))
+
+(apl-test
+  "each-dyadic vector+vector"
+  (rv
+    (apl-each-dyadic
+      apl-add
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 10 20 30))))
+  (list 11 22 33))
+
+(apl-test
+  "each-dyadic mul matrix+matrix shape"
+  (sh
+    (apl-each-dyadic
+      apl-mul
+      (make-array (list 2 2) (list 1 2 3 4))
+      (make-array (list 2 2) (list 5 6 7 8))))
+  (list 2 2))
+
+(apl-test
+  "each-dyadic mul matrix+matrix values"
+  (rv
+    (apl-each-dyadic
+      apl-mul
+      (make-array (list 2 2) (list 1 2 3 4))
+      (make-array (list 2 2) (list 5 6 7 8))))
+  (list 5 12 21 32))
+
+(apl-test
+  "outer product mult table values"
+  (rv
+    (apl-outer
+      apl-mul
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 1 2 3))))
+  (list 1 2 3 2 4 6 3 6 9))
+
+(apl-test
+  "outer product mult table shape"
+  (sh
+    (apl-outer
+      apl-mul
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 1 2 3))))
+  (list 3 3))
+
+(apl-test
+  "outer product add table values"
+  (rv
+    (apl-outer
+      apl-add
+      (make-array (list 2) (list 1 2))
+      (make-array (list 3) (list 10 20 30))))
+  (list 11 21 31 12 22 32))
+
+(apl-test
+  "outer product add table shape"
+  (sh
+    (apl-outer
+      apl-add
+      (make-array (list 2) (list 1 2))
+      (make-array (list 3) (list 10 20 30))))
+  (list 2 3))
+
+(apl-test
+  "outer product scalar+vector shape"
+  (sh
+    (apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3))))
+  (list 3))
+
+(apl-test
+  "outer product scalar+vector values"
+  (rv
+    (apl-outer apl-mul (apl-scalar 5) (make-array (list 3) (list 1 2 3))))
+  (list 5 10 15))
+
+(apl-test
+  "outer product vector+scalar shape"
+  (sh
+    (apl-outer apl-mul (make-array (list 3) (list 1 2 3)) (apl-scalar 10)))
+  (list 3))
+
+(apl-test
+  "outer product scalar+scalar"
+  (rv (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7)))
+  (list 42))
+
+(apl-test
+  "outer product scalar+scalar shape"
+  (sh (apl-outer apl-mul (apl-scalar 6) (apl-scalar 7)))
+  (list))
+
+(apl-test
+  "outer product equality identity matrix values"
+  (rv
+    (apl-outer
+      apl-eq
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 1 2 3))))
+  (list 1 0 0 0 1 0 0 0 1))
+
+(apl-test
+  "outer product matrix+vector rank doubling shape"
+  (sh
+    (apl-outer
+      apl-add
+      (make-array (list 2 2) (list 1 2 3 4))
+      (make-array (list 3) (list 10 20 30))))
+  (list 2 2 3))
+
+(apl-test
+  "outer product matrix+vector rank doubling values"
+  (rv
+    (apl-outer
+      apl-add
+      (make-array (list 2 2) (list 1 2 3 4))
+      (make-array (list 3) (list 10 20 30))))
+  (list 11 21 31 12 22 32 13 23 33 14 24 34))
+
+(apl-test
+  "inner +.× dot product"
+  (rv
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 4 5 6))))
+  (list 32))
+
+(apl-test
+  "inner +.× dot product shape is scalar"
+  (sh
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 4 5 6))))
+  (list))
+
+(apl-test
+  "inner +.× matrix multiply 2x3 * 3x2 shape"
+  (sh
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3 2) (list 7 8 9 10 11 12))))
+  (list 2 2))
+
+(apl-test
+  "inner +.× matrix multiply 2x3 * 3x2 values"
+  (rv
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3 2) (list 7 8 9 10 11 12))))
+  (list 58 64 139 154))
+
+(apl-test
+  "inner +.× identity matrix 2x2"
+  (rv
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 2 2) (list 1 0 0 1))
+      (make-array (list 2 2) (list 5 6 7 8))))
+  (list 5 6 7 8))
+
+(apl-test
+  "inner ∧.= equal vectors"
+  (rv
+    (apl-inner
+      apl-and
+      apl-eq
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 1 2 3))))
+  (list 1))
+
+(apl-test
+  "inner ∧.= unequal vectors"
+  (rv
+    (apl-inner
+      apl-and
+      apl-eq
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 1 9 3))))
+  (list 0))
+
+(apl-test
+  "inner +.× matrix * vector shape"
+  (sh
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3) (list 7 8 9))))
+  (list 2))
+
+(apl-test
+  "inner +.× matrix * vector values"
+  (rv
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3) (list 7 8 9))))
+  (list 50 122))
+
+(apl-test
+  "inner +.× vector * matrix shape"
+  (sh
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3 2) (list 4 5 6 7 8 9))))
+  (list 2))
+
+(apl-test
+  "inner +.× vector * matrix values"
+  (rv
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3 2) (list 4 5 6 7 8 9))))
+  (list 40 46))
+
+(apl-test
+  "inner +.× single-element vectors"
+  (rv
+    (apl-inner
+      apl-add
+      apl-mul
+      (make-array (list 1) (list 6))
+      (make-array (list 1) (list 7))))
+  (list 42))
+
+(apl-test
+  "commute +⍨ scalar doubles"
+  (rv (apl-commute apl-add (apl-scalar 5)))
+  (list 10))
+
+(apl-test
+  "commute ×⍨ vector squares"
+  (rv (apl-commute apl-mul (make-array (list 4) (list 1 2 3 4))))
+  (list 1 4 9 16))
+
+(apl-test
+  "commute +⍨ vector doubles"
+  (rv (apl-commute apl-add (make-array (list 3) (list 1 2 3))))
+  (list 2 4 6))
+
+(apl-test
+  "commute +⍨ shape preserved"
+  (sh (apl-commute apl-add (make-array (list 3) (list 1 2 3))))
+  (list 3))
+
+(apl-test
+  "commute ×⍨ matrix shape preserved"
+  (sh (apl-commute apl-mul (make-array (list 2 2) (list 1 2 3 4))))
+  (list 2 2))
+
+(apl-test
+  "commute-dyadic -⍨ swaps subtraction"
+  (rv (apl-commute-dyadic apl-sub (apl-scalar 5) (apl-scalar 3)))
+  (list -2))
+
+(apl-test
+  "commute-dyadic ÷⍨ swaps division"
+  (rv (apl-commute-dyadic apl-div (apl-scalar 4) (apl-scalar 12)))
+  (list 3))
+
+(apl-test
+  "commute-dyadic -⍨ on vectors"
+  (rv
+    (apl-commute-dyadic
+      apl-sub
+      (make-array (list 3) (list 10 20 30))
+      (make-array (list 3) (list 1 2 3))))
+  (list -9 -18 -27))
+
+(apl-test
+  "commute-dyadic +⍨ commutative same result"
+  (rv
+    (apl-commute-dyadic
+      apl-add
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 10 20 30))))
+  (list 11 22 33))
+
+(apl-test
+  "commute-dyadic ×⍨ commutative same result"
+  (rv
+    (apl-commute-dyadic
+      apl-mul
+      (make-array (list 3) (list 2 3 4))
+      (make-array (list 3) (list 5 6 7))))
+  (list 10 18 28))
+
+(apl-test
+  "compose -∘| scalar (negative abs)"
+  (rv (apl-compose apl-neg-m apl-abs (apl-scalar -7)))
+  (list -7))
+
+(apl-test
+  "compose -∘| vector"
+  (rv
+    (apl-compose apl-neg-m apl-abs (make-array (list 4) (list -1 2 -3 4))))
+  (list -1 -2 -3 -4))
+
+(apl-test
+  "compose ⌊∘- (floor of negate)"
+  (rv (apl-compose apl-floor apl-neg-m (make-array (list 3) (list 1 2 3))))
+  (list -1 -2 -3))
+
+(apl-test
+  "compose -∘| matrix shape preserved"
+  (sh
+    (apl-compose apl-neg-m apl-abs (make-array (list 2 2) (list -1 2 -3 4))))
+  (list 2 2))
+
+(apl-test
+  "compose-dyadic +∘- equals subtract scalar"
+  (rv (apl-compose-dyadic apl-add apl-neg-m (apl-scalar 10) (apl-scalar 3)))
+  (list 7))
+
+(apl-test
+  "compose-dyadic +∘- equals subtract vector"
+  (rv
+    (apl-compose-dyadic
+      apl-add
+      apl-neg-m
+      (make-array (list 3) (list 10 20 30))
+      (make-array (list 3) (list 1 2 3))))
+  (list 9 18 27))
+
+(apl-test
+  "compose-dyadic -∘| (subtract abs)"
+  (rv (apl-compose-dyadic apl-sub apl-abs (apl-scalar 10) (apl-scalar -3)))
+  (list 7))
+
+(apl-test
+  "compose-dyadic ×∘- (multiply by negative)"
+  (rv
+    (apl-compose-dyadic
+      apl-mul
+      apl-neg-m
+      (make-array (list 3) (list 2 3 4))
+      (make-array (list 3) (list 1 2 3))))
+  (list -2 -6 -12))
+
+(apl-test
+  "compose-dyadic shape preserved"
+  (sh
+    (apl-compose-dyadic
+      apl-add
+      apl-neg-m
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 2 3) (list 1 1 1 1 1 1))))
+  (list 2 3))
+
+(apl-test
+  "power n=0 identity"
+  (rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 0 (apl-scalar 5)))
+  (list 5))
+
+(apl-test
+  "power increment by 3"
+  (rv (apl-power (fn (a) (apl-add a (apl-scalar 1))) 3 (apl-scalar 0)))
+  (list 3))
+
+(apl-test
+  "power double 4 times = 16"
+  (rv (apl-power (fn (a) (apl-mul a (apl-scalar 2))) 4 (apl-scalar 1)))
+  (list 16))
+
+(apl-test
+  "power on vector +5"
+  (rv
+    (apl-power
+      (fn (a) (apl-add a (apl-scalar 1)))
+      5
+      (make-array (list 3) (list 1 2 3))))
+  (list 6 7 8))
+
+(apl-test
+  "power on vector preserves shape"
+  (sh
+    (apl-power
+      (fn (a) (apl-add a (apl-scalar 1)))
+      5
+      (make-array (list 3) (list 1 2 3))))
+  (list 3))
+
+(apl-test
+  "power on matrix"
+  (rv
+    (apl-power
+      (fn (a) (apl-mul a (apl-scalar 3)))
+      2
+      (make-array (list 2 2) (list 1 2 3 4))))
+  (list 9 18 27 36))
+
+(apl-test
+  "power-fixed identity stops immediately"
+  (rv (apl-power-fixed (fn (a) a) (make-array (list 3) (list 1 2 3))))
+  (list 1 2 3))
+
+(apl-test
+  "power-fixed floor half scalar to 0"
+  (rv
+    (apl-power-fixed
+      (fn (a) (apl-floor (apl-div a (apl-scalar 2))))
+      (apl-scalar 100)))
+  (list 0))
+
+(apl-test
+  "power-fixed shape preserved"
+  (sh
+    (apl-power-fixed (fn (a) a) (make-array (list 2 2) (list 1 2 3 4))))
+  (list 2 2))
+
+(apl-test
+  "rank tally⍤1 row tallies"
+  (rv (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 3 3))
+
+(apl-test
+  "rank tally⍤1 row tallies shape"
+  (sh (apl-rank apl-tally 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2))
+
+(apl-test
+  "rank neg⍤0 vector scalar cells"
+  (rv (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3))))
+  (list -1 -2 -3))
+
+(apl-test
+  "rank neg⍤0 vector preserves shape"
+  (sh (apl-rank apl-neg-m 0 (make-array (list 3) (list 1 2 3))))
+  (list 3))
+
+(apl-test
+  "rank neg⍤1 matrix per-row"
+  (rv (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list -1 -2 -3 -4 -5 -6))
+
+(apl-test
+  "rank neg⍤1 matrix preserves shape"
+  (sh (apl-rank apl-neg-m 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2 3))
+
+(apl-test
+  "rank k>=rank fallthrough"
+  (rv (apl-rank apl-tally 5 (make-array (list 4) (list 1 2 3 4))))
+  (list 4))
+
+(apl-test
+  "rank tally⍤2 whole matrix tally"
+  (rv
+    (apl-rank
+      apl-tally
+      2
+      (make-array (list 3 5) (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))))
+  (list 3))
+
+(apl-test
+  "rank reverse⍤1 matrix reverse rows"
+  (rv (apl-rank apl-reverse 1 (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 3 2 1 6 5 4))
+
+(apl-test
+  "rank tally⍤1 3x4 row tallies"
+  (rv
+    (apl-rank
+      apl-tally
+      1
+      (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
+  (list 4 4 4))
+
+(apl-test
+  "at-replace single index"
+  (rv
+    (apl-at-replace
+      (apl-scalar 99)
+      (make-array (list 1) (list 2))
+      (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 99 3 4 5))
+
+(apl-test
+  "at-replace multiple indices vector vals"
+  (rv
+    (apl-at-replace
+      (make-array (list 2) (list 99 88))
+      (make-array (list 2) (list 2 4))
+      (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 99 3 88 5))
+
+(apl-test
+  "at-replace scalar broadcast"
+  (rv
+    (apl-at-replace
+      (apl-scalar 0)
+      (make-array (list 3) (list 1 3 5))
+      (make-array (list 5) (list 10 20 30 40 50))))
+  (list 0 20 0 40 0))
+
+(apl-test
+  "at-replace preserves shape"
+  (sh
+    (apl-at-replace
+      (apl-scalar 99)
+      (make-array (list 1) (list 2))
+      (make-array (list 5) (list 1 2 3 4 5))))
+  (list 5))
+
+(apl-test
+  "at-replace last index"
+  (rv
+    (apl-at-replace
+      (apl-scalar 99)
+      (make-array (list 1) (list 5))
+      (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 3 4 99))
+
+(apl-test
+  "at-replace on matrix linear-index"
+  (rv
+    (apl-at-replace
+      (apl-scalar 99)
+      (make-array (list 1) (list 3))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2 99 4 5 6))
+
+(apl-test
+  "at-apply negate at indices"
+  (rv
+    (apl-at-apply
+      apl-neg-m
+      (make-array (list 3) (list 1 3 5))
+      (make-array (list 5) (list 1 2 3 4 5))))
+  (list -1 2 -3 4 -5))
+
+(apl-test
+  "at-apply double at index 1"
+  (rv
+    (apl-at-apply
+      (fn (a) (apl-mul a (apl-scalar 2)))
+      (make-array (list 1) (list 1))
+      (make-array (list 2) (list 5 10))))
+  (list 10 10))
+
+(apl-test
+  "at-apply preserves shape"
+  (sh
+    (apl-at-apply
+      apl-neg-m
+      (make-array (list 2) (list 1 3))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2 3))
+
+(apl-test
+  "at-apply on matrix linear-index"
+  (rv
+    (apl-at-apply
+      apl-neg-m
+      (make-array (list 2) (list 1 6))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list -1 2 3 4 5 -6))

lib/apl/tests/parse.sx

@@ -0,0 +1,340 @@
+(define apl-test-count 0)
+(define apl-test-pass  0)
+(define apl-test-fails (list))
+
+(define apl-test
+  (fn (name actual expected)
+    (begin
+      (set! apl-test-count (+ apl-test-count 1))
+      (if (= actual expected)
+        (set! apl-test-pass (+ apl-test-pass 1))
+        (append! apl-test-fails {:name name :actual actual :expected expected})))))
+
+(define tok-types
+  (fn (src)
+    (map (fn (t) (get t :type)) (apl-tokenize src))))
+
+(define tok-values
+  (fn (src)
+    (map (fn (t) (get t :value)) (apl-tokenize src))))
+
+(define tok-count
+  (fn (src)
+    (len (apl-tokenize src))))
+
+(define tok-type-at
+  (fn (src i)
+    (get (nth (apl-tokenize src) i) :type)))
+
+(define tok-value-at
+  (fn (src i)
+    (get (nth (apl-tokenize src) i) :value)))
+
+(apl-test "empty: no tokens"        (tok-count "")           0)
+(apl-test "empty: whitespace only"  (tok-count "   ")        0)
+(apl-test "num: zero"               (tok-values "0")         (list 0))
+(apl-test "num: positive"           (tok-values "42")        (list 42))
+(apl-test "num: large"              (tok-values "12345")     (list 12345))
+(apl-test "num: negative"           (tok-values "¯5")        (list -5))
+(apl-test "num: negative zero"      (tok-values "¯0")        (list 0))
+(apl-test "num: strand count"       (tok-count "1 2 3")      3)
+(apl-test "num: strand types"       (tok-types "1 2 3")      (list :num :num :num))
+(apl-test "num: strand values"      (tok-values "1 2 3")     (list 1 2 3))
+(apl-test "num: neg in strand"      (tok-values "1 ¯2 3")    (list 1 -2 3))
+(apl-test "str: empty"              (tok-values "''")        (list ""))
+(apl-test "str: single char"        (tok-values "'a'")       (list "a"))
+(apl-test "str: word"               (tok-values "'hello'")   (list "hello"))
+(apl-test "str: escaped quote"      (tok-values "''''")      (list "'"))
+(apl-test "str: type"               (tok-types "'abc'")      (list :str))
+(apl-test "name: simple"            (tok-values "foo")       (list "foo"))
+(apl-test "name: type"              (tok-types "foo")        (list :name))
+(apl-test "name: mixed case"        (tok-values "MyVar")     (list "MyVar"))
+(apl-test "name: with digits"       (tok-values "x1")        (list "x1"))
+(apl-test "name: system var"        (tok-values "⎕IO")       (list "⎕IO"))
+(apl-test "name: system var type"   (tok-types "⎕IO")        (list :name))
+(apl-test "glyph: plus"             (tok-types "+")          (list :glyph))
+(apl-test "glyph: plus value"       (tok-values "+")         (list "+"))
+(apl-test "glyph: iota"             (tok-values "⍳")         (list "⍳"))
+(apl-test "glyph: reduce"           (tok-values "+/")        (list "+" "/"))
+(apl-test "glyph: floor"            (tok-values "⌊")         (list "⌊"))
+(apl-test "glyph: rho"              (tok-values "⍴")         (list "⍴"))
+(apl-test "glyph: alpha omega"      (tok-types "⍺ ⍵")        (list :glyph :glyph))
+(apl-test "punct: lparen"           (tok-types "(")          (list :lparen))
+(apl-test "punct: rparen"           (tok-types ")")          (list :rparen))
+(apl-test "punct: brackets"         (tok-types "[42]")       (list :lbracket :num :rbracket))
+(apl-test "punct: braces"           (tok-types "{}")         (list :lbrace :rbrace))
+(apl-test "punct: semi"             (tok-types ";")          (list :semi))
+(apl-test "assign: arrow"           (tok-types "x←1")        (list :name :assign :num))
+(apl-test "diamond: separator"      (tok-types "1⋄2")        (list :num :diamond :num))
+(apl-test "newline: emitted"        (tok-types "1\n2")       (list :num :newline :num))
+(apl-test "comment: skipped"        (tok-count "⍝ ignore me") 0)
+(apl-test "comment: rest ignored"   (tok-count "1 ⍝ note")  1)
+(apl-test "colon: bare"             (tok-types ":")          (list :colon))
+(apl-test "keyword: If"             (tok-values ":If")       (list ":If"))
+(apl-test "keyword: type"           (tok-types ":While")     (list :keyword))
+(apl-test "keyword: EndFor"         (tok-values ":EndFor")   (list ":EndFor"))
+(apl-test "expr: +/ ⍳ 5"           (tok-types "+/ ⍳ 5")     (list :glyph :glyph :glyph :num))
+(apl-test "expr: x←42"             (tok-count "x←42")       3)
+(apl-test "expr: dfn body"          (tok-types "{⍺+⍵}")
+                                    (list :lbrace :glyph :glyph :glyph :rbrace))
+
+(define apl-tokenize-test-summary
+  (str "tokenizer " apl-test-pass "/" apl-test-count
+       (if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails))))
+
+; ===========================================================================
+; Parser tests
+; ===========================================================================
+
+; Helper: parse an APL source string and return the AST
+(define parse
+  (fn (src) (parse-apl src)))
+
+; Helper: build an expected AST node using keyword-tagged lists
+(define num-node    (fn (n)       (list :num n)))
+(define str-node    (fn (s)       (list :str s)))
+(define name-node   (fn (n)       (list :name n)))
+(define fn-node     (fn (g)       (list :fn-glyph g)))
+(define fn-nm       (fn (n)       (list :fn-name n)))
+(define assign-node (fn (nm expr) (list :assign nm expr)))
+(define monad-node  (fn (f a)     (list :monad f a)))
+(define dyad-node   (fn (f l r)   (list :dyad f l r)))
+(define derived-fn  (fn (op f)    (list :derived-fn op f)))
+(define derived-fn2 (fn (op f g)  (list :derived-fn2 op f g)))
+(define outer-node  (fn (f)       (list :outer "∘." f)))
+(define guard-node  (fn (c e)     (list :guard c e)))
+
+; ---- numeric literals ----
+
+(apl-test "parse: num literal"
+  (parse "42")
+  (num-node 42))
+
+(apl-test "parse: negative num"
+  (parse "¯3")
+  (num-node -3))
+
+(apl-test "parse: zero"
+  (parse "0")
+  (num-node 0))
+
+; ---- string literals ----
+
+(apl-test "parse: str literal"
+  (parse "'hello'")
+  (str-node "hello"))
+
+(apl-test "parse: empty str"
+  (parse "''")
+  (str-node ""))
+
+; ---- name reference ----
+
+(apl-test "parse: name"
+  (parse "x")
+  (name-node "x"))
+
+(apl-test "parse: system name"
+  (parse "⎕IO")
+  (name-node "⎕IO"))
+
+; ---- strands (vec nodes) ----
+
+(apl-test "parse: strand 3 nums"
+  (parse "1 2 3")
+  (list :vec (num-node 1) (num-node 2) (num-node 3)))
+
+(apl-test "parse: strand 2 nums"
+  (parse "1 2")
+  (list :vec (num-node 1) (num-node 2)))
+
+(apl-test "parse: strand with negatives"
+  (parse "1 ¯2 3")
+  (list :vec (num-node 1) (num-node -2) (num-node 3)))
+
+; ---- assignment ----
+
+(apl-test "parse: assignment"
+  (parse "x←42")
+  (assign-node "x" (num-node 42)))
+
+(apl-test "parse: assignment with spaces"
+  (parse "x ← 42")
+  (assign-node "x" (num-node 42)))
+
+(apl-test "parse: assignment of expr"
+  (parse "r←2+3")
+  (assign-node "r" (dyad-node (fn-node "+") (num-node 2) (num-node 3))))
+
+; ---- monadic functions ----
+
+(apl-test "parse: monadic iota"
+  (parse "⍳5")
+  (monad-node (fn-node "⍳") (num-node 5)))
+
+(apl-test "parse: monadic iota with space"
+  (parse "⍳ 5")
+  (monad-node (fn-node "⍳") (num-node 5)))
+
+(apl-test "parse: monadic negate"
+  (parse "-3")
+  (monad-node (fn-node "-") (num-node 3)))
+
+(apl-test "parse: monadic floor"
+  (parse "⌊2")
+  (monad-node (fn-node "⌊") (num-node 2)))
+
+(apl-test "parse: monadic of name"
+  (parse "⍴x")
+  (monad-node (fn-node "⍴") (name-node "x")))
+
+; ---- dyadic functions ----
+
+(apl-test "parse: dyadic plus"
+  (parse "2+3")
+  (dyad-node (fn-node "+") (num-node 2) (num-node 3)))
+
+(apl-test "parse: dyadic times"
+  (parse "2×3")
+  (dyad-node (fn-node "×") (num-node 2) (num-node 3)))
+
+(apl-test "parse: dyadic with names"
+  (parse "x+y")
+  (dyad-node (fn-node "+") (name-node "x") (name-node "y")))
+
+; ---- right-to-left evaluation ----
+
+(apl-test "parse: right-to-left 2×3+4"
+  (parse "2×3+4")
+  (dyad-node (fn-node "×") (num-node 2)
+    (dyad-node (fn-node "+") (num-node 3) (num-node 4))))
+
+(apl-test "parse: right-to-left chain"
+  (parse "1+2×3-4")
+  (dyad-node (fn-node "+") (num-node 1)
+    (dyad-node (fn-node "×") (num-node 2)
+      (dyad-node (fn-node "-") (num-node 3) (num-node 4)))))
+
+; ---- parenthesized subexpressions ----
+
+(apl-test "parse: parens override order"
+  (parse "(2+3)×4")
+  (dyad-node (fn-node "×")
+    (dyad-node (fn-node "+") (num-node 2) (num-node 3))
+    (num-node 4)))
+
+(apl-test "parse: nested parens"
+  (parse "((2+3))")
+  (dyad-node (fn-node "+") (num-node 2) (num-node 3)))
+
+(apl-test "parse: paren in dyadic right"
+  (parse "2×(3+4)")
+  (dyad-node (fn-node "×") (num-node 2)
+    (dyad-node (fn-node "+") (num-node 3) (num-node 4))))
+
+; ---- operators → derived functions ----
+
+(apl-test "parse: reduce +"
+  (parse "+/x")
+  (monad-node (derived-fn "/" (fn-node "+")) (name-node "x")))
+
+(apl-test "parse: reduce iota"
+  (parse "+/⍳5")
+  (monad-node (derived-fn "/" (fn-node "+"))
+    (monad-node (fn-node "⍳") (num-node 5))))
+
+(apl-test "parse: scan"
+  (parse "+\\x")
+  (monad-node (derived-fn "\\" (fn-node "+")) (name-node "x")))
+
+(apl-test "parse: each"
+  (parse "⍳¨x")
+  (monad-node (derived-fn "¨" (fn-node "⍳")) (name-node "x")))
+
+(apl-test "parse: commute"
+  (parse "-⍨3")
+  (monad-node (derived-fn "⍨" (fn-node "-")) (num-node 3)))
+
+(apl-test "parse: stacked ops"
+  (parse "+/¨x")
+  (monad-node (derived-fn "¨" (derived-fn "/" (fn-node "+"))) (name-node "x")))
+
+; ---- outer product ----
+
+(apl-test "parse: outer product monadic"
+  (parse "∘.×")
+  (outer-node (fn-node "×")))
+
+(apl-test "parse: outer product dyadic names"
+  (parse "x ∘.× y")
+  (dyad-node (outer-node (fn-node "×")) (name-node "x") (name-node "y")))
+
+(apl-test "parse: outer product dyadic strands"
+  (parse "1 2 3 ∘.× 4 5 6")
+  (dyad-node (outer-node (fn-node "×"))
+    (list :vec (num-node 1) (num-node 2) (num-node 3))
+    (list :vec (num-node 4) (num-node 5) (num-node 6))))
+
+; ---- inner product ----
+
+(apl-test "parse: inner product"
+  (parse "+.×")
+  (derived-fn2 "." (fn-node "+") (fn-node "×")))
+
+(apl-test "parse: inner product applied"
+  (parse "a +.× b")
+  (dyad-node (derived-fn2 "." (fn-node "+") (fn-node "×"))
+    (name-node "a") (name-node "b")))
+
+; ---- dfn (anonymous function) ----
+
+(apl-test "parse: simple dfn"
+  (parse "{⍺+⍵}")
+  (list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵"))))
+
+(apl-test "parse: monadic dfn"
+  (parse "{⍵×2}")
+  (list :dfn (dyad-node (fn-node "×") (name-node "⍵") (num-node 2))))
+
+(apl-test "parse: dfn self-ref"
+  (parse "{⍵≤1:1 ⋄ ⍵×∇ ⍵-1}")
+  (list :dfn
+    (guard-node (dyad-node (fn-node "≤") (name-node "⍵") (num-node 1)) (num-node 1))
+    (dyad-node (fn-node "×") (name-node "⍵")
+      (monad-node (fn-node "∇") (dyad-node (fn-node "-") (name-node "⍵") (num-node 1))))))
+
+; ---- dfn applied ----
+
+(apl-test "parse: dfn as function"
+  (parse "{⍺+⍵} 3")
+  (monad-node
+    (list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵")))
+    (num-node 3)))
+
+; ---- multi-statement ----
+
+(apl-test "parse: diamond separator"
+  (let ((result (parse "x←1 ⋄ x+2")))
+    (= (first result) :program))
+  true)
+
+(apl-test "parse: diamond first stmt"
+  (let ((result (parse "x←1 ⋄ x+2")))
+    (nth result 1))
+  (assign-node "x" (num-node 1)))
+
+(apl-test "parse: diamond second stmt"
+  (let ((result (parse "x←1 ⋄ x+2")))
+    (nth result 2))
+  (dyad-node (fn-node "+") (name-node "x") (num-node 2)))
+
+; ---- combined summary ----
+
+(define apl-parse-test-count (- apl-test-count 46))
+(define apl-parse-test-pass  (- apl-test-pass 46))
+
+(define apl-test-summary
+  (str
+    "tokenizer 46/46  |  "
+    "parser " apl-parse-test-pass "/" apl-parse-test-count
+    (if (= (len apl-test-fails) 0) "" (str "  FAILS: " apl-test-fails))))

lib/apl/tests/pipeline.sx

@@ -0,0 +1,457 @@
+; End-to-end pipeline tests: source string → tokenize → parse → eval-ast → array.
+; Verifies the full stack as a single function call (apl-run).
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+
+; ---------- scalars ----------
+
+(apl-test "apl-run \"42\" → scalar 42" (mkrv (apl-run "42")) (list 42))
+
+(apl-test "apl-run \"¯7\" → scalar -7" (mkrv (apl-run "¯7")) (list -7))
+
+; ---------- strands ----------
+
+(apl-test
+  "apl-run \"1 2 3\" → vector"
+  (mkrv (apl-run "1 2 3"))
+  (list 1 2 3))
+
+(apl-test "apl-run \"1 2 3\" shape" (mksh (apl-run "1 2 3")) (list 3))
+
+; ---------- dyadic arithmetic ----------
+
+(apl-test "apl-run \"2 + 3\" → 5" (mkrv (apl-run "2 + 3")) (list 5))
+
+(apl-run "2 × 3 + 4")  ; right-to-left
+
+(apl-test
+  "apl-run \"2 × 3 + 4\" → 14 (right-to-left)"
+  (mkrv (apl-run "2 × 3 + 4"))
+  (list 14))
+
+(apl-test
+  "apl-run \"1 2 3 + 4 5 6\" → 5 7 9"
+  (mkrv (apl-run "1 2 3 + 4 5 6"))
+  (list 5 7 9))
+
+(apl-test
+  "apl-run \"3 × 1 2 3 4\" → scalar broadcast"
+  (mkrv (apl-run "3 × 1 2 3 4"))
+  (list 3 6 9 12))
+
+; ---------- monadic primitives ----------
+
+(apl-test
+  "apl-run \"⍳5\" → 1..5"
+  (mkrv (apl-run "⍳5"))
+  (list 1 2 3 4 5))
+
+(apl-test
+  "apl-run \"-3\" → -3 (monadic negate)"
+  (mkrv (apl-run "-3"))
+  (list -3))
+
+(apl-test
+  "apl-run \"⌈/ 1 3 9 5 7\" → 9 (max-reduce)"
+  (mkrv (apl-run "⌈/ 1 3 9 5 7"))
+  (list 9))
+
+(apl-test
+  "apl-run \"⌊/ 4 7 2 9 1 3\" → 1 (min-reduce)"
+  (mkrv (apl-run "⌊/ 4 7 2 9 1 3"))
+  (list 1))
+
+; ---------- operators ----------
+
+(apl-test "apl-run \"+/⍳5\" → 15" (mkrv (apl-run "+/⍳5")) (list 15))
+
+(apl-test "apl-run \"×/⍳5\" → 120" (mkrv (apl-run "×/⍳5")) (list 120))
+
+(apl-test
+  "apl-run \"⌈/3 1 4 1 5 9 2\" → 9"
+  (mkrv (apl-run "⌈/3 1 4 1 5 9 2"))
+  (list 9))
+
+(apl-test
+  "apl-run \"+\\\\⍳5\" → triangular numbers"
+  (mkrv (apl-run "+\\⍳5"))
+  (list 1 3 6 10 15))
+
+; ---------- outer / inner products ----------
+
+(apl-test
+  "apl-run \"1 2 3 ∘.× 1 2 3\" → mult table values"
+  (mkrv (apl-run "1 2 3 ∘.× 1 2 3"))
+  (list 1 2 3 2 4 6 3 6 9))
+
+(apl-test
+  "apl-run \"1 2 3 +.× 4 5 6\" → dot product 32"
+  (mkrv (apl-run "1 2 3 +.× 4 5 6"))
+  (list 32))
+
+; ---------- shape ----------
+
+(apl-test
+  "apl-run \"⍴ 1 2 3 4 5\" → 5"
+  (mkrv (apl-run "⍴ 1 2 3 4 5"))
+  (list 5))
+
+(apl-test "apl-run \"⍴⍳10\" → 10" (mkrv (apl-run "⍴⍳10")) (list 10))
+
+; ---------- comparison ----------
+
+(apl-test "apl-run \"3 < 5\" → 1" (mkrv (apl-run "3 < 5")) (list 1))
+
+(apl-test "apl-run \"5 = 5\" → 1" (mkrv (apl-run "5 = 5")) (list 1))
+
+(apl-test
+  "apl-run \"1 2 3 = 1 0 3\" → 1 0 1"
+  (mkrv (apl-run "1 2 3 = 1 0 3"))
+  (list 1 0 1))
+
+; ---------- famous one-liners ----------
+
+(apl-test
+  "apl-run \"+/(⍳10)\" → sum 1..10 = 55"
+  (mkrv (apl-run "+/(⍳10)"))
+  (list 55))
+
+(apl-test
+  "apl-run \"×/⍳10\" → 10! = 3628800"
+  (mkrv (apl-run "×/⍳10"))
+  (list 3628800))
+
+(apl-test "apl-run \"⎕IO\" → 1" (mkrv (apl-run "⎕IO")) (list 1))
+
+(apl-test "apl-run \"⎕ML\" → 1" (mkrv (apl-run "⎕ML")) (list 1))
+
+(apl-test "apl-run \"⎕FR\" → 1248" (mkrv (apl-run "⎕FR")) (list 1248))
+
+(apl-test "apl-run \"⎕TS\" shape (7)" (mksh (apl-run "⎕TS")) (list 7))
+
+(apl-test "apl-run \"⎕FMT 42\" → \"42\"" (apl-run "⎕FMT 42") "42")
+
+(apl-test
+  "apl-run \"⎕FMT 1 2 3\" → \"1 2 3\""
+  (apl-run "⎕FMT 1 2 3")
+  "1 2 3")
+
+(apl-test
+  "apl-run \"⎕FMT ⍳5\" → \"1 2 3 4 5\""
+  (apl-run "⎕FMT ⍳5")
+  "1 2 3 4 5")
+
+(apl-test "apl-run \"⎕IO + 4\" → 5" (mkrv (apl-run "⎕IO + 4")) (list 5))
+
+(apl-test
+  "apl-run \"(10 20 30 40 50)[3]\" → 30"
+  (mkrv (apl-run "(10 20 30 40 50)[3]"))
+  (list 30))
+
+(apl-test
+  "apl-run \"(⍳10)[5]\" → 5"
+  (mkrv (apl-run "(⍳10)[5]"))
+  (list 5))
+
+(apl-test
+  "apl-run \"A ← 100 200 300 ⋄ A[2]\" → 200"
+  (mkrv (apl-run "A ← 100 200 300 ⋄ A[2]"))
+  (list 200))
+
+(apl-test
+  "apl-run \"V ← ⍳10 ⋄ V[3]\" → 3"
+  (mkrv (apl-run "V ← ⍳10 ⋄ V[3]"))
+  (list 3))
+
+(apl-test
+  "apl-run \"(10 20 30)[1]\" → 10 (1-indexed)"
+  (mkrv (apl-run "(10 20 30)[1]"))
+  (list 10))
+
+(apl-test
+  "apl-run \"V ← 10 20 30 40 50 ⋄ V[3] + 1\" → 31"
+  (mkrv (apl-run "V ← 10 20 30 40 50 ⋄ V[3] + 1"))
+  (list 31))
+
+(apl-test
+  "apl-run \"(⍳5)[3] × 7\" → 21"
+  (mkrv (apl-run "(⍳5)[3] × 7"))
+  (list 21))
+
+(apl-test "decimal: 3.7 → 3.7" (mkrv (apl-run "3.7")) (list 3.7))
+
+(apl-test "decimal: ¯2.5 → -2.5" (mkrv (apl-run "¯2.5")) (list -2.5))
+
+(apl-test "decimal: 1.5 + 2.5 → 4" (mkrv (apl-run "1.5 + 2.5")) (list 4))
+
+(apl-test "decimal: ⌊3.7 → 3" (mkrv (apl-run "⌊ 3.7")) (list 3))
+
+(apl-test "decimal: ⌈3.7 → 4" (mkrv (apl-run "⌈ 3.7")) (list 4))
+
+(apl-test
+  "⎕← scalar passthrough"
+  (mkrv (apl-run "⎕← 42"))
+  (list 42))
+
+(apl-test
+  "⎕← vector passthrough"
+  (mkrv (apl-run "⎕← 1 2 3"))
+  (list 1 2 3))
+
+(apl-test
+  "string: 'abc' → 3-char vector"
+  (mkrv (apl-run "'abc'"))
+  (list "a" "b" "c"))
+
+(apl-test "string: 'a' is rank-0 scalar" (mksh (apl-run "'a'")) (list))
+
+(apl-test "string: 'hello' shape (5)" (mksh (apl-run "'hello'")) (list 5))
+
+(apl-test
+  "named-fn: f ← {⍺+⍵} ⋄ 3 f 4 → 7"
+  (mkrv (apl-run "f ← {⍺+⍵} ⋄ 3 f 4"))
+  (list 7))
+
+(apl-test
+  "named-fn monadic: sq ← {⍵×⍵} ⋄ sq 7 → 49"
+  (mkrv (apl-run "sq ← {⍵×⍵} ⋄ sq 7"))
+  (list 49))
+
+(apl-test
+  "named-fn dyadic: hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4 → 25"
+  (mkrv (apl-run "hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4"))
+  (list 25))
+
+(apl-test
+  "named-fn: dbl ← {⍵+⍵} ⋄ dbl ⍳5"
+  (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ dbl ⍳5"))
+  (list 2 4 6 8 10))
+
+(apl-test
+  "named-fn factorial via ∇ recursion"
+  (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
+  (list 120))
+
+(apl-test
+  "named-fn used twice in expr: dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"
+  (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4"))
+  (list 14))
+
+(apl-test
+  "named-fn with vector arg: neg ← {-⍵} ⋄ neg 1 2 3"
+  (mkrv (apl-run "neg ← {-⍵} ⋄ neg 1 2 3"))
+  (list -1 -2 -3))
+
+(apl-test
+  "multi-axis: M[2;2] → center"
+  (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[2;2]"))
+  (list 5))
+
+(apl-test
+  "multi-axis: M[1;] → first row"
+  (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
+  (list 1 2 3))
+
+(apl-test
+  "multi-axis: M[;2] → second column"
+  (mkrv (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[;2]"))
+  (list 2 5 8))
+
+(apl-test
+  "multi-axis: M[1 2;1 2] → 2x2 block"
+  (mkrv (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
+  (list 1 2 4 5))
+
+(apl-test
+  "multi-axis: M[1 2;1 2] shape (2 2)"
+  (mksh (apl-run "M ← (2 3) ⍴ ⍳6 ⋄ M[1 2;1 2]"))
+  (list 2 2))
+
+(apl-test
+  "multi-axis: M[;] full matrix"
+  (mkrv (apl-run "M ← (2 2) ⍴ 10 20 30 40 ⋄ M[;]"))
+  (list 10 20 30 40))
+
+(apl-test
+  "multi-axis: M[1;] shape collapsed"
+  (mksh (apl-run "M ← (3 3) ⍴ ⍳9 ⋄ M[1;]"))
+  (list 3))
+
+(apl-test
+  "multi-axis: select all rows of column 3"
+  (mkrv (apl-run "M ← (4 3) ⍴ 1 2 3 4 5 6 7 8 9 10 11 12 ⋄ M[;3]"))
+  (list 3 6 9 12))
+
+(apl-test
+  "train: mean = (+/÷≢) on 1..5"
+  (mkrv (apl-run "(+/÷≢) 1 2 3 4 5"))
+  (list 3))
+
+(apl-test
+  "train: mean of 2 4 6 8 10"
+  (mkrv (apl-run "(+/÷≢) 2 4 6 8 10"))
+  (list 6))
+
+(apl-test
+  "train 2-atop: (- ⌊) 5 → -5"
+  (mkrv (apl-run "(- ⌊) 5"))
+  (list -5))
+
+(apl-test
+  "train 3-fork dyadic: 2(+×-)5 → -21"
+  (mkrv (apl-run "2 (+ × -) 5"))
+  (list -21))
+
+(apl-test
+  "train: range = (⌈/-⌊/) on vector"
+  (mkrv (apl-run "(⌈/-⌊/) 3 1 4 1 5 9 2 6"))
+  (list 8))
+
+(apl-test
+  "train: mean of ⍳10 has shape ()"
+  (mksh (apl-run "(+/÷≢) ⍳10"))
+  (list))
+
+(apl-test
+  "compress: 1 0 1 0 1 / 10 20 30 40 50"
+  (mkrv (apl-run "1 0 1 0 1 / 10 20 30 40 50"))
+  (list 10 30 50))
+
+(apl-test
+  "compress: empty mask → empty"
+  (mkrv (apl-run "0 0 0 / 1 2 3"))
+  (list))
+
+(apl-test
+  "primes via classic idiom (multi-stmt)"
+  (mkrv (apl-run "P ← ⍳ 30 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
+  (list 2 3 5 7 11 13 17 19 23 29))
+
+(apl-test
+  "primes via classic idiom (n=20)"
+  (mkrv (apl-run "P ← ⍳ 20 ⋄ (2 = +⌿ 0 = P ∘.| P) / P"))
+  (list 2 3 5 7 11 13 17 19))
+
+(apl-test
+  "compress: filter even values"
+  (mkrv (apl-run "(0 = 2 | 1 2 3 4 5 6) / 1 2 3 4 5 6"))
+  (list 2 4 6))
+
+(apl-test "inline-assign: x ← 5" (mkrv (apl-run "x ← 5")) (list 5))
+
+(apl-test
+  "inline-assign: (2×x) + x←10 → 30"
+  (mkrv (apl-run "(2 × x) + x ← 10"))
+  (list 30))
+
+(apl-test
+  "inline-assign primes one-liner: (2=+⌿0=a∘.|a)/a←⍳30"
+  (mkrv (apl-run "(2 = +⌿ 0 = a ∘.| a) / a ← ⍳ 30"))
+  (list 2 3 5 7 11 13 17 19 23 29))
+
+(apl-test
+  "inline-assign: x is reusable — x + x ← 7 → 14"
+  (mkrv (apl-run "x + x ← 7"))
+  (list 14))
+
+(apl-test
+  "inline-assign in dfn: f ← {x + x ← ⍵} ⋄ f 8 → 16"
+  (mkrv (apl-run "f ← {x + x ← ⍵} ⋄ f 8"))
+  (list 16))
+
+(begin (apl-rng-seed! 42) nil)
+
+(apl-test
+  "?10 with seed 42 → 8 (deterministic)"
+  (mkrv (apl-run "?10"))
+  (list 8))
+
+(apl-test "?10 next call → 5" (mkrv (apl-run "?10")) (list 5))
+
+(apl-test
+  "?100 stays in range"
+  (let ((v (first (mkrv (apl-run "?100"))))) (and (>= v 1) (<= v 100)))
+  true)
+
+(begin (apl-rng-seed! 42) nil)
+
+(apl-test
+  "?10 with re-seed 42 → 8 (reproducible)"
+  (mkrv (apl-run "?10"))
+  (list 8))
+
+(apl-test
+  "apl-run-file: load primes.apl returns dfn AST"
+  (first (apl-run-file "lib/apl/tests/programs/primes.apl"))
+  :dfn)
+
+(apl-test
+  "apl-run-file: life.apl parses without error"
+  (first (apl-run-file "lib/apl/tests/programs/life.apl"))
+  :dfn)
+
+(apl-test
+  "apl-run-file: quicksort.apl parses without error"
+  (first (apl-run-file "lib/apl/tests/programs/quicksort.apl"))
+  :dfn)
+
+(apl-test
+  "apl-run-file: source-then-call returns primes count"
+  (mksh
+    (apl-run
+      (str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 30")))
+  (list 10))
+
+(apl-test
+  "primes one-liner with ⍵-rebind: primes 30"
+  (mkrv
+    (apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 30"))
+  (list 2 3 5 7 11 13 17 19 23 29))
+
+(apl-test
+  "primes one-liner: primes 50"
+  (mkrv
+    (apl-run "primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵} ⋄ primes 50"))
+  (list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
+
+(apl-test
+  "primes.apl loaded + called via apl-run-file"
+  (mkrv
+    (apl-run
+      (str (file-read "lib/apl/tests/programs/primes.apl") " ⋄ primes 20")))
+  (list 2 3 5 7 11 13 17 19))
+
+(apl-test
+  "primes.apl loaded — count of primes ≤ 100"
+  (first
+    (mksh
+      (apl-run
+        (str
+          (file-read "lib/apl/tests/programs/primes.apl")
+          " ⋄ primes 100"))))
+  25)
+
+(apl-test
+  "⍉ monadic transpose 2x3 → 3x2"
+  (mkrv (apl-run "⍉ (2 3) ⍴ ⍳6"))
+  (list 1 4 2 5 3 6))
+
+(apl-test
+  "⍉ transpose shape (3 2)"
+  (mksh (apl-run "⍉ (2 3) ⍴ ⍳6"))
+  (list 3 2))
+
+(apl-test "⊢ monadic identity" (mkrv (apl-run "⊢ 1 2 3")) (list 1 2 3))
+
+(apl-test
+  "5 ⊣ 1 2 3 → 5 (left)"
+  (mkrv (apl-run "5 ⊣ 1 2 3"))
+  (list 5))
+
+(apl-test
+  "5 ⊢ 1 2 3 → 1 2 3 (right)"
+  (mkrv (apl-run "5 ⊢ 1 2 3"))
+  (list 1 2 3))
+
+(apl-test "⍕ 42 → \"42\" (alias for ⎕FMT)" (apl-run "⍕ 42") "42")

lib/apl/tests/programs-e2e.sx

@@ -0,0 +1,96 @@
+; End-to-end tests of the classic-program archetypes — running APL
+; source through the full pipeline (tokenize → parse → eval-ast → runtime).
+;
+; These mirror the algorithms documented in lib/apl/tests/programs/*.apl
+; but use forms our pipeline supports today (named functions instead of
+; the inline ⍵← rebinding idiom; multi-stmt over single one-liners).
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+
+; ---------- factorial via ∇ recursion (cf. n-queens style) ----------
+
+(apl-test
+  "e2e: factorial 5! = 120"
+  (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5"))
+  (list 120))
+
+(apl-test
+  "e2e: factorial 7! = 5040"
+  (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 7"))
+  (list 5040))
+
+(apl-test
+  "e2e: factorial via ×/⍳N (no recursion)"
+  (mkrv (apl-run "fact ← {×/⍳⍵} ⋄ fact 6"))
+  (list 720))
+
+; ---------- sum / triangular numbers (sum-1..N) ----------
+
+(apl-test
+  "e2e: triangular(10) = 55"
+  (mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 10"))
+  (list 55))
+
+(apl-test
+  "e2e: triangular(100) = 5050"
+  (mkrv (apl-run "tri ← {+/⍳⍵} ⋄ tri 100"))
+  (list 5050))
+
+; ---------- sum of squares ----------
+
+(apl-test
+  "e2e: sum-of-squares 1..5 = 55"
+  (mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳5"))
+  (list 55))
+
+(apl-test
+  "e2e: sum-of-squares 1..10 = 385"
+  (mkrv (apl-run "ss ← {+/⍵×⍵} ⋄ ss ⍳10"))
+  (list 385))
+
+; ---------- divisor-counting (prime-sieve building blocks) ----------
+
+(apl-test
+  "e2e: divisor counts 1..5 via outer mod"
+  (mkrv (apl-run "P ← ⍳ 5 ⋄ +⌿ 0 = P ∘.| P"))
+  (list 1 2 2 3 2))
+
+(apl-test
+  "e2e: divisor counts 1..10"
+  (mkrv (apl-run "P ← ⍳ 10 ⋄ +⌿ 0 = P ∘.| P"))
+  (list 1 2 2 3 2 4 2 4 3 4))
+
+(apl-test
+  "e2e: prime-mask 1..10 (count==2)"
+  (mkrv (apl-run "P ← ⍳ 10 ⋄ 2 = +⌿ 0 = P ∘.| P"))
+  (list 0 1 1 0 1 0 1 0 0 0))
+
+; ---------- monadic primitives chained ----------
+
+(apl-test
+  "e2e: sum of |abs| = 15"
+  (mkrv (apl-run "+/|¯1 ¯2 ¯3 ¯4 ¯5"))
+  (list 15))
+
+(apl-test
+  "e2e: max of squares 1..6"
+  (mkrv (apl-run "⌈/(⍳6)×⍳6"))
+  (list 36))
+
+; ---------- nested named functions ----------
+
+(apl-test
+  "e2e: compose dbl and sq via two named fns"
+  (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ sq ← {⍵×⍵} ⋄ sq dbl 3"))
+  (list 36))
+
+(apl-test
+  "e2e: max-of-two as named dyadic fn"
+  (mkrv (apl-run "mx ← {⍺⌈⍵} ⋄ 5 mx 3"))
+  (list 5))
+
+(apl-test
+  "e2e: sqrt-via-newton 1 step from 1 → 2.5"
+  (mkrv (apl-run "step ← {(⍵+⍺÷⍵)÷2} ⋄ 4 step 1"))
+  (list 2.5))

lib/apl/tests/programs.sx

@@ -0,0 +1,304 @@
+; Tests for classic APL programs (lib/apl/tests/programs/*.apl).
+; Programs are showcase APL source; runtime impl is in lib/apl/runtime.sx.
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+
+; ===== primes (Sieve of Eratosthenes) =====
+
+(apl-test "primes 1 → empty" (mkrv (apl-primes 1)) (list))
+
+(apl-test "primes 2 → just 2" (mkrv (apl-primes 2)) (list 2))
+
+(apl-test "primes 10 → 2 3 5 7" (mkrv (apl-primes 10)) (list 2 3 5 7))
+
+(apl-test
+  "primes 20 → 2 3 5 7 11 13 17 19"
+  (mkrv (apl-primes 20))
+  (list 2 3 5 7 11 13 17 19))
+
+(apl-test
+  "primes 30"
+  (mkrv (apl-primes 30))
+  (list 2 3 5 7 11 13 17 19 23 29))
+
+(apl-test
+  "primes 50"
+  (mkrv (apl-primes 50))
+  (list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47))
+
+(apl-test "primes 7 length" (first (mksh (apl-primes 7))) 4)
+
+(apl-test "primes 100 has 25 primes" (first (mksh (apl-primes 100))) 25)
+
+; ===== compress helper sanity =====
+
+(apl-test
+  "compress 1 0 1 0 1 / 10 20 30 40 50"
+  (mkrv
+    (apl-compress
+      (make-array (list 5) (list 1 0 1 0 1))
+      (make-array (list 5) (list 10 20 30 40 50))))
+  (list 10 30 50))
+
+(apl-test
+  "compress all-zero mask → empty"
+  (mkrv
+    (apl-compress
+      (make-array (list 3) (list 0 0 0))
+      (make-array (list 3) (list 1 2 3))))
+  (list))
+
+(apl-test
+  "compress all-one mask → full vector"
+  (mkrv
+    (apl-compress
+      (make-array (list 3) (list 1 1 1))
+      (make-array (list 3) (list 1 2 3))))
+  (list 1 2 3))
+
+(apl-test
+  "life: empty 5x5 stays empty"
+  (mkrv
+    (apl-life-step
+      (make-array
+        (list 5 5)
+        (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))))
+  (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+
+(apl-test
+  "life: horizontal blinker → vertical blinker"
+  (mkrv
+    (apl-life-step
+      (make-array
+        (list 5 5)
+        (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))))
+  (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))
+
+(apl-test
+  "life: vertical blinker → horizontal blinker"
+  (mkrv
+    (apl-life-step
+      (make-array
+        (list 5 5)
+        (list 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0))))
+  (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
+
+(apl-test
+  "life: blinker has period 2"
+  (mkrv
+    (apl-life-step
+      (apl-life-step
+        (make-array
+          (list 5 5)
+          (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0)))))
+  (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))
+
+(apl-test
+  "life: 2x2 block stable on 5x5"
+  (mkrv
+    (apl-life-step
+      (make-array
+        (list 5 5)
+        (list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0))))
+  (list 0 0 0 0 0 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0))
+
+(apl-test
+  "life: shape preserved"
+  (mksh
+    (apl-life-step
+      (make-array
+        (list 5 5)
+        (list 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0))))
+  (list 5 5))
+
+(apl-test
+  "life: glider on 6x6 advances"
+  (mkrv
+    (apl-life-step
+      (make-array
+        (list 6 6)
+        (list
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          1
+          0
+          0
+          0
+          0
+          0
+          0
+          1
+          0
+          0
+          0
+          1
+          1
+          1
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0
+          0))))
+  (list
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    1
+    0
+    1
+    0
+    0
+    0
+    0
+    1
+    1
+    0
+    0
+    0
+    0
+    1
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0
+    0))
+
+(apl-test
+  "mandelbrot c=0 stays bounded"
+  (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0)) 100))
+  (list 100))
+
+(apl-test
+  "mandelbrot c=-1 cycle bounded"
+  (mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1)) 100))
+  (list 100))
+
+(apl-test
+  "mandelbrot c=-2 boundary stays bounded"
+  (mkrv (apl-mandelbrot-1d (make-array (list 1) (list -2)) 100))
+  (list 100))
+
+(apl-test
+  "mandelbrot c=0.25 boundary stays bounded"
+  (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.25)) 100))
+  (list 100))
+
+(apl-test
+  "mandelbrot c=1 escapes at iter 3"
+  (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 1)) 100))
+  (list 3))
+
+(apl-test
+  "mandelbrot c=0.5 escapes at iter 5"
+  (mkrv (apl-mandelbrot-1d (make-array (list 1) (list 0.5)) 100))
+  (list 5))
+
+(apl-test
+  "mandelbrot batched grid (rank-polymorphic)"
+  (mkrv (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10))
+  (list 10 10 10 3 2))
+
+(apl-test
+  "mandelbrot batched preserves shape"
+  (mksh (apl-mandelbrot-1d (make-array (list 5) (list -2 -1 0 1 2)) 10))
+  (list 5))
+
+(apl-test
+  "mandelbrot c=-1.5 stays bounded"
+  (mkrv (apl-mandelbrot-1d (make-array (list 1) (list -1.5)) 100))
+  (list 100))
+
+(apl-test "queens 1 → 1 solution" (mkrv (apl-queens 1)) (list 1))
+
+(apl-test "queens 2 → 0 solutions" (mkrv (apl-queens 2)) (list 0))
+
+(apl-test "queens 3 → 0 solutions" (mkrv (apl-queens 3)) (list 0))
+
+(apl-test "queens 4 → 2 solutions" (mkrv (apl-queens 4)) (list 2))
+
+(apl-test "queens 5 → 10 solutions" (mkrv (apl-queens 5)) (list 10))
+
+(apl-test "queens 6 → 4 solutions" (mkrv (apl-queens 6)) (list 4))
+
+(apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40))
+
+(apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6)
+
+(apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24)
+
+(apl-test
+  "quicksort empty"
+  (mkrv (apl-quicksort (make-array (list 0) (list))))
+  (list))
+
+(apl-test
+  "quicksort single"
+  (mkrv (apl-quicksort (make-array (list 1) (list 42))))
+  (list 42))
+
+(apl-test
+  "quicksort already sorted"
+  (mkrv (apl-quicksort (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 3 4 5))
+
+(apl-test
+  "quicksort reverse sorted"
+  (mkrv (apl-quicksort (make-array (list 5) (list 5 4 3 2 1))))
+  (list 1 2 3 4 5))
+
+(apl-test
+  "quicksort with duplicates"
+  (mkrv (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2))))
+  (list 1 1 2 3 4 5 9))
+
+(apl-test
+  "quicksort all equal"
+  (mkrv (apl-quicksort (make-array (list 5) (list 7 7 7 7 7))))
+  (list 7 7 7 7 7))
+
+(apl-test
+  "quicksort negatives"
+  (mkrv (apl-quicksort (make-array (list 5) (list -3 1 -1 2 0))))
+  (list -3 -1 0 1 2))
+
+(apl-test
+  "quicksort 11-element pi"
+  (mkrv
+    (apl-quicksort (make-array (list 11) (list 3 1 4 1 5 9 2 6 5 3 5))))
+  (list 1 1 2 3 3 4 5 5 5 6 9))
+
+(apl-test
+  "quicksort preserves length"
+  (first
+    (mksh (apl-quicksort (make-array (list 7) (list 3 1 4 1 5 9 2)))))
+  7)

lib/apl/tests/programs/life.apl

@@ -0,0 +1,22 @@
+⍝ Conway's Game of Life — toroidal one-liner
+⍝
+⍝ The classic Roger Hui formulation:
+⍝   life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵}
+⍝
+⍝ Read right-to-left:
+⍝   ⊂⍵                : enclose the board (so it's a single scalar item)
+⍝   ¯1 0 1 ⌽¨ ⊂⍵      : produce 3 horizontally-shifted copies
+⍝   ¯1 0 1 ∘.⊖ …      : outer-product with vertical shifts → 3×3 = 9 shifts
+⍝   +/ +/ …           : sum the 9 boards element-wise → neighbor-count + self
+⍝   3 4 = …           : boolean — count is exactly 3 or exactly 4
+⍝   1 ⍵ ∨.∧ …         : "alive next" iff (count=3) or (alive AND count=4)
+⍝   ⊃ …               : disclose back to a 2D board
+⍝
+⍝ Rules in plain language:
+⍝   - dead cell + 3 live neighbors → born
+⍝   - live cell + 2 or 3 live neighbors → survives
+⍝   - all else → dies
+⍝
+⍝ Toroidal: edges wrap (rotate is cyclic).
+
+life ← {⊃1 ⍵ ∨.∧ 3 4 = +/ +/ ¯1 0 1 ∘.⊖ ¯1 0 1 ⌽¨ ⊂⍵}

lib/apl/tests/programs/mandelbrot.apl

@@ -0,0 +1,29 @@
+⍝ Mandelbrot — real-axis subset
+⍝
+⍝ For complex c, the Mandelbrot set is { c : |z_n| stays bounded } where
+⍝   z_0 = 0, z_{n+1} = z_n² + c.
+⍝ Restricting c (and z) to ℝ gives the segment c ∈ [-2, 1/4]
+⍝ where the iteration stays bounded.
+⍝
+⍝ Rank-polymorphic batched-iteration form:
+⍝   mandelbrot ← {⍵ ⍵⍵ ⍺⍺ +,(⍺⍺ × ⍺⍺) }
+⍝
+⍝ Pseudocode (as we don't have ⎕ system fns yet):
+⍝   z      ← 0×c                             ⍝ start at zero
+⍝   alive  ← 1+0×c                           ⍝ all "still in"
+⍝   for k iterations:
+⍝     alive ← alive ∧ 4 ≥ z×z                ⍝ still bounded?
+⍝     z     ← alive × c + z×z                ⍝ freeze escaped via mask
+⍝     count ← count + alive                  ⍝ tally surviving iters
+⍝
+⍝ Examples (count after 100 iterations):
+⍝   c=0      : 100  (z stays at 0)
+⍝   c=-1     : 100  (cycles 0,-1,0,-1,...)
+⍝   c=-2     : 100  (settles at 2 — boundary)
+⍝   c=0.25   : 100  (boundary — converges to 0.5)
+⍝   c=0.5    : 5    (escapes by iteration 6)
+⍝   c=1      : 3    (escapes quickly)
+⍝
+⍝ Real-axis Mandelbrot set: bounded for c ∈ [-2, 0.25].
+
+mandelbrot ← {z←alive←count←0×⍵ ⋄ {alive←alive∧4≥z×z ⋄ z←alive×⍵+z×z ⋄ count+←alive}⍣⍺⊢⍵}

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

@@ -0,0 +1,18 @@
+⍝ N-Queens — count solutions to placing N non-attacking queens on N×N
+⍝
+⍝ A solution is encoded as a permutation P of 1..N where P[i] is the
+⍝ column of the queen in row i.  Rows and columns are then automatically
+⍝ unique (it's a permutation).  We must additionally rule out queens
+⍝ sharing a diagonal: |i-j| = |P[i]-P[j]| for any pair.
+⍝
+⍝ Backtracking via reduce — the classic Roger Hui style:
+⍝   queens ← {≢{⍵,¨⍨↓(0=∊(¨⍳⍴⍵)≠.+|⍵)/⍳⍴⍵}/(⍳⍵)⍴⊂⍳⍵}
+⍝
+⍝ Plain reading:
+⍝   permute 1..N, keep those where no two queens share a diagonal.
+⍝
+⍝ Known solution counts (OEIS A000170):
+⍝     N    1   2   3   4   5   6   7    8    9    10
+⍝   q(N)   1   0   0   2  10   4  40   92  352   724
+
+queens ← {≢({(i j)←⍺⍵ ⋄ (|i-j)≠|(P[i])-(P[j])}⌿permutations ⍵)}

lib/apl/tests/programs/primes.apl

@@ -0,0 +1,16 @@
+⍝ Sieve of Eratosthenes — the classic APL one-liner
+⍝   primes ← (2=+⌿0=A∘.|A)/A←⍳N
+⍝
+⍝ Read right-to-left:
+⍝   A ← ⍳N        : A is 1..N
+⍝   A∘.|A         : outer-product residue table — M[i,j] = A[j] mod A[i]
+⍝   0=...         : boolean — true where A[i] divides A[j]
+⍝   +⌿...         : column sums — count of divisors per A[j]
+⍝   2=...         : true for numbers with exactly 2 divisors (1 and self) → primes
+⍝   .../A         : compress — select A[j] where mask[j] is true
+⍝
+⍝ Examples:
+⍝   primes 10  →  2 3 5 7
+⍝   primes 30  →  2 3 5 7 11 13 17 19 23 29
+
+primes ← {(2=+⌿0=⍵∘.|⍵)/⍵←⍳⍵}

lib/apl/tests/programs/quicksort.apl

@@ -0,0 +1,25 @@
+⍝ Quicksort — the classic Roger Hui one-liner
+⍝
+⍝ Q ← {1≥≢⍵:⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p←⍵⌷⍨?≢⍵}
+⍝
+⍝ Read right-to-left:
+⍝   ?≢⍵          : pick a random index in 1..length
+⍝   ⍵⌷⍨…         : take that element as pivot p
+⍝   ⍵>p          : boolean — elements greater than pivot
+⍝   ∇⍵⌿⍨…        : recursively sort the > partition
+⍝   (p=⍵)/⍵      : keep elements equal to pivot
+⍝   ⍵<p          : boolean — elements less than pivot
+⍝   ∇⍵⌿⍨…        : recursively sort the < partition
+⍝   ,            : catenate ⟨less⟩ ⟨equal⟩ ⟨greater⟩
+⍝   1≥≢⍵:⍵       : guard — base case for length ≤ 1
+⍝
+⍝ Stability: not stable on duplicates (but eq-class is preserved as a block).
+⍝ Worst case O(N²) on already-sorted input with deterministic pivot;
+⍝ randomized pivot selection gives expected O(N log N).
+⍝
+⍝ Examples:
+⍝   Q 3 1 4 1 5 9 2 6 5 3 5    →  1 1 2 3 3 4 5 5 5 6 9
+⍝   Q ⍳0                        →  ⍬   (empty)
+⍝   Q ,42                       →  42
+
+quicksort ← {1≥≢⍵:⍵ ⋄ p←⍵⌷⍨?≢⍵ ⋄ (∇⍵⌿⍨⍵<p),(p=⍵)/⍵,∇⍵⌿⍨⍵>p}

lib/apl/tests/scalar.sx

@@ -0,0 +1,369 @@
+; APL scalar primitives test suite
+; Requires: lib/apl/runtime.sx
+
+; ============================================================
+; Test framework
+; ============================================================
+
+(define apl-rt-count 0)
+(define apl-rt-pass 0)
+(define apl-rt-fails (list))
+
+; Element-wise list comparison (handles both List and ListRef)
+(define
+  lists-eq
+  (fn
+    (a b)
+    (if
+      (and (= (len a) 0) (= (len b) 0))
+      true
+      (if
+        (not (= (len a) (len b)))
+        false
+        (if
+          (not (= (first a) (first b)))
+          false
+          (lists-eq (rest a) (rest b)))))))
+
+(define
+  apl-rt-test
+  (fn
+    (name actual expected)
+    (begin
+      (set! apl-rt-count (+ apl-rt-count 1))
+      (if
+        (equal? actual expected)
+        (set! apl-rt-pass (+ apl-rt-pass 1))
+        (append! apl-rt-fails {:actual actual :expected expected :name name})))))
+
+; Test that a ravel equals a plain list (handles ListRef vs List)
+(define
+  ravel-test
+  (fn
+    (name arr expected-list)
+    (begin
+      (set! apl-rt-count (+ apl-rt-count 1))
+      (let
+        ((actual (get arr :ravel)))
+        (if
+          (lists-eq actual expected-list)
+          (set! apl-rt-pass (+ apl-rt-pass 1))
+          (append! apl-rt-fails {:actual actual :expected expected-list :name name}))))))
+
+; Test a scalar ravel value (single-element list)
+(define
+  scalar-test
+  (fn (name arr expected-val) (ravel-test name arr (list expected-val))))
+
+; ============================================================
+; Array constructor tests
+; ============================================================
+
+(apl-rt-test
+  "scalar: shape is empty list"
+  (get (apl-scalar 5) :shape)
+  (list))
+
+(apl-rt-test
+  "scalar: ravel has one element"
+  (get (apl-scalar 5) :ravel)
+  (list 5))
+
+(apl-rt-test "scalar: rank 0" (array-rank (apl-scalar 5)) 0)
+
+(apl-rt-test "scalar? returns true for scalar" (scalar? (apl-scalar 5)) true)
+
+(apl-rt-test "scalar: zero" (get (apl-scalar 0) :ravel) (list 0))
+
+(apl-rt-test
+  "vector: shape is (3)"
+  (get (apl-vector (list 1 2 3)) :shape)
+  (list 3))
+
+(apl-rt-test
+  "vector: ravel matches input"
+  (get (apl-vector (list 1 2 3)) :ravel)
+  (list 1 2 3))
+
+(apl-rt-test "vector: rank 1" (array-rank (apl-vector (list 1 2 3))) 1)
+
+(apl-rt-test
+  "scalar? returns false for vector"
+  (scalar? (apl-vector (list 1 2 3)))
+  false)
+
+(apl-rt-test
+  "make-array: rank 2"
+  (array-rank (make-array (list 2 3) (list 1 2 3 4 5 6)))
+  2)
+
+(apl-rt-test
+  "make-array: shape"
+  (get (make-array (list 2 3) (list 1 2 3 4 5 6)) :shape)
+  (list 2 3))
+
+(apl-rt-test
+  "array-ref: first element"
+  (array-ref (apl-vector (list 10 20 30)) 0)
+  10)
+
+(apl-rt-test
+  "array-ref: last element"
+  (array-ref (apl-vector (list 10 20 30)) 2)
+  30)
+
+(apl-rt-test "enclose: wraps in rank-0" (scalar? (enclose 42)) true)
+
+(apl-rt-test
+  "enclose: ravel contains value"
+  (get (enclose 42) :ravel)
+  (list 42))
+
+(apl-rt-test "disclose: unwraps rank-0" (disclose (enclose 42)) 42)
+
+; ============================================================
+; Shape primitive tests
+; ============================================================
+
+(ravel-test "⍴ scalar: returns empty" (apl-shape (apl-scalar 5)) (list))
+
+(ravel-test
+  "⍴ vector: returns (3)"
+  (apl-shape (apl-vector (list 1 2 3)))
+  (list 3))
+
+(ravel-test
+  "⍴ matrix: returns (2 3)"
+  (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6)))
+  (list 2 3))
+
+(ravel-test
+  ", ravel scalar: vector of 1"
+  (apl-ravel (apl-scalar 5))
+  (list 5))
+
+(apl-rt-test
+  ", ravel vector: same elements"
+  (get (apl-ravel (apl-vector (list 1 2 3))) :ravel)
+  (list 1 2 3))
+
+(apl-rt-test
+  ", ravel matrix: all elements"
+  (get (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))) :ravel)
+  (list 1 2 3 4 5 6))
+
+(scalar-test "≢ tally scalar: 1" (apl-tally (apl-scalar 5)) 1)
+
+(scalar-test
+  "≢ tally vector: first dimension"
+  (apl-tally (apl-vector (list 1 2 3)))
+  3)
+
+(scalar-test
+  "≢ tally matrix: first dimension"
+  (apl-tally (make-array (list 2 3) (list 1 2 3 4 5 6)))
+  2)
+
+(scalar-test
+  "≡ depth flat vector: 0"
+  (apl-depth (apl-vector (list 1 2 3)))
+  0)
+
+(scalar-test "≡ depth scalar: 0" (apl-depth (apl-scalar 5)) 0)
+
+(scalar-test
+  "≡ depth nested (enclose in vector): 1"
+  (apl-depth (enclose (apl-vector (list 1 2 3))))
+  1)
+
+; ============================================================
+; ⍳ iota tests
+; ============================================================
+
+(apl-rt-test
+  "⍳5 shape is (5)"
+  (get (apl-iota (apl-scalar 5)) :shape)
+  (list 5))
+
+(ravel-test "⍳5 ravel is 1..5" (apl-iota (apl-scalar 5)) (list 1 2 3 4 5))
+
+(ravel-test "⍳1 ravel is (1)" (apl-iota (apl-scalar 1)) (list 1))
+
+(ravel-test "⍳0 ravel is empty" (apl-iota (apl-scalar 0)) (list))
+
+(apl-rt-test "apl-io is 1" apl-io 1)
+
+; ============================================================
+; Arithmetic broadcast tests
+; ============================================================
+
+(scalar-test
+  "+ scalar scalar: 3+4=7"
+  (apl-add (apl-scalar 3) (apl-scalar 4))
+  7)
+
+(ravel-test
+  "+ vector scalar: +10"
+  (apl-add (apl-vector (list 1 2 3)) (apl-scalar 10))
+  (list 11 12 13))
+
+(ravel-test
+  "+ scalar vector: 10+"
+  (apl-add (apl-scalar 10) (apl-vector (list 1 2 3)))
+  (list 11 12 13))
+
+(ravel-test
+  "+ vector vector"
+  (apl-add (apl-vector (list 1 2 3)) (apl-vector (list 4 5 6)))
+  (list 5 7 9))
+
+(scalar-test "- negate monadic" (apl-neg-m (apl-scalar 5)) -5)
+
+(scalar-test "- dyadic 10-3=7" (apl-sub (apl-scalar 10) (apl-scalar 3)) 7)
+
+(scalar-test "× signum positive" (apl-signum (apl-scalar 7)) 1)
+
+(scalar-test "× signum negative" (apl-signum (apl-scalar -3)) -1)
+
+(scalar-test "× signum zero" (apl-signum (apl-scalar 0)) 0)
+
+(scalar-test "× dyadic 3×4=12" (apl-mul (apl-scalar 3) (apl-scalar 4)) 12)
+
+(scalar-test "÷ reciprocal 1÷4=0.25" (apl-recip (apl-scalar 4)) 0.25)
+
+(scalar-test
+  "÷ dyadic 10÷4=2.5"
+  (apl-div (apl-scalar 10) (apl-scalar 4))
+  2.5)
+
+(scalar-test "⌈ ceiling 2.3→3" (apl-ceil (apl-scalar 2.3)) 3)
+
+(scalar-test "⌈ max 3 5 → 5" (apl-max (apl-scalar 3) (apl-scalar 5)) 5)
+
+(scalar-test "⌊ floor 2.7→2" (apl-floor (apl-scalar 2.7)) 2)
+
+(scalar-test "⌊ min 3 5 → 3" (apl-min (apl-scalar 3) (apl-scalar 5)) 3)
+
+(scalar-test "* exp monadic e^0=1" (apl-exp (apl-scalar 0)) 1)
+
+(scalar-test
+  "* pow dyadic 2^10=1024"
+  (apl-pow (apl-scalar 2) (apl-scalar 10))
+  1024)
+
+(scalar-test "⍟ ln 1=0" (apl-ln (apl-scalar 1)) 0)
+
+(scalar-test "| abs positive" (apl-abs (apl-scalar 5)) 5)
+
+(scalar-test "| abs negative" (apl-abs (apl-scalar -5)) 5)
+
+(scalar-test "| mod 3|7=1" (apl-mod (apl-scalar 3) (apl-scalar 7)) 1)
+
+(scalar-test "! factorial 5!=120" (apl-fact (apl-scalar 5)) 120)
+
+(scalar-test "! factorial 0!=1" (apl-fact (apl-scalar 0)) 1)
+
+(scalar-test
+  "! binomial 4 choose 2 = 6"
+  (apl-binomial (apl-scalar 4) (apl-scalar 2))
+  6)
+
+(scalar-test "○ pi×0=0" (apl-pi-times (apl-scalar 0)) 0)
+
+(scalar-test "○ trig sin(0)=0" (apl-trig (apl-scalar 1) (apl-scalar 0)) 0)
+
+(scalar-test "○ trig cos(0)=1" (apl-trig (apl-scalar 2) (apl-scalar 0)) 1)
+
+; ============================================================
+; Comparison tests
+; ============================================================
+
+(scalar-test "< less: 3<5 → 1" (apl-lt (apl-scalar 3) (apl-scalar 5)) 1)
+
+(scalar-test "< less: 5<3 → 0" (apl-lt (apl-scalar 5) (apl-scalar 3)) 0)
+
+(scalar-test
+  "≤ le equal: 3≤3 → 1"
+  (apl-le (apl-scalar 3) (apl-scalar 3))
+  1)
+
+(scalar-test "= eq: 5=5 → 1" (apl-eq (apl-scalar 5) (apl-scalar 5)) 1)
+
+(scalar-test "= ne: 5=6 → 0" (apl-eq (apl-scalar 5) (apl-scalar 6)) 0)
+
+(scalar-test "≥ ge: 5≥3 → 1" (apl-ge (apl-scalar 5) (apl-scalar 3)) 1)
+
+(scalar-test "> gt: 5>3 → 1" (apl-gt (apl-scalar 5) (apl-scalar 3)) 1)
+
+(scalar-test "≠ ne: 5≠3 → 1" (apl-ne (apl-scalar 5) (apl-scalar 3)) 1)
+
+(ravel-test
+  "comparison vector broadcast: 1 2 3 < 2 → 1 0 0"
+  (apl-lt (apl-vector (list 1 2 3)) (apl-scalar 2))
+  (list 1 0 0))
+
+; ============================================================
+; Logical tests
+; ============================================================
+
+(scalar-test "~ not 0 → 1" (apl-not (apl-scalar 0)) 1)
+
+(scalar-test "~ not 1 → 0" (apl-not (apl-scalar 1)) 0)
+
+(ravel-test
+  "~ not vector: 1 0 1 0 → 0 1 0 1"
+  (apl-not (apl-vector (list 1 0 1 0)))
+  (list 0 1 0 1))
+
+(scalar-test
+  "∧ and 1∧1 → 1"
+  (apl-and (apl-scalar 1) (apl-scalar 1))
+  1)
+
+(scalar-test
+  "∧ and 1∧0 → 0"
+  (apl-and (apl-scalar 1) (apl-scalar 0))
+  0)
+
+(scalar-test "∨ or 0∨1 → 1" (apl-or (apl-scalar 0) (apl-scalar 1)) 1)
+
+(scalar-test "∨ or 0∨0 → 0" (apl-or (apl-scalar 0) (apl-scalar 0)) 0)
+
+(scalar-test
+  "⍱ nor 0⍱0 → 1"
+  (apl-nor (apl-scalar 0) (apl-scalar 0))
+  1)
+
+(scalar-test
+  "⍱ nor 1⍱0 → 0"
+  (apl-nor (apl-scalar 1) (apl-scalar 0))
+  0)
+
+(scalar-test
+  "⍲ nand 1⍲1 → 0"
+  (apl-nand (apl-scalar 1) (apl-scalar 1))
+  0)
+
+(scalar-test
+  "⍲ nand 1⍲0 → 1"
+  (apl-nand (apl-scalar 1) (apl-scalar 0))
+  1)
+
+; ============================================================
+; plus-m identity test
+; ============================================================
+
+(scalar-test "+ monadic identity: +5 → 5" (apl-plus-m (apl-scalar 5)) 5)
+
+; ============================================================
+; Summary
+; ============================================================
+
+(define
+  apl-scalar-summary
+  (str
+    "scalar "
+    apl-rt-pass
+    "/"
+    apl-rt-count
+    (if (= (len apl-rt-fails) 0) "" (str " FAILS: " apl-rt-fails))))

lib/apl/tests/structural.sx

@@ -0,0 +1,608 @@
+;; lib/apl/tests/structural.sx — Phase 3: structural primitives
+;; Tests for: apl-reshape, apl-ravel, apl-transpose, apl-transpose-dyadic
+;; Loaded after runtime.sx; shares apl-test / apl-test-pass / apl-test-fail.
+
+(define rv (fn (arr) (get arr :ravel)))
+(define sh (fn (arr) (get arr :shape)))
+
+;; ---------------------------------------------------------------------------
+;; 1. Ravel (monadic ,)
+;; ---------------------------------------------------------------------------
+(apl-test "ravel scalar" (rv (apl-ravel (apl-scalar 5))) (list 5))
+
+(apl-test
+  "ravel vector"
+  (rv (apl-ravel (make-array (list 3) (list 1 2 3))))
+  (list 1 2 3))
+
+(apl-test
+  "ravel matrix"
+  (rv (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2 3 4 5 6))
+
+(apl-test
+  "ravel shape is rank-1"
+  (sh (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 6))
+
+;; ---------------------------------------------------------------------------
+;; 2. Reshape (dyadic ⍴)
+;; ---------------------------------------------------------------------------
+
+(apl-test
+  "reshape 2x3 ravel"
+  (rv
+    (apl-reshape
+      (make-array (list 2) (list 2 3))
+      (make-array (list 6) (list 1 2 3 4 5 6))))
+  (list 1 2 3 4 5 6))
+
+(apl-test
+  "reshape 2x3 shape"
+  (sh
+    (apl-reshape
+      (make-array (list 2) (list 2 3))
+      (make-array (list 6) (list 1 2 3 4 5 6))))
+  (list 2 3))
+
+(apl-test
+  "reshape cycle 6 from 1 2"
+  (rv
+    (apl-reshape
+      (make-array (list 1) (list 6))
+      (make-array (list 2) (list 1 2))))
+  (list 1 2 1 2 1 2))
+
+(apl-test
+  "reshape cycle 2x3 from 1 2"
+  (rv
+    (apl-reshape
+      (make-array (list 2) (list 2 3))
+      (make-array (list 2) (list 1 2))))
+  (list 1 2 1 2 1 2))
+
+(apl-test
+  "reshape scalar fill"
+  (rv (apl-reshape (make-array (list 1) (list 4)) (apl-scalar 7)))
+  (list 7 7 7 7))
+
+(apl-test
+  "reshape truncate"
+  (rv
+    (apl-reshape
+      (make-array (list 1) (list 3))
+      (make-array (list 6) (list 10 20 30 40 50 60))))
+  (list 10 20 30))
+
+(apl-test
+  "reshape matrix to vector"
+  (sh
+    (apl-reshape
+      (make-array (list 1) (list 6))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 6))
+
+(apl-test
+  "reshape 2x2x3"
+  (sh
+    (apl-reshape
+      (make-array (list 3) (list 2 2 3))
+      (make-array (list 12) (range 1 13))))
+  (list 2 2 3))
+
+(apl-test
+  "reshape to empty"
+  (rv
+    (apl-reshape
+      (make-array (list 1) (list 0))
+      (make-array (list 3) (list 1 2 3))))
+  (list))
+
+;; ---------------------------------------------------------------------------
+;; 3. Monadic transpose (⍉)
+;; ---------------------------------------------------------------------------
+
+(apl-test
+  "transpose scalar shape"
+  (sh (apl-transpose (apl-scalar 99)))
+  (list))
+
+(apl-test
+  "transpose scalar ravel"
+  (rv (apl-transpose (apl-scalar 99)))
+  (list 99))
+
+(apl-test
+  "transpose vector shape"
+  (sh (apl-transpose (make-array (list 3) (list 3 1 4))))
+  (list 3))
+
+(apl-test
+  "transpose vector ravel"
+  (rv (apl-transpose (make-array (list 3) (list 3 1 4))))
+  (list 3 1 4))
+
+(apl-test
+  "transpose 2x3 shape"
+  (sh (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 3 2))
+
+(apl-test
+  "transpose 2x3 ravel"
+  (rv (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 4 2 5 3 6))
+
+(apl-test
+  "transpose 3x3"
+  (rv (apl-transpose (make-array (list 3 3) (list 1 2 3 4 5 6 7 8 9))))
+  (list 1 4 7 2 5 8 3 6 9))
+
+(apl-test
+  "transpose 1x4 shape"
+  (sh (apl-transpose (make-array (list 1 4) (list 1 2 3 4))))
+  (list 4 1))
+
+(apl-test
+  "transpose twice identity"
+  (rv
+    (apl-transpose
+      (apl-transpose (make-array (list 2 3) (list 1 2 3 4 5 6)))))
+  (list 1 2 3 4 5 6))
+
+(apl-test
+  "transpose 3d shape"
+  (sh (apl-transpose (make-array (list 2 3 4) (range 0 24))))
+  (list 4 3 2))
+
+;; ---------------------------------------------------------------------------
+;; 4. Dyadic transpose (perm⍉arr)
+;; ---------------------------------------------------------------------------
+
+(apl-test
+  "dyadic-transpose identity"
+  (rv
+    (apl-transpose-dyadic
+      (make-array (list 2) (list 1 2))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2 3 4 5 6))
+
+(apl-test
+  "dyadic-transpose swap 2x3"
+  (rv
+    (apl-transpose-dyadic
+      (make-array (list 2) (list 2 1))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 4 2 5 3 6))
+
+(apl-test
+  "dyadic-transpose swap shape"
+  (sh
+    (apl-transpose-dyadic
+      (make-array (list 2) (list 2 1))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 3 2))
+
+(apl-test
+  "dyadic-transpose 3d shape"
+  (sh
+    (apl-transpose-dyadic
+      (make-array (list 3) (list 2 1 3))
+      (make-array (list 2 3 4) (range 0 24))))
+  (list 3 2 4))
+
+(apl-test
+  "take 3 from front"
+  (rv (apl-take (apl-scalar 3) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 3))
+
+(apl-test
+  "take 0"
+  (rv (apl-take (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
+  (list))
+
+(apl-test
+  "take -2 from back"
+  (rv (apl-take (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 4 5))
+
+(apl-test
+  "take over-take pads with 0"
+  (rv (apl-take (apl-scalar 7) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 3 4 5 0 0))
+
+(apl-test
+  "take matrix 1 row 2 cols shape"
+  (sh
+    (apl-take
+      (make-array (list 2) (list 1 2))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2))
+
+(apl-test
+  "take matrix 1 row 2 cols ravel"
+  (rv
+    (apl-take
+      (make-array (list 2) (list 1 2))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2))
+
+(apl-test
+  "take matrix negative row"
+  (rv
+    (apl-take
+      (make-array (list 2) (list -1 3))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 4 5 6))
+
+(apl-test
+  "drop 2 from front"
+  (rv (apl-drop (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 3 4 5))
+
+(apl-test
+  "drop -2 from back"
+  (rv (apl-drop (apl-scalar -2) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 3))
+
+(apl-test
+  "drop all"
+  (rv (apl-drop (apl-scalar 5) (make-array (list 5) (list 1 2 3 4 5))))
+  (list))
+
+(apl-test
+  "drop 0"
+  (rv (apl-drop (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 3 4 5))
+
+(apl-test
+  "drop matrix 1 row shape"
+  (sh
+    (apl-drop
+      (make-array (list 2) (list 1 0))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 3))
+
+(apl-test
+  "drop matrix 1 row ravel"
+  (rv
+    (apl-drop
+      (make-array (list 2) (list 1 0))
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 4 5 6))
+
+(apl-test
+  "reverse vector"
+  (rv (apl-reverse (make-array (list 5) (list 1 2 3 4 5))))
+  (list 5 4 3 2 1))
+
+(apl-test
+  "reverse scalar identity"
+  (rv (apl-reverse (apl-scalar 42)))
+  (list 42))
+
+(apl-test
+  "reverse matrix last axis"
+  (rv (apl-reverse (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 3 2 1 6 5 4))
+
+(apl-test
+  "reverse-first matrix"
+  (rv (apl-reverse-first (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 4 5 6 1 2 3))
+
+(apl-test
+  "reverse-first vector identity"
+  (rv (apl-reverse-first (make-array (list 4) (list 1 2 3 4))))
+  (list 4 3 2 1))
+
+(apl-test
+  "rotate vector left by 2"
+  (rv (apl-rotate (apl-scalar 2) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 3 4 5 1 2))
+
+(apl-test
+  "rotate vector right by 1 (negative)"
+  (rv (apl-rotate (apl-scalar -1) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 5 1 2 3 4))
+
+(apl-test
+  "rotate by 0 is identity"
+  (rv (apl-rotate (apl-scalar 0) (make-array (list 5) (list 1 2 3 4 5))))
+  (list 1 2 3 4 5))
+
+(apl-test
+  "rotate matrix last axis"
+  (rv
+    (apl-rotate (apl-scalar 1) (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 2 3 1 5 6 4))
+
+(apl-test
+  "rotate-first matrix"
+  (rv
+    (apl-rotate-first
+      (apl-scalar 1)
+      (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 4 5 6 1 2 3))
+
+(apl-test
+  "cat v,v ravel"
+  (rv
+    (apl-catenate
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 2) (list 4 5))))
+  (list 1 2 3 4 5))
+
+(apl-test
+  "cat v,v shape"
+  (sh
+    (apl-catenate
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 2) (list 4 5))))
+  (list 5))
+
+(apl-test
+  "cat scalar,v"
+  (rv (apl-catenate (apl-scalar 99) (make-array (list 3) (list 1 2 3))))
+  (list 99 1 2 3))
+
+(apl-test
+  "cat v,scalar"
+  (rv (apl-catenate (make-array (list 3) (list 1 2 3)) (apl-scalar 99)))
+  (list 1 2 3 99))
+
+(apl-test
+  "cat matrix last-axis shape"
+  (sh
+    (apl-catenate
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 2 2) (list 7 8 9 10))))
+  (list 2 5))
+
+(apl-test
+  "cat matrix last-axis ravel"
+  (rv
+    (apl-catenate
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 2 2) (list 7 8 9 10))))
+  (list 1 2 3 7 8 4 5 6 9 10))
+
+(apl-test
+  "cat-first v,v shape"
+  (sh
+    (apl-catenate-first
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 2) (list 4 5))))
+  (list 5))
+
+(apl-test
+  "cat-first matrix shape"
+  (sh
+    (apl-catenate-first
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19))))
+  (list 5 3))
+
+(apl-test
+  "cat-first matrix ravel"
+  (rv
+    (apl-catenate-first
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3 3) (list 11 12 13 14 15 16 17 18 19))))
+  (list 1 2 3 4 5 6 11 12 13 14 15 16 17 18 19))
+
+(apl-test
+  "squad scalar into vector"
+  (rv
+    (apl-squad (apl-scalar 2) (make-array (list 5) (list 10 20 30 40 50))))
+  (list 20))
+
+(apl-test
+  "squad first element"
+  (rv (apl-squad (apl-scalar 1) (make-array (list 3) (list 10 20 30))))
+  (list 10))
+
+(apl-test
+  "squad last element"
+  (rv
+    (apl-squad (apl-scalar 5) (make-array (list 5) (list 10 20 30 40 50))))
+  (list 50))
+
+(apl-test
+  "squad fully specified matrix element"
+  (rv
+    (apl-squad
+      (make-array (list 2) (list 2 3))
+      (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
+  (list 7))
+
+(apl-test
+  "squad partial row of matrix shape"
+  (sh
+    (apl-squad
+      (apl-scalar 2)
+      (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
+  (list 4))
+
+(apl-test
+  "squad partial row of matrix ravel"
+  (rv
+    (apl-squad
+      (apl-scalar 2)
+      (make-array (list 3 4) (list 1 2 3 4 5 6 7 8 9 10 11 12))))
+  (list 5 6 7 8))
+
+(apl-test
+  "squad partial 3d slice shape"
+  (sh (apl-squad (apl-scalar 1) (make-array (list 2 3 4) (range 1 25))))
+  (list 3 4))
+
+(apl-test
+  "grade-up basic"
+  (rv (apl-grade-up (make-array (list 5) (list 3 1 4 1 5))))
+  (list 2 4 1 3 5))
+
+(apl-test
+  "grade-up shape"
+  (sh (apl-grade-up (make-array (list 4) (list 4 1 3 2))))
+  (list 4))
+
+(apl-test
+  "grade-up no duplicates"
+  (rv (apl-grade-up (make-array (list 4) (list 4 1 3 2))))
+  (list 2 4 3 1))
+
+(apl-test
+  "grade-up already sorted"
+  (rv (apl-grade-up (make-array (list 3) (list 1 2 3))))
+  (list 1 2 3))
+
+(apl-test
+  "grade-up reverse sorted"
+  (rv (apl-grade-up (make-array (list 3) (list 3 2 1))))
+  (list 3 2 1))
+
+(apl-test
+  "grade-down basic"
+  (rv (apl-grade-down (make-array (list 5) (list 3 1 4 1 5))))
+  (list 5 3 1 2 4))
+
+(apl-test
+  "grade-down no duplicates"
+  (rv (apl-grade-down (make-array (list 4) (list 4 1 3 2))))
+  (list 1 3 4 2))
+
+(apl-test
+  "grade-up single element"
+  (rv (apl-grade-up (make-array (list 1) (list 42))))
+  (list 1))
+
+(apl-test
+  "enclose shape is scalar"
+  (sh (apl-enclose (make-array (list 3) (list 1 2 3))))
+  (list))
+
+(apl-test
+  "enclose ravel length is 1"
+  (len (rv (apl-enclose (make-array (list 3) (list 1 2 3)))))
+  1)
+
+(apl-test
+  "enclose inner ravel"
+  (rv (first (rv (apl-enclose (make-array (list 3) (list 1 2 3))))))
+  (list 1 2 3))
+
+(apl-test
+  "disclose of enclose round-trips ravel"
+  (rv (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30)))))
+  (list 10 20 30))
+
+(apl-test
+  "disclose of enclose round-trips shape"
+  (sh (apl-disclose (apl-enclose (make-array (list 3) (list 10 20 30)))))
+  (list 3))
+
+(apl-test
+  "disclose scalar ravel"
+  (rv (apl-disclose (apl-scalar 42)))
+  (list 42))
+
+(apl-test
+  "disclose vector ravel"
+  (rv (apl-disclose (make-array (list 3) (list 5 6 7))))
+  (list 5))
+
+(apl-test
+  "disclose matrix returns first row"
+  (rv (apl-disclose (make-array (list 2 3) (list 1 2 3 4 5 6))))
+  (list 1 2 3))
+
+(apl-test
+  "member basic"
+  (rv
+    (apl-member
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 2) (list 2 3))))
+  (list 0 1 1))
+
+(apl-test
+  "member all absent"
+  (rv
+    (apl-member
+      (make-array (list 3) (list 4 5 6))
+      (make-array (list 3) (list 1 2 3))))
+  (list 0 0 0))
+
+(apl-test
+  "member scalar"
+  (rv (apl-member (apl-scalar 5) (make-array (list 3) (list 1 5 9))))
+  (list 1))
+
+(apl-test
+  "member shape preserved"
+  (sh
+    (apl-member
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3) (list 1 3 5))))
+  (list 2 3))
+
+(apl-test
+  "member matrix ravel"
+  (rv
+    (apl-member
+      (make-array (list 2 3) (list 1 2 3 4 5 6))
+      (make-array (list 3) (list 1 3 5))))
+  (list 1 0 1 0 1 0))
+
+(apl-test
+  "index-of basic"
+  (rv
+    (apl-index-of
+      (make-array (list 4) (list 10 20 30 40))
+      (make-array (list 3) (list 20 40 10))))
+  (list 2 4 1))
+
+(apl-test
+  "index-of not-found"
+  (rv
+    (apl-index-of
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 2) (list 5 2))))
+  (list 4 2))
+
+(apl-test
+  "index-of scalar right"
+  (rv
+    (apl-index-of (make-array (list 3) (list 10 20 30)) (apl-scalar 20)))
+  (list 2))
+
+(apl-test
+  "without basic"
+  (rv
+    (apl-without
+      (make-array (list 5) (list 1 2 3 4 5))
+      (make-array (list 2) (list 2 4))))
+  (list 1 3 5))
+
+(apl-test
+  "without shape"
+  (sh
+    (apl-without
+      (make-array (list 5) (list 1 2 3 4 5))
+      (make-array (list 2) (list 2 4))))
+  (list 3))
+
+(apl-test
+  "without nothing removed"
+  (rv
+    (apl-without
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 4 5 6))))
+  (list 1 2 3))
+
+(apl-test
+  "without all removed"
+  (rv
+    (apl-without
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 1 2 3))))
+  (list))

lib/apl/tests/system.sx

@@ -0,0 +1,48 @@
+; Tests for APL ⎕ system functions.
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+
+(apl-test "⎕IO returns 1" (mkrv (apl-quad-io)) (list 1))
+
+(apl-test "⎕ML returns 1" (mkrv (apl-quad-ml)) (list 1))
+
+(apl-test "⎕FR returns 1248" (mkrv (apl-quad-fr)) (list 1248))
+
+(apl-test "⎕TS shape is 7" (mksh (apl-quad-ts)) (list 7))
+
+(apl-test "⎕TS year is 1970 default" (first (mkrv (apl-quad-ts))) 1970)
+
+(apl-test "⎕FMT scalar 42" (apl-quad-fmt (apl-scalar 42)) "42")
+
+(apl-test "⎕FMT scalar negative" (apl-quad-fmt (apl-scalar -7)) "-7")
+
+(apl-test
+  "⎕FMT empty vector"
+  (apl-quad-fmt (make-array (list 0) (list)))
+  "")
+
+(apl-test
+  "⎕FMT singleton vector"
+  (apl-quad-fmt (make-array (list 1) (list 42)))
+  "42")
+
+(apl-test
+  "⎕FMT vector"
+  (apl-quad-fmt (make-array (list 5) (list 1 2 3 4 5)))
+  "1 2 3 4 5")
+
+(apl-test
+  "⎕FMT matrix 2x3"
+  (apl-quad-fmt (make-array (list 2 3) (list 1 2 3 4 5 6)))
+  "1 2 3\n4 5 6\n")
+
+(apl-test
+  "⎕← (print) returns its arg"
+  (mkrv (apl-quad-print (apl-scalar 99)))
+  (list 99))
+
+(apl-test
+  "⎕← preserves shape"
+  (mksh (apl-quad-print (make-array (list 3) (list 1 2 3))))
+  (list 3))

lib/apl/tests/tradfn.sx

@@ -0,0 +1,156 @@
+; Tests for apl-call-tradfn (manual structure construction).
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+(define mknum (fn (n) (list :num n)))
+(define mknm (fn (s) (list :name s)))
+(define mkfg (fn (g) (list :fn-glyph g)))
+(define mkmon (fn (g a) (list :monad (mkfg g) a)))
+(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
+(define mkasg (fn (n e) (list :assign n e)))
+(define mkbr (fn (e) (list :branch e)))
+
+(define mkif (fn (c t e) (list :if c t e)))
+
+(define mkwhile (fn (c b) (list :while c b)))
+
+(define mkfor (fn (v i b) (list :for v i b)))
+
+(define mksel (fn (v cs d) (list :select v cs d)))
+
+(define mktrap (fn (codes t c) (list :trap codes t c)))
+
+(define mkthr (fn (code msg) (list :throw code msg)))
+
+(apl-test
+  "tradfn R←L+W simple add"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 5) (apl-scalar 7)))
+  (list 12))
+
+(apl-test
+  "tradfn R←L×W"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7)))
+  (list 42))
+
+(apl-test
+  "tradfn monadic R←-W"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9)))
+  (list -9))
+
+(apl-test
+  "tradfn →0 exits early"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknm "W")) (mkbr (mknum 0)) (mkasg "R" (mknum 999))) :alpha nil} nil (apl-scalar 7)))
+  (list 7))
+
+(apl-test
+  "tradfn branch to line 3 skips line 2"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 3)) (mkasg "R" (mknum 999)) (mkasg "R" (mknum 42))) :alpha nil} nil (apl-scalar 0)))
+  (list 42))
+
+(apl-test
+  "tradfn local var t←W+1; R←t×2"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "t" (mkdyd "+" (mknm "W") (mknum 1))) (mkasg "R" (mkdyd "×" (mknm "t") (mknum 2)))) :alpha nil} nil (apl-scalar 5)))
+  (list 12))
+
+(apl-test
+  "tradfn vector args"
+  (mkrv
+    (apl-call-tradfn
+      {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"}
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 10 20 30))))
+  (list 11 22 33))
+
+(apl-test
+  "tradfn unset result returns nil"
+  (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 0))) :alpha nil} nil (apl-scalar 5))
+  nil)
+
+(apl-test
+  "tradfn run-off end returns result"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "W") (mknum 3)))) :alpha nil} nil (apl-scalar 7)))
+  (list 21))
+
+(apl-test
+  "tradfn loop sum 1+2+...+5 via branch"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1))) (mkbr (mkdyd "×" (mkdyd "≤" (mknm "i") (mknm "W")) (mknum 3)))) :alpha nil} nil (apl-scalar 5)))
+  (list 15))
+
+(apl-test
+  "tradfn :If true branch"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
+  (list 1))
+
+(apl-test
+  "tradfn :If false branch"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 100)) (list (mkasg "R" (mknum 1))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
+  (list 0))
+
+(apl-test
+  "tradfn :While sum 1..N"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkwhile (mkdyd "≤" (mknm "i") (mknm "W")) (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1)))))) :alpha nil} nil (apl-scalar 10)))
+  (list 55))
+
+(apl-test
+  "tradfn :For sum elements"
+  (mkrv
+    (apl-call-tradfn
+      {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil}
+      nil
+      (make-array (list 4) (list 10 20 30 40))))
+  (list 100))
+
+(apl-test
+  "tradfn :For with empty vector"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 99)) (mkfor "x" (mknm "W") (list (mkasg "R" (mkdyd "+" (mknm "R") (mknm "x")))))) :alpha nil} nil (make-array (list 0) (list))))
+  (list 99))
+
+(apl-test
+  "tradfn :Select dispatch hit"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200))) (list (mknum 3) (mkasg "R" (mknum 300)))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 2)))
+  (list 200))
+
+(apl-test
+  "tradfn :Select default block"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mksel (mknm "W") (list (list (mknum 1) (mkasg "R" (mknum 100))) (list (mknum 2) (mkasg "R" (mknum 200)))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil (apl-scalar 99)))
+  (list -1))
+
+(apl-test
+  "tradfn nested :If"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkif (mkdyd ">" (mknm "W") (mknum 10)) (list (mkasg "R" (mknum 2))) (list (mkasg "R" (mknum 1))))) (list (mkasg "R" (mknum 0))))) :alpha nil} nil (apl-scalar 5)))
+  (list 1))
+
+(apl-test
+  "tradfn :If assigns persist outside"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 0)) (mkif (mkdyd ">" (mknm "W") (mknum 0)) (list (mkasg "R" (mknum 42))) (list)) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 1)))) :alpha nil} nil (apl-scalar 5)))
+  (list 43))
+
+(apl-test
+  "tradfn :For factorial 1..5"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 1)) (mkfor "x" (mkmon "⍳" (mknm "W")) (list (mkasg "R" (mkdyd "×" (mknm "R") (mknm "x")))))) :alpha nil} nil (apl-scalar 5)))
+  (list 120))
+
+(apl-test
+  "tradfn :Trap normal flow (no error)"
+  (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkasg "R" (mknum 99))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil nil))
+  (list 99))
+
+(apl-test
+  "tradfn :Trap catches matching code"
+  (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 5) (list (mkthr 5 "boom")) (list (mkasg "R" (mknum 42))))) :alpha nil} nil nil))
+  (list 42))
+
+(apl-test
+  "tradfn :Trap catch-all (code 0)"
+  (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkthr 99 "any")) (list (mkasg "R" (mknum 1))))) :alpha nil} nil nil))
+  (list 1))
+
+(apl-test
+  "tradfn :Trap catches one of many codes"
+  (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 1 2 3) (list (mkthr 2 "two")) (list (mkasg "R" (mknum 22))))) :alpha nil} nil nil))
+  (list 22))
+
+(apl-test
+  "tradfn :Trap continues to next stmt after catch"
+  (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 7) (list (mkthr 7 "c")) (list (mkasg "R" (mknum 10)))) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 5)))) :alpha nil} nil nil))
+  (list 15))

lib/apl/tests/valence.sx

@@ -0,0 +1,81 @@
+; Tests for valence detection (apl-dfn-valence, apl-tradfn-valence)
+; and unified dispatch (apl-call).
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mknum (fn (n) (list :num n)))
+(define mknm (fn (s) (list :name s)))
+(define mkfg (fn (g) (list :fn-glyph g)))
+(define mkmon (fn (g a) (list :monad (mkfg g) a)))
+(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
+(define mkasg (fn (n e) (list :assign n e)))
+(define mkdfn (fn (stmts) (cons :dfn stmts)))
+
+(apl-test
+  "dfn-valence niladic body=42"
+  (apl-dfn-valence (mkdfn (list (mknum 42))))
+  :niladic)
+
+(apl-test
+  "dfn-valence monadic body=⍵+1"
+  (apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1)))))
+  :monadic)
+
+(apl-test
+  "dfn-valence dyadic body=⍺+⍵"
+  (apl-dfn-valence (mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵")))))
+  :dyadic)
+
+(apl-test
+  "dfn-valence dyadic mentions ⍺ via local"
+  (apl-dfn-valence (mkdfn (list (mkasg "x" (mknm "⍺")) (mknm "x"))))
+  :dyadic)
+
+(apl-test
+  "dfn-valence dyadic deep nest"
+  (apl-dfn-valence
+    (mkdfn (list (mkmon "-" (mkdyd "×" (mknm "⍺") (mknm "⍵"))))))
+  :dyadic)
+
+(apl-test "tradfn-valence niladic" (apl-tradfn-valence {:result "R" :omega nil :stmts (list) :alpha nil}) :niladic)
+
+(apl-test "tradfn-valence monadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha nil}) :monadic)
+
+(apl-test "tradfn-valence dyadic" (apl-tradfn-valence {:result "R" :omega "W" :stmts (list) :alpha "L"}) :dyadic)
+
+(apl-test
+  "apl-call dfn niladic"
+  (mkrv (apl-call (mkdfn (list (mknum 42))) nil nil))
+  (list 42))
+
+(apl-test
+  "apl-call dfn monadic"
+  (mkrv
+    (apl-call
+      (mkdfn (list (mkdyd "+" (mknm "⍵") (mknum 1))))
+      nil
+      (apl-scalar 5)))
+  (list 6))
+
+(apl-test
+  "apl-call dfn dyadic"
+  (mkrv
+    (apl-call
+      (mkdfn (list (mkdyd "+" (mknm "⍺") (mknm "⍵"))))
+      (apl-scalar 3)
+      (apl-scalar 4)))
+  (list 7))
+
+(apl-test
+  "apl-call tradfn dyadic"
+  (mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7)))
+  (list 42))
+
+(apl-test
+  "apl-call tradfn monadic"
+  (mkrv (apl-call {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9)))
+  (list -9))
+
+(apl-test
+  "apl-call tradfn niladic returns nil result"
+  (apl-call {:result "R" :omega nil :stmts (list) :alpha nil} nil nil)
+  nil)

lib/apl/tokenizer.sx

@@ -0,0 +1,180 @@
+(define apl-glyph-set
+  (list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
+        "≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
+        "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
+        "⍺" "⍵" "∇" "/" "⌿" "\\" "⍀" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
+
+(define apl-glyph?
+  (fn (ch)
+    (some (fn (g) (= g ch)) apl-glyph-set)))
+
+(define apl-digit?
+  (fn (ch)
+    (and (string? ch) (>= ch "0") (<= ch "9"))))
+
+(define apl-alpha?
+  (fn (ch)
+    (and (string? ch)
+         (or (and (>= ch "a") (<= ch "z"))
+             (and (>= ch "A") (<= ch "Z"))
+             (= ch "_")))))
+
+(define apl-tokenize
+  (fn (source)
+    (let ((pos 0)
+          (src-len (len source))
+          (tokens (list)))
+
+      (define tok-push!
+        (fn (type value)
+          (append! tokens {:type type :value value})))
+
+      (define cur-sw?
+        (fn (ch)
+          (and (< pos src-len) (starts-with? (slice source pos) ch))))
+
+      (define cur-byte
+        (fn ()
+          (if (< pos src-len) (nth source pos) nil)))
+
+      (define advance!
+        (fn ()
+          (set! pos (+ pos 1))))
+
+      (define consume!
+        (fn (ch)
+          (set! pos (+ pos (len ch)))))
+
+      (define find-glyph
+        (fn ()
+          (let ((rem (slice source pos)))
+            (let ((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set)))
+              (if (> (len matches) 0) (first matches) nil)))))
+
+      (define read-digits!
+        (fn (acc)
+          (if (and (< pos src-len) (apl-digit? (cur-byte)))
+            (let ((ch (cur-byte)))
+              (begin
+                (advance!)
+                (read-digits! (str acc ch))))
+            acc)))
+
+      (define read-ident-cont!
+        (fn ()
+          (when (and (< pos src-len)
+                     (let ((ch (cur-byte)))
+                       (or (apl-alpha? ch) (apl-digit? ch))))
+            (begin
+              (advance!)
+              (read-ident-cont!)))))
+
+      (define read-string!
+        (fn (acc)
+          (cond
+            ((>= pos src-len) acc)
+            ((cur-sw? "'")
+             (if (and (< (+ pos 1) src-len) (cur-sw? "'"))
+               (begin
+                 (advance!)
+                 (advance!)
+                 (read-string! (str acc "'")))
+               (begin (advance!) acc)))
+            (true
+             (let ((ch (cur-byte)))
+               (begin
+                 (advance!)
+                 (read-string! (str acc ch))))))))
+
+      (define skip-line!
+        (fn ()
+          (when (and (< pos src-len) (not (cur-sw? "\n")))
+            (begin
+              (advance!)
+              (skip-line!)))))
+
+      (define scan!
+        (fn ()
+          (when (< pos src-len)
+            (let ((ch (cur-byte)))
+              (cond
+                ((or (= ch " ") (= ch "\t") (= ch "\r"))
+                 (begin (advance!) (scan!)))
+                ((= ch "\n")
+                 (begin (advance!) (tok-push! :newline nil) (scan!)))
+                ((cur-sw? "⍝")
+                 (begin (skip-line!) (scan!)))
+                ((cur-sw? "⋄")
+                 (begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
+                ((= ch "(")
+                 (begin (advance!) (tok-push! :lparen nil) (scan!)))
+                ((= ch ")")
+                 (begin (advance!) (tok-push! :rparen nil) (scan!)))
+                ((= ch "[")
+                 (begin (advance!) (tok-push! :lbracket nil) (scan!)))
+                ((= ch "]")
+                 (begin (advance!) (tok-push! :rbracket nil) (scan!)))
+                ((= ch "{")
+                 (begin (advance!) (tok-push! :lbrace nil) (scan!)))
+                ((= ch "}")
+                 (begin (advance!) (tok-push! :rbrace nil) (scan!)))
+                ((= ch ";")
+                 (begin (advance!) (tok-push! :semi nil) (scan!)))
+                ((cur-sw? "←")
+                 (begin (consume! "←") (tok-push! :assign nil) (scan!)))
+                ((= ch ":")
+                 (let ((start pos))
+                   (begin
+                     (advance!)
+                     (if (and (< pos src-len) (apl-alpha? (cur-byte)))
+                       (begin
+                         (read-ident-cont!)
+                         (tok-push! :keyword (slice source start pos)))
+                       (tok-push! :colon nil))
+                     (scan!))))
+                ((and (cur-sw? "¯")
+                      (< (+ pos (len "¯")) src-len)
+                      (apl-digit? (nth source (+ pos (len "¯")))))
+                 (begin
+                   (consume! "¯")
+                   (let ((digits (read-digits! "")))
+                     (if (and (< pos src-len) (= (cur-byte) ".")
+                              (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
+                       (begin (advance!)
+                              (let ((frac (read-digits! "")))
+                                (tok-push! :num (- 0 (string->number (str digits "." frac))))))
+                       (tok-push! :num (- 0 (parse-int digits 0)))))
+                   (scan!)))
+                ((apl-digit? ch)
+                 (begin
+                   (let ((digits (read-digits! "")))
+                     (if (and (< pos src-len) (= (cur-byte) ".")
+                              (< (+ pos 1) src-len) (apl-digit? (nth source (+ pos 1))))
+                       (begin (advance!)
+                              (let ((frac (read-digits! "")))
+                                (tok-push! :num (string->number (str digits "." frac)))))
+                       (tok-push! :num (parse-int digits 0))))
+                   (scan!)))
+                ((= ch "'")
+                 (begin
+                   (advance!)
+                   (let ((s (read-string! "")))
+                     (tok-push! :str s))
+                   (scan!)))
+                ((or (apl-alpha? ch) (cur-sw? "⎕"))
+                 (let ((start pos))
+                   (begin
+                     (if (cur-sw? "⎕") (consume! "⎕") (advance!))
+                     (if (and (< pos src-len) (cur-sw? "←"))
+                       (consume! "←")
+                       (read-ident-cont!))
+                     (tok-push! :name (slice source start pos))
+                     (scan!))))
+                (true
+                 (let ((g (find-glyph)))
+                   (if g
+                     (begin (consume! g) (tok-push! :glyph g) (scan!))
+                     (begin (advance!) (scan!))))))))))
+
+      (scan!)
+      tokens)))

lib/apl/transpile.sx

@@ -0,0 +1,568 @@
+; APL transpile / AST evaluator
+;
+; Walks parsed AST nodes and evaluates against the runtime.
+; Entry points:
+;   apl-eval-ast    : node × env → value
+;   apl-eval-stmts  : stmt-list × env → value (handles guards, locals, ⍺← default)
+;   apl-call-dfn    : dfn-ast × ⍺ × ⍵ → value   (dyadic)
+;   apl-call-dfn-m  : dfn-ast × ⍵ → value       (monadic)
+;
+; Env is a dict; ⍺ stored under "alpha", ⍵ under "omega",
+; the dfn-ast itself under "nabla" (for ∇ recursion),
+; user names under their literal name.
+
+(define
+  apl-monadic-fn
+  (fn
+    (g)
+    (cond
+      ((= g "+") apl-plus-m)
+      ((= g "-") apl-neg-m)
+      ((= g "×") apl-signum)
+      ((= g "÷") apl-recip)
+      ((= g "⌈") apl-ceil)
+      ((= g "⌊") apl-floor)
+      ((= g "⍳") apl-iota)
+      ((= g "|") apl-abs)
+      ((= g "*") apl-exp)
+      ((= g "⍟") apl-ln)
+      ((= g "!") apl-fact)
+      ((= g "○") apl-pi-times)
+      ((= g "~") apl-not)
+      ((= g "≢") apl-tally)
+      ((= g "⍴") apl-shape)
+      ((= g "≡") apl-depth)
+      ((= g "⊂") apl-enclose)
+      ((= g "⊃") apl-disclose)
+      ((= g ",") apl-ravel)
+      ((= g "⌽") apl-reverse)
+      ((= g "⊖") apl-reverse-first)
+      ((= g "⍋") apl-grade-up)
+      ((= g "⍒") apl-grade-down)
+      ((= g "?") apl-roll)
+      ((= g "⍉") apl-transpose)
+      ((= g "⊢") (fn (a) a))
+      ((= g "⊣") (fn (a) a))
+      ((= g "⍕") apl-quad-fmt)
+      ((= g "⎕FMT") apl-quad-fmt)
+      ((= g "⎕←") apl-quad-print)
+      (else (error "no monadic fn for glyph")))))
+
+(define
+  apl-dyadic-fn
+  (fn
+    (g)
+    (cond
+      ((= g "+") apl-add)
+      ((= g "-") apl-sub)
+      ((= g "×") apl-mul)
+      ((= g "÷") apl-div)
+      ((= g "⌈") apl-max)
+      ((= g "⌊") apl-min)
+      ((= g "*") apl-pow)
+      ((= g "⍟") apl-log)
+      ((= g "|") apl-mod)
+      ((= g "!") apl-binomial)
+      ((= g "○") apl-trig)
+      ((= g "<") apl-lt)
+      ((= g "≤") apl-le)
+      ((= g "=") apl-eq)
+      ((= g "≥") apl-ge)
+      ((= g ">") apl-gt)
+      ((= g "≠") apl-ne)
+      ((= g "∧") apl-and)
+      ((= g "∨") apl-or)
+      ((= g "⍱") apl-nor)
+      ((= g "⍲") apl-nand)
+      ((= g ",") apl-catenate)
+      ((= g "⍪") apl-catenate-first)
+      ((= g "⍴") apl-reshape)
+      ((= g "↑") apl-take)
+      ((= g "↓") apl-drop)
+      ((= g "⌷") apl-squad)
+      ((= g "⌽") apl-rotate)
+      ((= g "⊖") apl-rotate-first)
+      ((= g "∊") apl-member)
+      ((= g "⍳") apl-index-of)
+      ((= g "~") apl-without)
+      ((= g "/") apl-compress)
+      ((= g "⌿") apl-compress-first)
+      ((= g "⍉") apl-transpose-dyadic)
+      ((= g "⊢") (fn (a b) b))
+      ((= g "⊣") (fn (a b) a))
+      (else (error "no dyadic fn for glyph")))))
+
+(define
+  apl-truthy?
+  (fn
+    (v)
+    (let
+      ((rv (get v :ravel)))
+      (if (and (= (len rv) 1) (= (first rv) 0)) false true))))
+
+(define
+  apl-eval-ast
+  (fn
+    (node env)
+    (let
+      ((tag (first node)))
+      (cond
+        ((= tag :num) (apl-scalar (nth node 1)))
+        ((= tag :str)
+          (let
+            ((s (nth node 1)))
+            (if
+              (= (len s) 1)
+              (apl-scalar s)
+              (make-array
+                (list (len s))
+                (map (fn (i) (slice s i (+ i 1))) (range 0 (len s)))))))
+        ((= tag :vec)
+          (let
+            ((items (rest node)))
+            (let
+              ((vals (map (fn (n) (apl-eval-ast n env)) items)))
+              (make-array
+                (list (len vals))
+                (map (fn (v) (first (get v :ravel))) vals)))))
+        ((= tag :name)
+          (let
+            ((nm (nth node 1)))
+            (cond
+              ((= nm "⍺")
+                (let
+                  ((v (get env "⍺")))
+                  (if (= v nil) (get env "alpha") v)))
+              ((= nm "⍵")
+                (let
+                  ((v (get env "⍵")))
+                  (if (= v nil) (get env "omega") v)))
+              ((= nm "⎕IO") (apl-quad-io))
+              ((= nm "⎕ML") (apl-quad-ml))
+              ((= nm "⎕FR") (apl-quad-fr))
+              ((= nm "⎕TS") (apl-quad-ts))
+              (else (get env nm)))))
+        ((= tag :monad)
+          (let
+            ((fn-node (nth node 1)) (arg (nth node 2)))
+            (if
+              (and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
+              (apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
+              (let
+                ((arg-val (apl-eval-ast arg env)))
+                (let
+                  ((new-env (if (and (list? arg) (> (len arg) 0) (= (first arg) :assign-expr)) (assoc env (nth arg 1) arg-val) env)))
+                  ((apl-resolve-monadic fn-node new-env) arg-val))))))
+        ((= tag :dyad)
+          (let
+            ((fn-node (nth node 1))
+              (lhs (nth node 2))
+              (rhs (nth node 3)))
+            (if
+              (and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
+              (apl-call-dfn
+                (get env "nabla")
+                (apl-eval-ast lhs env)
+                (apl-eval-ast rhs env))
+              (let
+                ((rhs-val (apl-eval-ast rhs env)))
+                (let
+                  ((new-env (if (and (list? rhs) (> (len rhs) 0) (= (first rhs) :assign-expr)) (assoc env (nth rhs 1) rhs-val) env)))
+                  ((apl-resolve-dyadic fn-node new-env)
+                    (apl-eval-ast lhs new-env)
+                    rhs-val))))))
+        ((= tag :program) (apl-eval-stmts (rest node) env))
+        ((= tag :dfn) node)
+        ((= tag :bracket)
+          (let
+            ((arr-expr (nth node 1)) (axis-exprs (rest (rest node))))
+            (let
+              ((arr (apl-eval-ast arr-expr env))
+                (axes
+                  (map
+                    (fn (a) (if (= a :all) nil (apl-eval-ast a env)))
+                    axis-exprs)))
+              (apl-bracket-multi axes arr))))
+        ((= tag :assign-expr) (apl-eval-ast (nth node 2) env))
+        ((= tag :assign) (apl-eval-ast (nth node 2) env))
+        (else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
+
+(define
+  apl-eval-stmts
+  (fn
+    (stmts env)
+    (if
+      (= (len stmts) 0)
+      nil
+      (let
+        ((stmt (first stmts)) (more (rest stmts)))
+        (let
+          ((tag (first stmt)))
+          (cond
+            ((= tag :guard)
+              (let
+                ((cond-val (apl-eval-ast (nth stmt 1) env)))
+                (if
+                  (apl-truthy? cond-val)
+                  (apl-eval-ast (nth stmt 2) env)
+                  (apl-eval-stmts more env))))
+            ((and (= tag :assign) (= (nth stmt 1) "⍺"))
+              (if
+                (get env "alpha")
+                (apl-eval-stmts more env)
+                (let
+                  ((v (apl-eval-ast (nth stmt 2) env)))
+                  (apl-eval-stmts more (assoc env "alpha" v)))))
+            ((= tag :assign)
+              (let
+                ((v (apl-eval-ast (nth stmt 2) env)))
+                (apl-eval-stmts more (assoc env (nth stmt 1) v))))
+            ((= (len more) 0) (apl-eval-ast stmt env))
+            (else (begin (apl-eval-ast stmt env) (apl-eval-stmts more env)))))))))
+
+(define
+  apl-call-dfn
+  (fn
+    (dfn-ast alpha omega)
+    (let
+      ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha alpha}))
+      (apl-eval-stmts stmts env))))
+
+(define
+  apl-call-dfn-m
+  (fn
+    (dfn-ast omega)
+    (let
+      ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil}))
+      (apl-eval-stmts stmts env))))
+
+(define
+  apl-tradfn-eval-block
+  (fn
+    (stmts env)
+    (if
+      (= (len stmts) 0)
+      env
+      (let
+        ((stmt (first stmts)))
+        (apl-tradfn-eval-block (rest stmts) (apl-tradfn-eval-stmt stmt env))))))
+
+(define
+  apl-tradfn-eval-while
+  (fn
+    (cond-expr body env)
+    (let
+      ((cond-val (apl-eval-ast cond-expr env)))
+      (if
+        (apl-truthy? cond-val)
+        (apl-tradfn-eval-while
+          cond-expr
+          body
+          (apl-tradfn-eval-block body env))
+        env))))
+
+(define
+  apl-tradfn-eval-for
+  (fn
+    (var-name items body env)
+    (if
+      (= (len items) 0)
+      env
+      (let
+        ((env-with-var (assoc env var-name (apl-scalar (first items)))))
+        (apl-tradfn-eval-for
+          var-name
+          (rest items)
+          body
+          (apl-tradfn-eval-block body env-with-var))))))
+
+(define
+  apl-tradfn-eval-select
+  (fn
+    (val cases default-block env)
+    (if
+      (= (len cases) 0)
+      (apl-tradfn-eval-block default-block env)
+      (let
+        ((c (first cases)))
+        (let
+          ((case-val (apl-eval-ast (first c) env)))
+          (if
+            (= (first (get val :ravel)) (first (get case-val :ravel)))
+            (apl-tradfn-eval-block (rest c) env)
+            (apl-tradfn-eval-select val (rest cases) default-block env)))))))
+
+(define
+  apl-tradfn-eval-stmt
+  (fn
+    (stmt env)
+    (let
+      ((tag (first stmt)))
+      (cond
+        ((= tag :assign)
+          (assoc env (nth stmt 1) (apl-eval-ast (nth stmt 2) env)))
+        ((= tag :if)
+          (let
+            ((cond-val (apl-eval-ast (nth stmt 1) env)))
+            (if
+              (apl-truthy? cond-val)
+              (apl-tradfn-eval-block (nth stmt 2) env)
+              (apl-tradfn-eval-block (nth stmt 3) env))))
+        ((= tag :while)
+          (apl-tradfn-eval-while (nth stmt 1) (nth stmt 2) env))
+        ((= tag :for)
+          (let
+            ((iter-val (apl-eval-ast (nth stmt 2) env)))
+            (apl-tradfn-eval-for
+              (nth stmt 1)
+              (get iter-val :ravel)
+              (nth stmt 3)
+              env)))
+        ((= tag :select)
+          (let
+            ((val (apl-eval-ast (nth stmt 1) env)))
+            (apl-tradfn-eval-select val (nth stmt 2) (nth stmt 3) env)))
+        ((= tag :trap)
+          (let
+            ((codes (nth stmt 1))
+              (try-block (nth stmt 2))
+              (catch-block (nth stmt 3)))
+            (guard
+              (e
+                ((apl-trap-matches? codes e)
+                  (apl-tradfn-eval-block catch-block env)))
+              (apl-tradfn-eval-block try-block env))))
+        ((= tag :throw) (apl-throw (nth stmt 1) (nth stmt 2)))
+        (else (begin (apl-eval-ast stmt env) env))))))
+
+(define
+  apl-tradfn-loop
+  (fn
+    (stmts line env result-name)
+    (cond
+      ((= line 0) (get env result-name))
+      ((> line (len stmts)) (get env result-name))
+      (else
+        (let
+          ((stmt (nth stmts (- line 1))))
+          (let
+            ((tag (first stmt)))
+            (cond
+              ((= tag :branch)
+                (let
+                  ((target (apl-eval-ast (nth stmt 1) env)))
+                  (let
+                    ((target-num (first (get target :ravel))))
+                    (apl-tradfn-loop stmts target-num env result-name))))
+              (else
+                (apl-tradfn-loop
+                  stmts
+                  (+ line 1)
+                  (apl-tradfn-eval-stmt stmt env)
+                  result-name)))))))))
+
+(define
+  apl-call-tradfn
+  (fn
+    (tradfn alpha omega)
+    (let
+      ((stmts (get tradfn :stmts))
+        (result-name (get tradfn :result))
+        (alpha-name (get tradfn :alpha))
+        (omega-name (get tradfn :omega)))
+      (let
+        ((env-a (if alpha-name (assoc {} alpha-name alpha) {})))
+        (let
+          ((env-ao (if omega-name (assoc env-a omega-name omega) env-a)))
+          (apl-tradfn-loop stmts 1 env-ao result-name))))))
+
+(define
+  apl-ast-mentions-list?
+  (fn
+    (lst target)
+    (if
+      (= (len lst) 0)
+      false
+      (if
+        (apl-ast-mentions? (first lst) target)
+        true
+        (apl-ast-mentions-list? (rest lst) target)))))
+
+(define
+  apl-ast-mentions?
+  (fn
+    (node target)
+    (cond
+      ((not (list? node)) false)
+      ((= (len node) 0) false)
+      ((and (= (first node) :name) (= (nth node 1) target)) true)
+      (else (apl-ast-mentions-list? (rest node) target)))))
+
+(define
+  apl-dfn-valence
+  (fn
+    (dfn-ast)
+    (let
+      ((body (rest dfn-ast)))
+      (cond
+        ((apl-ast-mentions-list? body "⍺") :dyadic)
+        ((apl-ast-mentions-list? body "⍵") :monadic)
+        (else :niladic)))))
+
+(define
+  apl-tradfn-valence
+  (fn
+    (tradfn)
+    (cond
+      ((get tradfn :alpha) :dyadic)
+      ((get tradfn :omega) :monadic)
+      (else :niladic))))
+
+(define
+  apl-call
+  (fn
+    (f alpha omega)
+    (cond
+      ((and (list? f) (> (len f) 0) (= (first f) :dfn))
+        (if alpha (apl-call-dfn f alpha omega) (apl-call-dfn-m f omega)))
+      ((dict? f) (apl-call-tradfn f alpha omega))
+      (else (error "apl-call: not a function")))))
+
+(define
+  apl-resolve-monadic
+  (fn
+    (fn-node env)
+    (let
+      ((tag (first fn-node)))
+      (cond
+        ((= tag :fn-glyph) (apl-monadic-fn (nth fn-node 1)))
+        ((= tag :derived-fn)
+          (let
+            ((op (nth fn-node 1)) (inner (nth fn-node 2)))
+            (cond
+              ((= op "/")
+                (let
+                  ((f (apl-resolve-dyadic inner env)))
+                  (fn (arr) (apl-reduce f arr))))
+              ((= op "⌿")
+                (let
+                  ((f (apl-resolve-dyadic inner env)))
+                  (fn (arr) (apl-reduce-first f arr))))
+              ((= op "\\")
+                (let
+                  ((f (apl-resolve-dyadic inner env)))
+                  (fn (arr) (apl-scan f arr))))
+              ((= op "⍀")
+                (let
+                  ((f (apl-resolve-dyadic inner env)))
+                  (fn (arr) (apl-scan-first f arr))))
+              ((= op "¨")
+                (let
+                  ((f (apl-resolve-monadic inner env)))
+                  (fn (arr) (apl-each f arr))))
+              ((= op "⍨")
+                (let
+                  ((f (apl-resolve-dyadic inner env)))
+                  (fn (arr) (apl-commute f arr))))
+              (else (error "apl-resolve-monadic: unsupported op")))))
+        ((= tag :fn-name)
+          (let
+            ((nm (nth fn-node 1)))
+            (let
+              ((bound (get env nm)))
+              (if
+                (and
+                  (list? bound)
+                  (> (len bound) 0)
+                  (= (first bound) :dfn))
+                (fn (arg) (apl-call-dfn-m bound arg))
+                (error "apl-resolve-monadic: name not bound to dfn")))))
+        ((= tag :train)
+          (let
+            ((fns (rest fn-node)))
+            (let
+              ((n (len fns)))
+              (cond
+                ((= n 2)
+                  (let
+                    ((g (apl-resolve-monadic (nth fns 0) env))
+                      (h (apl-resolve-monadic (nth fns 1) env)))
+                    (fn (arg) (g (h arg)))))
+                ((= n 3)
+                  (let
+                    ((f (apl-resolve-monadic (nth fns 0) env))
+                      (g (apl-resolve-dyadic (nth fns 1) env))
+                      (h (apl-resolve-monadic (nth fns 2) env)))
+                    (fn (arg) (g (f arg) (h arg)))))
+                (else (error "monadic train arity not 2 or 3"))))))
+        (else (error "apl-resolve-monadic: unknown fn-node tag"))))))
+
+(define
+  apl-resolve-dyadic
+  (fn
+    (fn-node env)
+    (let
+      ((tag (first fn-node)))
+      (cond
+        ((= tag :fn-glyph) (apl-dyadic-fn (nth fn-node 1)))
+        ((= tag :derived-fn)
+          (let
+            ((op (nth fn-node 1)) (inner (nth fn-node 2)))
+            (cond
+              ((= op "¨")
+                (let
+                  ((f (apl-resolve-dyadic inner env)))
+                  (fn (a b) (apl-each-dyadic f a b))))
+              ((= op "⍨")
+                (let
+                  ((f (apl-resolve-dyadic inner env)))
+                  (fn (a b) (apl-commute-dyadic f a b))))
+              (else (error "apl-resolve-dyadic: unsupported op")))))
+        ((= tag :fn-name)
+          (let
+            ((nm (nth fn-node 1)))
+            (let
+              ((bound (get env nm)))
+              (if
+                (and
+                  (list? bound)
+                  (> (len bound) 0)
+                  (= (first bound) :dfn))
+                (fn (a b) (apl-call-dfn bound a b))
+                (error "apl-resolve-dyadic: name not bound to dfn")))))
+        ((= tag :outer)
+          (let
+            ((inner (nth fn-node 2)))
+            (let
+              ((f (apl-resolve-dyadic inner env)))
+              (fn (a b) (apl-outer f a b)))))
+        ((= tag :derived-fn2)
+          (let
+            ((f-node (nth fn-node 2)) (g-node (nth fn-node 3)))
+            (let
+              ((f (apl-resolve-dyadic f-node env))
+                (g (apl-resolve-dyadic g-node env)))
+              (fn (a b) (apl-inner f g a b)))))
+        ((= tag :train)
+          (let
+            ((fns (rest fn-node)))
+            (let
+              ((n (len fns)))
+              (cond
+                ((= n 2)
+                  (let
+                    ((g (apl-resolve-monadic (nth fns 0) env))
+                      (h (apl-resolve-dyadic (nth fns 1) env)))
+                    (fn (a b) (g (h a b)))))
+                ((= n 3)
+                  (let
+                    ((f (apl-resolve-dyadic (nth fns 0) env))
+                      (g (apl-resolve-dyadic (nth fns 1) env))
+                      (h (apl-resolve-dyadic (nth fns 2) env)))
+                    (fn (a b) (g (f a b) (h a b)))))
+                (else (error "dyadic train arity not 2 or 3"))))))
+        (else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
+
+(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
+
+(define apl-run-file (fn (path) (apl-run (file-read path))))

lib/erlang/conformance.sh

@@ -76,7 +76,7 @@ cat > "$TMPFILE" << 'EPOCHS'
 (eval "(list er-fib-test-pass er-fib-test-count)")
 EPOCHS
 
-timeout 120 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
+timeout 600 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
 
 # Parse "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
 parse_pair() {

lib/erlang/scoreboard.json

@@ -1,16 +1,16 @@
 {
   "language": "erlang",
-  "total_pass": 0,
-  "total": 0,
+  "total_pass": 530,
+  "total": 530,
   "suites": [
-    {"name":"tokenize","pass":0,"total":0,"status":"ok"},
-    {"name":"parse","pass":0,"total":0,"status":"ok"},
-    {"name":"eval","pass":0,"total":0,"status":"ok"},
-    {"name":"runtime","pass":0,"total":0,"status":"ok"},
-    {"name":"ring","pass":0,"total":0,"status":"ok"},
-    {"name":"ping-pong","pass":0,"total":0,"status":"ok"},
-    {"name":"bank","pass":0,"total":0,"status":"ok"},
-    {"name":"echo","pass":0,"total":0,"status":"ok"},
-    {"name":"fib","pass":0,"total":0,"status":"ok"}
+    {"name":"tokenize","pass":62,"total":62,"status":"ok"},
+    {"name":"parse","pass":52,"total":52,"status":"ok"},
+    {"name":"eval","pass":346,"total":346,"status":"ok"},
+    {"name":"runtime","pass":39,"total":39,"status":"ok"},
+    {"name":"ring","pass":4,"total":4,"status":"ok"},
+    {"name":"ping-pong","pass":4,"total":4,"status":"ok"},
+    {"name":"bank","pass":8,"total":8,"status":"ok"},
+    {"name":"echo","pass":7,"total":7,"status":"ok"},
+    {"name":"fib","pass":8,"total":8,"status":"ok"}
   ]
 }

lib/erlang/scoreboard.md

@@ -1,18 +1,18 @@
 # Erlang-on-SX Scoreboard
 
-**Total: 0 / 0 tests passing**
+**Total: 530 / 530 tests passing**
 
 |  | Suite | Pass | Total |
 |---|---|---|---|
-| ✅ | tokenize | 0 | 0 |
-| ✅ | parse | 0 | 0 |
-| ✅ | eval | 0 | 0 |
-| ✅ | runtime | 0 | 0 |
-| ✅ | ring | 0 | 0 |
-| ✅ | ping-pong | 0 | 0 |
-| ✅ | bank | 0 | 0 |
-| ✅ | echo | 0 | 0 |
-| ✅ | fib | 0 | 0 |
+| ✅ | tokenize | 62 | 62 |
+| ✅ | parse | 52 | 52 |
+| ✅ | eval | 346 | 346 |
+| ✅ | runtime | 39 | 39 |
+| ✅ | ring | 4 | 4 |
+| ✅ | ping-pong | 4 | 4 |
+| ✅ | bank | 8 | 8 |
+| ✅ | echo | 7 | 7 |
+| ✅ | fib | 8 | 8 |
 
 
 Generated by `lib/erlang/conformance.sh`.

lib/guest/ast.sx

@@ -0,0 +1,92 @@
+;; lib/guest/ast.sx — canonical AST node shapes.
+;;
+;; A guest's parser may emit its own AST in whatever shape is convenient
+;; for that language's evaluator/transpiler. This file gives a SHARED
+;; canonical shape that cross-language tools (formatters, highlighters,
+;; debuggers) can target without per-language adapters.
+;;
+;; Each canonical node is a tagged list: (KIND ...payload).
+;;
+;; Constructors (return a canonical node):
+;;
+;;   (ast-literal       VALUE)               — number / string / bool / nil
+;;   (ast-var           NAME)                — identifier reference
+;;   (ast-app           FN ARGS)             — function application
+;;   (ast-lambda        PARAMS BODY)         — anonymous function
+;;   (ast-let           BINDINGS BODY)       — local bindings
+;;   (ast-letrec        BINDINGS BODY)       — recursive local bindings
+;;   (ast-if            TEST THEN ELSE)      — conditional
+;;   (ast-match-clause  PATTERN BODY)        — one match arm
+;;   (ast-module        NAME BODY)           — module declaration
+;;   (ast-import        NAME)                — import directive
+;;
+;; Predicates: (ast-literal? X), (ast-var? X), …
+;; Generic:    (ast? X)         — any canonical node
+;;             (ast-kind X)     — :literal / :var / :app / …
+;;
+;; Accessors  (one per payload field):
+;;   (ast-literal-value N)
+;;   (ast-var-name N)
+;;   (ast-app-fn N)             (ast-app-args N)
+;;   (ast-lambda-params N)      (ast-lambda-body N)
+;;   (ast-let-bindings N)       (ast-let-body N)
+;;   (ast-letrec-bindings N)    (ast-letrec-body N)
+;;   (ast-if-test N)            (ast-if-then N)         (ast-if-else N)
+;;   (ast-match-clause-pattern N)
+;;   (ast-match-clause-body N)
+;;   (ast-module-name N)        (ast-module-body N)
+;;   (ast-import-name N)
+
+(define ast-literal      (fn (v)         (list :literal v)))
+(define ast-var          (fn (n)         (list :var n)))
+(define ast-app          (fn (f args)    (list :app f args)))
+(define ast-lambda       (fn (ps body)   (list :lambda ps body)))
+(define ast-let          (fn (bs body)   (list :let bs body)))
+(define ast-letrec       (fn (bs body)   (list :letrec bs body)))
+(define ast-if           (fn (t th el)   (list :if t th el)))
+(define ast-match-clause (fn (p body)    (list :match-clause p body)))
+(define ast-module       (fn (n body)    (list :module n body)))
+(define ast-import       (fn (n)         (list :import n)))
+
+(define ast-kind (fn (x) (if (and (list? x) (not (empty? x))) (first x) nil)))
+
+(define
+  ast?
+  (fn (x)
+    (and (list? x)
+         (not (empty? x))
+         (let ((k (first x)))
+           (or (= k :literal) (= k :var) (= k :app)
+               (= k :lambda)  (= k :let) (= k :letrec)
+               (= k :if)      (= k :match-clause)
+               (= k :module)  (= k :import))))))
+
+(define ast-literal?      (fn (x) (and (ast? x) (= (first x) :literal))))
+(define ast-var?          (fn (x) (and (ast? x) (= (first x) :var))))
+(define ast-app?          (fn (x) (and (ast? x) (= (first x) :app))))
+(define ast-lambda?       (fn (x) (and (ast? x) (= (first x) :lambda))))
+(define ast-let?          (fn (x) (and (ast? x) (= (first x) :let))))
+(define ast-letrec?       (fn (x) (and (ast? x) (= (first x) :letrec))))
+(define ast-if?           (fn (x) (and (ast? x) (= (first x) :if))))
+(define ast-match-clause? (fn (x) (and (ast? x) (= (first x) :match-clause))))
+(define ast-module?       (fn (x) (and (ast? x) (= (first x) :module))))
+(define ast-import?       (fn (x) (and (ast? x) (= (first x) :import))))
+
+(define ast-literal-value (fn (n) (nth n 1)))
+(define ast-var-name      (fn (n) (nth n 1)))
+(define ast-app-fn        (fn (n) (nth n 1)))
+(define ast-app-args      (fn (n) (nth n 2)))
+(define ast-lambda-params (fn (n) (nth n 1)))
+(define ast-lambda-body   (fn (n) (nth n 2)))
+(define ast-let-bindings  (fn (n) (nth n 1)))
+(define ast-let-body      (fn (n) (nth n 2)))
+(define ast-letrec-bindings (fn (n) (nth n 1)))
+(define ast-letrec-body     (fn (n) (nth n 2)))
+(define ast-if-test       (fn (n) (nth n 1)))
+(define ast-if-then       (fn (n) (nth n 2)))
+(define ast-if-else       (fn (n) (nth n 3)))
+(define ast-match-clause-pattern (fn (n) (nth n 1)))
+(define ast-match-clause-body    (fn (n) (nth n 2)))
+(define ast-module-name   (fn (n) (nth n 1)))
+(define ast-module-body   (fn (n) (nth n 2)))
+(define ast-import-name   (fn (n) (nth n 1)))

lib/guest/hm.sx

@@ -0,0 +1,180 @@
+;; lib/guest/hm.sx — Hindley-Milner type-inference foundations.
+;;
+;; Builds on lib/guest/match.sx (terms + unify) and ast.sx (canonical
+;; AST shapes). This file ships the ALGEBRA — types, schemes, free
+;; type-vars, generalize / instantiate, substitution composition — so a
+;; full Algorithm W (or J) can be assembled on top either inside this
+;; file or in a host-specific consumer (haskell/infer.sx,
+;; lib/ocaml/types.sx, …).
+;;
+;; Per the brief the second consumer for this step is OCaml-on-SX
+;; Phase 5 (paired sequencing). Until that lands, the algebra is the
+;; deliverable; the host-flavoured assembly (lambda / app / let
+;; inference rules with substitution threading) lives in the host.
+;;
+;; Types
+;; -----
+;; A type is a canonical match.sx term — type variables use mk-var,
+;; type constructors use mk-ctor:
+;;   (hm-tv NAME)              type variable
+;;   (hm-arrow A B)             A -> B
+;;   (hm-con NAME ARGS)         named n-ary constructor
+;;   (hm-int) / (hm-bool) / (hm-string)   primitive constructors
+;;
+;; Schemes
+;; -------
+;;   (hm-scheme VARS TYPE)        ∀ VARS . TYPE
+;;   (hm-monotype TYPE)           empty quantifier
+;;   (hm-scheme? S) (hm-scheme-vars S) (hm-scheme-type S)
+;;
+;; Free type variables
+;; -------------------
+;;   (hm-ftv TYPE)                names occurring in TYPE
+;;   (hm-ftv-scheme S)            free names (minus quantifiers)
+;;   (hm-ftv-env ENV)             free across an env (name -> scheme)
+;;
+;; Substitution
+;; ------------
+;;   (hm-apply SUBST TYPE)        substitute through a type
+;;   (hm-apply-scheme SUBST S)    leaves bound vars alone
+;;   (hm-apply-env SUBST ENV)
+;;   (hm-compose S2 S1)           apply S1 then S2
+;;
+;; Generalize / Instantiate
+;; ------------------------
+;;   (hm-generalize TYPE ENV)      → scheme over ftv(t) - ftv(env)
+;;   (hm-instantiate SCHEME COUNTER) → fresh-var instance
+;;   (hm-fresh-tv COUNTER)         → (:var "tN"), bumps COUNTER
+;;
+;; Inference (literal only — the rest of Algorithm W lives in the host)
+;; --------------------------------------------------------------------
+;;   (hm-infer-literal EXPR)       → {:subst {} :type T}
+;;
+;; A complete Algorithm W consumes this kit by assembling lambda / app
+;; / let rules in the host language file.
+
+(define hm-tv     (fn (name) (list :var name)))
+(define hm-con    (fn (name args) (list :ctor name args)))
+(define hm-arrow  (fn (a b) (hm-con "->" (list a b))))
+(define hm-int    (fn () (hm-con "Int" (list))))
+(define hm-bool   (fn () (hm-con "Bool" (list))))
+(define hm-string (fn () (hm-con "String" (list))))
+
+(define hm-scheme        (fn (vars t) (list :scheme vars t)))
+(define hm-monotype      (fn (t) (hm-scheme (list) t)))
+(define hm-scheme?       (fn (s) (and (list? s) (not (empty? s)) (= (first s) :scheme))))
+(define hm-scheme-vars   (fn (s) (nth s 1)))
+(define hm-scheme-type   (fn (s) (nth s 2)))
+
+(define
+  hm-fresh-tv
+  (fn (counter)
+    (let ((n (first counter)))
+      (begin
+        (set-nth! counter 0 (+ n 1))
+        (hm-tv (str "t" (+ n 1)))))))
+
+(define
+  hm-ftv-acc
+  (fn (t acc)
+    (cond
+      ((is-var? t)
+        (if (some (fn (n) (= n (var-name t))) acc) acc (cons (var-name t) acc)))
+      ((is-ctor? t)
+        (let ((a acc))
+          (begin
+            (for-each (fn (x) (set! a (hm-ftv-acc x a))) (ctor-args t))
+            a)))
+      (:else acc))))
+
+(define hm-ftv (fn (t) (hm-ftv-acc t (list))))
+
+(define
+  hm-ftv-scheme
+  (fn (s)
+    (let ((qs (hm-scheme-vars s))
+          (all (hm-ftv (hm-scheme-type s))))
+      (filter (fn (n) (not (some (fn (q) (= q n)) qs))) all))))
+
+(define
+  hm-ftv-env
+  (fn (env)
+    (let ((acc (list)))
+      (begin
+        (for-each
+          (fn (k)
+            (for-each
+              (fn (n)
+                (when (not (some (fn (m) (= m n)) acc))
+                  (set! acc (cons n acc))))
+              (hm-ftv-scheme (get env k))))
+          (keys env))
+        acc))))
+
+(define hm-apply (fn (subst t) (walk* t subst)))
+
+(define
+  hm-apply-scheme
+  (fn (subst s)
+    (let ((qs (hm-scheme-vars s))
+          (d {}))
+      (begin
+        (for-each
+          (fn (k)
+            (when (not (some (fn (q) (= q k)) qs))
+              (dict-set! d k (get subst k))))
+          (keys subst))
+        (hm-scheme qs (walk* (hm-scheme-type s) d))))))
+
+(define
+  hm-apply-env
+  (fn (subst env)
+    (let ((d {}))
+      (begin
+        (for-each
+          (fn (k) (dict-set! d k (hm-apply-scheme subst (get env k))))
+          (keys env))
+        d))))
+
+(define
+  hm-compose
+  (fn (s2 s1)
+    (let ((d {}))
+      (begin
+        (for-each (fn (k) (dict-set! d k (walk* (get s1 k) s2))) (keys s1))
+        (for-each
+          (fn (k) (when (not (has-key? d k)) (dict-set! d k (get s2 k))))
+          (keys s2))
+        d))))
+
+(define
+  hm-generalize
+  (fn (t env)
+    (let ((tvars (hm-ftv t))
+          (evars (hm-ftv-env env)))
+      (let ((qs (filter (fn (n) (not (some (fn (m) (= m n)) evars))) tvars)))
+        (hm-scheme qs t)))))
+
+(define
+  hm-instantiate
+  (fn (s counter)
+    (let ((qs (hm-scheme-vars s))
+          (subst {}))
+      (begin
+        (for-each
+          (fn (q) (set! subst (assoc subst q (hm-fresh-tv counter))))
+          qs)
+        (walk* (hm-scheme-type s) subst)))))
+
+;; Literal inference — the only AST kind whose typing rule is closed
+;; in the kit. Lambda / app / let live in host code so the host's own
+;; AST conventions stay untouched.
+(define
+  hm-infer-literal
+  (fn (expr)
+    (let ((v (ast-literal-value expr)))
+      (cond
+        ((number? v)  {:subst {} :type (hm-int)})
+        ((string? v)  {:subst {} :type (hm-string)})
+        ((boolean? v) {:subst {} :type (hm-bool)})
+        (:else (error (str "hm-infer-literal: unknown kind: " v)))))))

lib/guest/layout.sx

@@ -0,0 +1,145 @@
+;; lib/guest/layout.sx — configurable off-side / layout-sensitive lexer.
+;;
+;; Inserts virtual open / close / separator tokens based on indentation.
+;; Configurable enough to encode either the Haskell 98 layout rule (let /
+;; where / do / of opens a virtual brace at the next token's column) or
+;; a Python-ish indent / dedent rule (a colon at the end of a line opens
+;; a block at the next non-blank line's column).
+;;
+;; Token shape (input + output)
+;; ----------------------------
+;; Each token is a dict {:type :value :line :col …}. The kit reads
+;; only :type / :value / :line / :col and passes everything else
+;; through. The input stream MUST be free of newline filler tokens
+;; (preprocess them away with your tokenizer) — line breaks are detected
+;; by comparing :line of consecutive tokens.
+;;
+;; Config
+;; ------
+;;   :open-keywords    list of strings; a token whose :value matches
+;;                     opens a new layout block at the next token's
+;;                     column (Haskell: let/where/do/of).
+;;   :open-trailing-fn (fn (tok) -> bool) — alternative trigger that
+;;                     fires AFTER the token is emitted. Use for
+;;                     Python-style trailing `:`.
+;;   :open-token / :close-token / :sep-token
+;;                     templates {:type :value} merged with :line and
+;;                     :col when virtual tokens are emitted.
+;;   :explicit-open?   (fn (tok) -> bool) — if the next token after a
+;;                     trigger satisfies this, suppress virtual layout
+;;                     for that block (Haskell: `{`).
+;;   :module-prelude?  if true, wrap whole input in an implicit block
+;;                     at the first token's column (Haskell yes,
+;;                     Python no).
+;;
+;; Public entry
+;; ------------
+;;   (layout-pass cfg tokens) -> tokens with virtual layout inserted.
+
+(define
+  layout-mk-virtual
+  (fn (template line col)
+    (assoc (assoc template :line line) :col col)))
+
+(define
+  layout-is-open-kw?
+  (fn (tok open-kws)
+    (and (= (get tok :type) "reserved")
+         (some (fn (k) (= k (get tok :value))) open-kws))))
+
+(define
+  layout-pass
+  (fn (cfg tokens)
+    (let ((open-kws (get cfg :open-keywords))
+          (trailing-fn (get cfg :open-trailing-fn))
+          (open-tmpl (get cfg :open-token))
+          (close-tmpl (get cfg :close-token))
+          (sep-tmpl (get cfg :sep-token))
+          (mod-prelude? (get cfg :module-prelude?))
+          (expl?-fn (get cfg :explicit-open?))
+          (out (list))
+          (stack (list))
+          (n (len tokens))
+          (i 0)
+          (prev-line -1)
+          (pending-open false)
+          (just-opened false))
+      (define
+        emit-closes-while-greater
+        (fn (col line)
+          (when (and (not (empty? stack)) (> (first stack) col))
+            (do
+              (append! out (layout-mk-virtual close-tmpl line col))
+              (set! stack (rest stack))
+              (emit-closes-while-greater col line)))))
+      (define
+        emit-pending-open
+        (fn (line col)
+          (do
+            (append! out (layout-mk-virtual open-tmpl line col))
+            (set! stack (cons col stack))
+            (set! pending-open false)
+            (set! just-opened true))))
+      (define
+        layout-step
+        (fn ()
+          (when (< i n)
+            (let ((tok (nth tokens i)))
+              (let ((line (get tok :line)) (col (get tok :col)))
+                (cond
+                  (pending-open
+                    (cond
+                      ((and (not (= expl?-fn nil)) (expl?-fn tok))
+                        (do
+                          (set! pending-open false)
+                          (append! out tok)
+                          (set! prev-line line)
+                          (set! i (+ i 1))
+                          (layout-step)))
+                      (:else
+                        (do
+                          (emit-pending-open line col)
+                          (layout-step)))))
+                  (:else
+                    (let ((on-fresh-line? (and (> prev-line 0) (> line prev-line))))
+                      (do
+                        (when on-fresh-line?
+                          (let ((stack-before stack))
+                            (begin
+                              (emit-closes-while-greater col line)
+                              (when (and (not (empty? stack))
+                                         (= (first stack) col)
+                                         (not just-opened)
+                                         ;; suppress separator if a dedent fired
+                                         ;; — the dedent is itself the separator
+                                         (= (len stack) (len stack-before)))
+                                (append! out (layout-mk-virtual sep-tmpl line col))))))
+                        (set! just-opened false)
+                        (append! out tok)
+                        (set! prev-line line)
+                        (set! i (+ i 1))
+                        (cond
+                          ((layout-is-open-kw? tok open-kws)
+                            (set! pending-open true))
+                          ((and (not (= trailing-fn nil)) (trailing-fn tok))
+                            (set! pending-open true)))
+                        (layout-step))))))))))
+      (begin
+        ;; Module prelude: implicit layout block at the first token's column.
+        (when (and mod-prelude? (> n 0))
+          (let ((tok (nth tokens 0)))
+            (do
+              (append! out (layout-mk-virtual open-tmpl (get tok :line) (get tok :col)))
+              (set! stack (cons (get tok :col) stack))
+              (set! just-opened true))))
+        (layout-step)
+        ;; EOF: close every remaining block.
+        (define close-rest
+          (fn ()
+            (when (not (empty? stack))
+              (do
+                (append! out (layout-mk-virtual close-tmpl 0 0))
+                (set! stack (rest stack))
+                (close-rest)))))
+        (close-rest)
+        out))))

lib/guest/match.sx

@@ -0,0 +1,185 @@
+;; lib/guest/match.sx — pure pattern-match + unification kit.
+;;
+;; Shipped for miniKanren / Datalog / future logic-flavoured guests that
+;; want immutable unification without writing it from scratch. The two
+;; existing prolog/haskell engines stay as-is — porting them in place
+;; risks the 746 tests they currently pass; consumers can migrate
+;; gradually via the converters in lib/guest/ast.sx.
+;;
+;; Term shapes (canonical wire format)
+;; -----------------------------------
+;;   var          (:var NAME)            NAME a string
+;;   constructor  (:ctor HEAD ARGS)      HEAD a string, ARGS a list of terms
+;;   literal      number / string / boolean / nil
+;;
+;; Guests with their own shape pass adapter callbacks via the cfg arg —
+;; see (unify-with cfg ...) and (match-pat-with cfg ...) below. The
+;; default canonical entry points (unify / match-pat) use the wire shape.
+;;
+;; Substitution / env
+;; ------------------
+;; A substitution is a SX dict mapping VAR-NAME → term. There are no
+;; trails, no mutation: each step either returns an extended dict or nil.
+;;
+;;   (empty-subst)                  → {}
+;;   (walk term s)                  → term with top-level vars resolved
+;;   (walk* term s)                 → term with all vars resolved (recursive)
+;;   (extend name term s)           → s with NAME → term added
+;;   (occurs? name term s)          → bool
+;;
+;; Unify (symmetric, miniKanren-flavour)
+;; -------------------------------------
+;;   (unify u v s)                  → extended subst or nil
+;;   (unify-with cfg u v s)         → ditto, with adapter callbacks:
+;;                                      :var? :var-name :ctor? :ctor-head
+;;                                      :ctor-args :occurs-check?
+;;
+;; Match (asymmetric, haskell-flavour: pattern → value, vars only in pat)
+;; ---------------------------------------------------------------------
+;;   (match-pat pat val env)        → extended env or nil
+;;   (match-pat-with cfg pat val env)
+
+(define mk-var  (fn (name) (list :var name)))
+(define mk-ctor (fn (head args) (list :ctor head args)))
+
+(define is-var?    (fn (t) (and (list? t) (not (empty? t)) (= (first t) :var))))
+(define is-ctor?   (fn (t) (and (list? t) (not (empty? t)) (= (first t) :ctor))))
+(define var-name   (fn (t) (nth t 1)))
+(define ctor-head  (fn (t) (nth t 1)))
+(define ctor-args  (fn (t) (nth t 2)))
+
+(define empty-subst (fn () {}))
+
+(define
+  walk
+  (fn (t s)
+    (if (and (is-var? t) (has-key? s (var-name t)))
+      (walk (get s (var-name t)) s)
+      t)))
+
+(define
+  walk*
+  (fn (t s)
+    (let ((w (walk t s)))
+      (cond
+        ((is-ctor? w)
+          (mk-ctor (ctor-head w) (map (fn (a) (walk* a s)) (ctor-args w))))
+        (:else w)))))
+
+(define
+  extend
+  (fn (name term s)
+    (assoc s name term)))
+
+(define
+  occurs?
+  (fn (name term s)
+    (let ((w (walk term s)))
+      (cond
+        ((is-var? w) (= (var-name w) name))
+        ((is-ctor? w) (some (fn (a) (occurs? name a s)) (ctor-args w)))
+        (:else false)))))
+
+(define
+  unify-with
+  (fn (cfg u v s)
+    (let ((var?-fn (get cfg :var?))
+          (var-name-fn (get cfg :var-name))
+          (ctor?-fn (get cfg :ctor?))
+          (ctor-head-fn (get cfg :ctor-head))
+          (ctor-args-fn (get cfg :ctor-args))
+          (occurs?-on (get cfg :occurs-check?)))
+      (let ((wu (walk-with cfg u s))
+            (wv (walk-with cfg v s)))
+        (cond
+          ((and (var?-fn wu) (var?-fn wv) (= (var-name-fn wu) (var-name-fn wv))) s)
+          ((var?-fn wu)
+            (if (and occurs?-on (occurs-with cfg (var-name-fn wu) wv s))
+              nil
+              (extend (var-name-fn wu) wv s)))
+          ((var?-fn wv)
+            (if (and occurs?-on (occurs-with cfg (var-name-fn wv) wu s))
+              nil
+              (extend (var-name-fn wv) wu s)))
+          ((and (ctor?-fn wu) (ctor?-fn wv))
+            (if (= (ctor-head-fn wu) (ctor-head-fn wv))
+              (unify-list-with
+                cfg
+                (ctor-args-fn wu)
+                (ctor-args-fn wv)
+                s)
+              nil))
+          (:else (if (= wu wv) s nil)))))))
+
+(define
+  walk-with
+  (fn (cfg t s)
+    (if (and ((get cfg :var?) t) (has-key? s ((get cfg :var-name) t)))
+      (walk-with cfg (get s ((get cfg :var-name) t)) s)
+      t)))
+
+(define
+  occurs-with
+  (fn (cfg name term s)
+    (let ((w (walk-with cfg term s)))
+      (cond
+        (((get cfg :var?) w) (= ((get cfg :var-name) w) name))
+        (((get cfg :ctor?) w)
+          (some (fn (a) (occurs-with cfg name a s)) ((get cfg :ctor-args) w)))
+        (:else false)))))
+
+(define
+  unify-list-with
+  (fn (cfg xs ys s)
+    (cond
+      ((and (empty? xs) (empty? ys)) s)
+      ((or (empty? xs) (empty? ys)) nil)
+      (:else
+        (let ((s2 (unify-with cfg (first xs) (first ys) s)))
+          (if (= s2 nil)
+            nil
+            (unify-list-with cfg (rest xs) (rest ys) s2)))))))
+
+(define canonical-cfg
+  {:var? is-var? :var-name var-name
+   :ctor? is-ctor? :ctor-head ctor-head :ctor-args ctor-args
+   :occurs-check? true})
+
+(define unify (fn (u v s) (unify-with canonical-cfg u v s)))
+
+;; Asymmetric pattern match (haskell-style): only patterns may contain vars;
+;; values are concrete. On a var pattern, bind name to value.
+(define
+  match-pat-with
+  (fn (cfg pat val env)
+    (let ((var?-fn (get cfg :var?))
+          (var-name-fn (get cfg :var-name))
+          (ctor?-fn (get cfg :ctor?))
+          (ctor-head-fn (get cfg :ctor-head))
+          (ctor-args-fn (get cfg :ctor-args)))
+      (cond
+        ((var?-fn pat) (extend (var-name-fn pat) val env))
+        ((and (ctor?-fn pat) (ctor?-fn val))
+          (if (= (ctor-head-fn pat) (ctor-head-fn val))
+            (match-list-pat-with
+              cfg
+              (ctor-args-fn pat)
+              (ctor-args-fn val)
+              env)
+            nil))
+        ((ctor?-fn pat) nil)
+        (:else (if (= pat val) env nil))))))
+
+(define
+  match-list-pat-with
+  (fn (cfg pats vals env)
+    (cond
+      ((and (empty? pats) (empty? vals)) env)
+      ((or (empty? pats) (empty? vals)) nil)
+      (:else
+        (let ((env2 (match-pat-with cfg (first pats) (first vals) env)))
+          (if (= env2 nil)
+            nil
+            (match-list-pat-with cfg (rest pats) (rest vals) env2)))))))
+
+(define match-pat (fn (pat val env) (match-pat-with canonical-cfg pat val env)))

lib/guest/pratt.sx

@@ -0,0 +1,28 @@
+;; lib/guest/pratt.sx — operator-table format + lookup for Pratt-style
+;; precedence climbing.
+;;
+;; The climbing loop stays per-language because the two canaries use
+;; opposite conventions (Lua: higher prec = tighter; Prolog: lower prec =
+;; tighter, with xfx/xfy/yfx assoc tags). Forcing a single loop adds
+;; callback indirection that obscures more than it shares.
+;;
+;; What IS shared and gets extracted: the operator-table format and lookup.
+;; "Grammar is a dict, not hardcoded cond."
+;;
+;; Entry shape: (NAME PREC ASSOC).
+;;   NAME   — string, the operator's source token.
+;;   PREC   — integer, in the host's own convention.
+;;   ASSOC  — :left | :right | :none for languages with traditional
+;;            associativity, or "xfx" / "xfy" / "yfx" for Prolog-style.
+
+(define
+  pratt-op-lookup
+  (fn (table name)
+    (cond
+      ((empty? table) nil)
+      ((= (first (first table)) name) (first table))
+      (:else (pratt-op-lookup (rest table) name)))))
+
+(define pratt-op-name  (fn (entry) (first entry)))
+(define pratt-op-prec  (fn (entry) (nth entry 1)))
+(define pratt-op-assoc (fn (entry) (nth entry 2)))

lib/guest/tests/ast.sx

@@ -0,0 +1,63 @@
+;; lib/guest/tests/ast.sx — exercises every constructor / predicate /
+;; accessor in lib/guest/ast.sx so future ports have a stable contract
+;; to point at.
+
+(define gast-test-pass 0)
+(define gast-test-fail 0)
+(define gast-test-fails (list))
+
+(define
+  gast-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! gast-test-pass (+ gast-test-pass 1))
+      (begin
+        (set! gast-test-fail (+ gast-test-fail 1))
+        (append! gast-test-fails {:name name :expected expected :actual actual})))))
+
+;; Constructors round-trip.
+(gast-test "literal-int"    (ast-literal-value (ast-literal 42)) 42)
+(gast-test "literal-str"    (ast-literal-value (ast-literal "hi")) "hi")
+(gast-test "literal-bool"   (ast-literal-value (ast-literal true)) true)
+(gast-test "var-name"       (ast-var-name (ast-var "x")) "x")
+(gast-test "app-fn"         (ast-app-fn (ast-app (ast-var "f") (list (ast-literal 1)))) (ast-var "f"))
+(gast-test "app-args-len"   (len (ast-app-args (ast-app (ast-var "f") (list (ast-literal 1))))) 1)
+(gast-test "lambda-params"  (ast-lambda-params (ast-lambda (list "x" "y") (ast-var "x"))) (list "x" "y"))
+(gast-test "lambda-body"    (ast-lambda-body (ast-lambda (list "x") (ast-var "x"))) (ast-var "x"))
+(gast-test "let-bindings"   (len (ast-let-bindings (ast-let (list {:name "x" :value (ast-literal 1)}) (ast-var "x")))) 1)
+(gast-test "letrec-body"    (ast-letrec-body (ast-letrec (list) (ast-literal 0))) (ast-literal 0))
+(gast-test "if-test"        (ast-if-test (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal true))
+(gast-test "if-then"        (ast-if-then (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 1))
+(gast-test "if-else"        (ast-if-else (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 0))
+(gast-test "match-pattern"  (ast-match-clause-pattern (ast-match-clause "P" (ast-literal 1))) "P")
+(gast-test "match-body"     (ast-match-clause-body (ast-match-clause "P" (ast-literal 1))) (ast-literal 1))
+(gast-test "module-name"    (ast-module-name (ast-module "m" (list))) "m")
+(gast-test "import-name"    (ast-import-name (ast-import "lib/foo")) "lib/foo")
+
+;; Predicates fire only on matching kinds.
+(gast-test "is-literal"     (ast-literal? (ast-literal 1)) true)
+(gast-test "not-literal"    (ast-literal? (ast-var "x")) false)
+(gast-test "is-var"         (ast-var? (ast-var "x")) true)
+(gast-test "is-app"         (ast-app? (ast-app (ast-var "f") (list))) true)
+(gast-test "is-lambda"      (ast-lambda? (ast-lambda (list) (ast-literal 0))) true)
+(gast-test "is-let"         (ast-let? (ast-let (list) (ast-literal 0))) true)
+(gast-test "is-letrec"      (ast-letrec? (ast-letrec (list) (ast-literal 0))) true)
+(gast-test "is-if"          (ast-if? (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) true)
+(gast-test "is-match"       (ast-match-clause? (ast-match-clause "P" (ast-literal 1))) true)
+(gast-test "is-module"      (ast-module? (ast-module "m" (list))) true)
+(gast-test "is-import"      (ast-import? (ast-import "x")) true)
+
+;; ast? recognises any canonical node.
+(gast-test "ast?-literal"   (ast? (ast-literal 0)) true)
+(gast-test "ast?-foreign"   (ast? (list "lua-num" 0)) false)
+(gast-test "ast?-non-list"  (ast? 42) false)
+
+;; ast-kind dispatch.
+(gast-test "kind-literal"   (ast-kind (ast-literal 0)) :literal)
+(gast-test "kind-import"    (ast-kind (ast-import "x")) :import)
+
+(define gast-tests-run!
+  (fn ()
+    {:passed gast-test-pass
+     :failed gast-test-fail
+     :total  (+ gast-test-pass gast-test-fail)}))

lib/guest/tests/hm.sx

@@ -0,0 +1,89 @@
+;; lib/guest/tests/hm.sx — exercises lib/guest/hm.sx algebra.
+
+(define ghm-test-pass 0)
+(define ghm-test-fail 0)
+(define ghm-test-fails (list))
+
+(define
+  ghm-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! ghm-test-pass (+ ghm-test-pass 1))
+      (begin
+        (set! ghm-test-fail (+ ghm-test-fail 1))
+        (append! ghm-test-fails {:name name :expected expected :actual actual})))))
+
+;; ── Type constructors ─────────────────────────────────────────────
+(ghm-test "tv"           (hm-tv "a") (list :var "a"))
+(ghm-test "int"          (hm-int)    (list :ctor "Int" (list)))
+(ghm-test "arrow"        (ctor-head (hm-arrow (hm-int) (hm-bool))) "->")
+(ghm-test "arrow-args-len" (len (ctor-args (hm-arrow (hm-int) (hm-bool)))) 2)
+
+;; ── Schemes ───────────────────────────────────────────────────────
+(ghm-test "scheme-vars"  (hm-scheme-vars (hm-scheme (list "a") (hm-tv "a"))) (list "a"))
+(ghm-test "monotype-vars" (hm-scheme-vars (hm-monotype (hm-int))) (list))
+(ghm-test "scheme?-yes"  (hm-scheme? (hm-monotype (hm-int))) true)
+(ghm-test "scheme?-no"   (hm-scheme? (hm-int)) false)
+
+;; ── Fresh tyvars ──────────────────────────────────────────────────
+(ghm-test "fresh-1"
+  (let ((c (list 0))) (var-name (hm-fresh-tv c))) "t1")
+(ghm-test "fresh-bumps"
+  (let ((c (list 5))) (begin (hm-fresh-tv c) (first c))) 6)
+
+;; ── Free type variables ──────────────────────────────────────────
+(ghm-test "ftv-int"      (hm-ftv (hm-int)) (list))
+(ghm-test "ftv-tv"       (hm-ftv (hm-tv "a")) (list "a"))
+(ghm-test "ftv-arrow"
+  (len (hm-ftv (hm-arrow (hm-tv "a") (hm-arrow (hm-tv "b") (hm-tv "a"))))) 2)
+(ghm-test "ftv-scheme-quantified"
+  (hm-ftv-scheme (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "b")))) (list "b"))
+(ghm-test "ftv-env"
+  (let ((env (assoc {} "f" (hm-monotype (hm-arrow (hm-tv "x") (hm-tv "y"))))))
+    (len (hm-ftv-env env))) 2)
+
+;; ── Substitution / apply / compose ───────────────────────────────
+(ghm-test "apply-tv"
+  (hm-apply (assoc {} "a" (hm-int)) (hm-tv "a")) (hm-int))
+(ghm-test "apply-arrow"
+  (ctor-head
+    (hm-apply (assoc {} "a" (hm-int))
+              (hm-arrow (hm-tv "a") (hm-tv "b")))) "->")
+(ghm-test "compose-1-then-2"
+  (var-name
+    (hm-apply
+      (hm-compose (assoc {} "b" (hm-tv "c")) (assoc {} "a" (hm-tv "b")))
+      (hm-tv "a"))) "c")
+
+;; ── Generalize / Instantiate ─────────────────────────────────────
+;;   forall a. a -> a   instantiated twice yields fresh vars each time
+(ghm-test "generalize-id"
+  (len (hm-scheme-vars (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "a")) {}))) 1)
+
+(ghm-test "generalize-skips-env"
+  ;; ftv(t)={a,b}, ftv(env)={a}, qs={b}
+  (let ((env (assoc {} "x" (hm-monotype (hm-tv "a")))))
+    (len (hm-scheme-vars
+           (hm-generalize (hm-arrow (hm-tv "a") (hm-tv "b")) env)))) 1)
+
+(ghm-test "instantiate-fresh"
+  (let ((s (hm-scheme (list "a") (hm-arrow (hm-tv "a") (hm-tv "a"))))
+        (c (list 0)))
+    (let ((t1 (hm-instantiate s c)) (t2 (hm-instantiate s c)))
+      (not (= (var-name (first (ctor-args t1)))
+              (var-name (first (ctor-args t2)))))))
+  true)
+
+;; ── Inference (literal only) ─────────────────────────────────────
+(ghm-test "infer-int"
+  (ctor-head (get (hm-infer-literal (ast-literal 42)) :type)) "Int")
+(ghm-test "infer-string"
+  (ctor-head (get (hm-infer-literal (ast-literal "hi")) :type)) "String")
+(ghm-test "infer-bool"
+  (ctor-head (get (hm-infer-literal (ast-literal true)) :type)) "Bool")
+
+(define ghm-tests-run!
+  (fn ()
+    {:passed ghm-test-pass
+     :failed ghm-test-fail
+     :total  (+ ghm-test-pass ghm-test-fail)}))

lib/guest/tests/layout.sx

@@ -0,0 +1,180 @@
+;; lib/guest/tests/layout.sx — synthetic Python-ish off-side fixture.
+;;
+;; Exercises lib/guest/layout.sx with a config different from Haskell's
+;; (no module-prelude, layout opens via trailing `:` not via reserved
+;; keyword) to prove the kit isn't Haskell-shaped.
+
+(define glayout-test-pass 0)
+(define glayout-test-fail 0)
+(define glayout-test-fails (list))
+
+(define
+  glayout-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! glayout-test-pass (+ glayout-test-pass 1))
+      (begin
+        (set! glayout-test-fail (+ glayout-test-fail 1))
+        (append! glayout-test-fails {:name name :expected expected :actual actual})))))
+
+;; Convenience: build a token from {type value line col}.
+(define
+  glayout-tok
+  (fn (ty val line col)
+    {:type ty :value val :line line :col col}))
+
+;; Project a token list to ((type value) ...) for compact comparison.
+(define
+  glayout-shape
+  (fn (toks)
+    (map (fn (t) (list (get t :type) (get t :value))) toks)))
+
+;; ── Haskell-flavour: keyword opens block ─────────────────────────
+(define
+  glayout-haskell-cfg
+  {:open-keywords (list "let" "where" "do" "of")
+   :open-trailing-fn nil
+   :open-token   {:type "vlbrace" :value "{"}
+   :close-token  {:type "vrbrace" :value "}"}
+   :sep-token    {:type "vsemi"   :value ";"}
+   :module-prelude? false
+   :explicit-open? (fn (tok) (= (get tok :type) "lbrace"))})
+
+;;   do
+;;     a
+;;     b
+;;   c       ← outside the do-block
+(glayout-test "haskell-do-block"
+  (glayout-shape
+    (layout-pass
+      glayout-haskell-cfg
+      (list (glayout-tok "reserved" "do" 1 1)
+            (glayout-tok "ident" "a" 2 3)
+            (glayout-tok "ident" "b" 3 3)
+            (glayout-tok "ident" "c" 4 1))))
+  (list (list "reserved" "do")
+        (list "vlbrace" "{")
+        (list "ident" "a")
+        (list "vsemi" ";")
+        (list "ident" "b")
+        (list "vrbrace" "}")
+        (list "ident" "c")))
+
+;; Explicit `{` after `do` suppresses virtual layout.
+(glayout-test "haskell-explicit-brace"
+  (glayout-shape
+    (layout-pass
+      glayout-haskell-cfg
+      (list (glayout-tok "reserved" "do" 1 1)
+            (glayout-tok "lbrace" "{" 1 4)
+            (glayout-tok "ident" "a" 1 6)
+            (glayout-tok "rbrace" "}" 1 8))))
+  (list (list "reserved" "do")
+        (list "lbrace" "{")
+        (list "ident" "a")
+        (list "rbrace" "}")))
+
+;; Single-statement do-block on the same line.
+(glayout-test "haskell-do-inline"
+  (glayout-shape
+    (layout-pass
+      glayout-haskell-cfg
+      (list (glayout-tok "reserved" "do" 1 1)
+            (glayout-tok "ident" "a" 1 4))))
+  (list (list "reserved" "do")
+        (list "vlbrace" "{")
+        (list "ident" "a")
+        (list "vrbrace" "}")))
+
+;; Module-prelude: wrap whole input in implicit layout block at first
+;; tok's column.
+(glayout-test "haskell-module-prelude"
+  (glayout-shape
+    (layout-pass
+      (assoc glayout-haskell-cfg :module-prelude? true)
+      (list (glayout-tok "ident" "x" 1 1)
+            (glayout-tok "ident" "y" 2 1)
+            (glayout-tok "ident" "z" 3 1))))
+  (list (list "vlbrace" "{")
+        (list "ident" "x")
+        (list "vsemi" ";")
+        (list "ident" "y")
+        (list "vsemi" ";")
+        (list "ident" "z")
+        (list "vrbrace" "}")))
+
+;; ── Python-flavour: trailing `:` opens block ─────────────────────
+(define
+  glayout-python-cfg
+  {:open-keywords (list)
+   :open-trailing-fn (fn (tok) (and (= (get tok :type) "punct")
+                                    (= (get tok :value) ":")))
+   :open-token   {:type "indent" :value "INDENT"}
+   :close-token  {:type "dedent" :value "DEDENT"}
+   :sep-token    {:type "newline" :value "NEWLINE"}
+   :module-prelude? false
+   :explicit-open? nil})
+
+;;   if x:
+;;       a
+;;       b
+;;   c
+(glayout-test "python-if-block"
+  (glayout-shape
+    (layout-pass
+      glayout-python-cfg
+      (list (glayout-tok "reserved" "if" 1 1)
+            (glayout-tok "ident" "x" 1 4)
+            (glayout-tok "punct" ":" 1 5)
+            (glayout-tok "ident" "a" 2 5)
+            (glayout-tok "ident" "b" 3 5)
+            (glayout-tok "ident" "c" 4 1))))
+  (list (list "reserved" "if")
+        (list "ident" "x")
+        (list "punct" ":")
+        (list "indent" "INDENT")
+        (list "ident" "a")
+        (list "newline" "NEWLINE")
+        (list "ident" "b")
+        (list "dedent" "DEDENT")
+        (list "ident" "c")))
+
+;; Nested Python-style blocks.
+;;   def f():
+;;       if x:
+;;           a
+;;       b
+(glayout-test "python-nested"
+  (glayout-shape
+    (layout-pass
+      glayout-python-cfg
+      (list (glayout-tok "reserved" "def" 1 1)
+            (glayout-tok "ident" "f" 1 5)
+            (glayout-tok "punct" "(" 1 6)
+            (glayout-tok "punct" ")" 1 7)
+            (glayout-tok "punct" ":" 1 8)
+            (glayout-tok "reserved" "if" 2 5)
+            (glayout-tok "ident" "x" 2 8)
+            (glayout-tok "punct" ":" 2 9)
+            (glayout-tok "ident" "a" 3 9)
+            (glayout-tok "ident" "b" 4 5))))
+  (list (list "reserved" "def")
+        (list "ident" "f")
+        (list "punct" "(")
+        (list "punct" ")")
+        (list "punct" ":")
+        (list "indent" "INDENT")
+        (list "reserved" "if")
+        (list "ident" "x")
+        (list "punct" ":")
+        (list "indent" "INDENT")
+        (list "ident" "a")
+        (list "dedent" "DEDENT")
+        (list "ident" "b")
+        (list "dedent" "DEDENT")))
+
+(define glayout-tests-run!
+  (fn ()
+    {:passed glayout-test-pass
+     :failed glayout-test-fail
+     :total  (+ glayout-test-pass glayout-test-fail)}))

lib/guest/tests/match.sx

@@ -0,0 +1,108 @@
+;; lib/guest/tests/match.sx — exercises lib/guest/match.sx.
+
+(define gmatch-test-pass 0)
+(define gmatch-test-fail 0)
+(define gmatch-test-fails (list))
+
+(define
+  gmatch-test
+  (fn (name actual expected)
+    (if (= actual expected)
+      (set! gmatch-test-pass (+ gmatch-test-pass 1))
+      (begin
+        (set! gmatch-test-fail (+ gmatch-test-fail 1))
+        (append! gmatch-test-fails {:name name :expected expected :actual actual})))))
+
+;; ── walk / extend / occurs ────────────────────────────────────────
+(gmatch-test "walk-direct"
+  (walk (mk-var "x") (extend "x" 5 (empty-subst))) 5)
+
+(gmatch-test "walk-chain"
+  (walk (mk-var "a") (extend "a" (mk-var "b") (extend "b" 7 (empty-subst)))) 7)
+
+(gmatch-test "walk-no-binding"
+  (let ((v (mk-var "u"))) (= (walk v (empty-subst)) v)) true)
+
+(gmatch-test "walk*-recursive"
+  (walk* (mk-ctor "Just" (list (mk-var "x"))) (extend "x" 9 (empty-subst)))
+  (mk-ctor "Just" (list 9)))
+
+(gmatch-test "occurs-direct"
+  (occurs? "x" (mk-var "x") (empty-subst)) true)
+
+(gmatch-test "occurs-nested"
+  (occurs? "x" (mk-ctor "f" (list (mk-var "x"))) (empty-subst)) true)
+
+(gmatch-test "occurs-not"
+  (occurs? "x" (mk-var "y") (empty-subst)) false)
+
+;; ── unify (symmetric) ─────────────────────────────────────────────
+(gmatch-test "unify-equal-literals"
+  (len (unify 5 5 (empty-subst))) 0)
+
+(gmatch-test "unify-different-literals"
+  (unify 5 6 (empty-subst)) nil)
+
+(gmatch-test "unify-var-literal"
+  (get (unify (mk-var "x") 5 (empty-subst)) "x") 5)
+
+(gmatch-test "unify-literal-var"
+  (get (unify 5 (mk-var "x") (empty-subst)) "x") 5)
+
+(gmatch-test "unify-same-var"
+  (len (unify (mk-var "x") (mk-var "x") (empty-subst))) 0)
+
+(gmatch-test "unify-two-vars"
+  (let ((s (unify (mk-var "x") (mk-var "y") (empty-subst))))
+    (or (= (get s "x") (mk-var "y")) (= (get s "y") (mk-var "x")))) true)
+
+(gmatch-test "unify-ctor-equal"
+  (len (unify (mk-ctor "f" (list 1 2)) (mk-ctor "f" (list 1 2)) (empty-subst))) 0)
+
+(gmatch-test "unify-ctor-with-var"
+  (get (unify (mk-ctor "Just" (list (mk-var "x"))) (mk-ctor "Just" (list 7)) (empty-subst)) "x") 7)
+
+(gmatch-test "unify-ctor-head-mismatch"
+  (unify (mk-ctor "Just" (list 1)) (mk-ctor "Nothing" (list)) (empty-subst)) nil)
+
+(gmatch-test "unify-ctor-arity-mismatch"
+  (unify (mk-ctor "f" (list 1 2)) (mk-ctor "f" (list 1)) (empty-subst)) nil)
+
+(gmatch-test "unify-occurs-check"
+  (unify (mk-var "x") (mk-ctor "f" (list (mk-var "x"))) (empty-subst)) nil)
+
+(gmatch-test "unify-transitive-vars"
+  (let ((s (unify (mk-var "x") (mk-var "y") (empty-subst))))
+    (let ((s2 (unify (mk-var "y") 42 s)))
+      (walk (mk-var "x") s2))) 42)
+
+;; ── match-pat (asymmetric) ────────────────────────────────────────
+(gmatch-test "match-var-binds"
+  (get (match-pat (mk-var "x") 99 (empty-subst)) "x") 99)
+
+(gmatch-test "match-literal-equal"
+  (len (match-pat 5 5 (empty-subst))) 0)
+
+(gmatch-test "match-literal-mismatch"
+  (match-pat 5 6 (empty-subst)) nil)
+
+(gmatch-test "match-ctor-binds"
+  (get (match-pat (mk-ctor "Just" (list (mk-var "y")))
+                  (mk-ctor "Just" (list 11))
+                  (empty-subst)) "y") 11)
+
+(gmatch-test "match-ctor-head-mismatch"
+  (match-pat (mk-ctor "Just" (list (mk-var "y")))
+             (mk-ctor "Nothing" (list))
+             (empty-subst)) nil)
+
+(gmatch-test "match-ctor-arity-mismatch"
+  (match-pat (mk-ctor "f" (list (mk-var "x") (mk-var "y")))
+             (mk-ctor "f" (list 1))
+             (empty-subst)) nil)
+
+(define gmatch-tests-run!
+  (fn ()
+    {:passed gmatch-test-pass
+     :failed gmatch-test-fail
+     :total  (+ gmatch-test-pass gmatch-test-fail)}))

lib/haskell/conformance.conf

@@ -14,6 +14,8 @@ PRELOADS=(
   lib/haskell/runtime.sx
   lib/haskell/match.sx
   lib/haskell/eval.sx
+  lib/haskell/map.sx
+  lib/haskell/set.sx
   lib/haskell/testlib.sx
 )
 
@@ -36,6 +38,24 @@ SUITES=(
   "matrix:lib/haskell/tests/program-matrix.sx"
   "wordcount:lib/haskell/tests/program-wordcount.sx"
   "powers:lib/haskell/tests/program-powers.sx"
+  "caesar:lib/haskell/tests/program-caesar.sx"
+  "runlength-str:lib/haskell/tests/program-runlength-str.sx"
+  "showadt:lib/haskell/tests/program-showadt.sx"
+  "showio:lib/haskell/tests/program-showio.sx"
+  "partial:lib/haskell/tests/program-partial.sx"
+  "statistics:lib/haskell/tests/program-statistics.sx"
+  "newton:lib/haskell/tests/program-newton.sx"
+  "wordfreq:lib/haskell/tests/program-wordfreq.sx"
+  "mapgraph:lib/haskell/tests/program-mapgraph.sx"
+  "uniquewords:lib/haskell/tests/program-uniquewords.sx"
+  "setops:lib/haskell/tests/program-setops.sx"
+  "shapes:lib/haskell/tests/program-shapes.sx"
+  "person:lib/haskell/tests/program-person.sx"
+  "config:lib/haskell/tests/program-config.sx"
+  "counter:lib/haskell/tests/program-counter.sx"
+  "accumulate:lib/haskell/tests/program-accumulate.sx"
+  "safediv:lib/haskell/tests/program-safediv.sx"
+  "trycatch:lib/haskell/tests/program-trycatch.sx"
 )
 
 emit_scoreboard_json() {

lib/haskell/desugar.sx

@@ -131,119 +131,280 @@
         (let
           ((tag (first node)))
           (cond
-            ;; Transformations
             ((= tag "where")
               (list
-                :let
-                (map hk-desugar (nth node 2))
+                :let (map hk-desugar (nth node 2))
                 (hk-desugar (nth node 1))))
             ((= tag "guarded") (hk-guards-to-if (nth node 1)))
             ((= tag "list-comp")
-              (hk-lc-desugar
-                (hk-desugar (nth node 1))
-                (nth node 2)))
-
-            ;; Expression nodes
+              (hk-lc-desugar (hk-desugar (nth node 1)) (nth node 2)))
             ((= tag "app")
               (list
-                :app
-                (hk-desugar (nth node 1))
+                :app (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))))
+            ((= tag "p-rec")
+              (let
+                ((cname (nth node 1))
+                  (field-pats (nth node 2))
+                  (field-order (hk-record-field-names cname)))
+                (cond
+                  ((nil? field-order)
+                    (raise (str "p-rec: no record info for " cname)))
+                  (:else
+                    (list
+                      :p-con
+                      cname
+                      (map
+                        (fn
+                          (fname)
+                          (let
+                            ((p (hk-find-rec-pair field-pats fname)))
+                            (cond
+                              ((nil? p) (list :p-wild))
+                              (:else (hk-desugar (nth p 1))))))
+                        field-order))))))
+            ((= tag "rec-update")
+              (list
+                :rec-update
+                (hk-desugar (nth node 1))
+                (map
+                  (fn (p) (list (first p) (hk-desugar (nth p 1))))
+                  (nth node 2))))
+            ((= tag "rec-create")
+              (let
+                ((cname (nth node 1))
+                  (field-pairs (nth node 2))
+                  (field-order (hk-record-field-names cname)))
+                (cond
+                  ((nil? field-order)
+                    (raise (str "rec-create: no record info for " cname)))
+                  (:else
+                    (let
+                      ((acc (list :con cname)))
+                      (begin
+                        (for-each
+                          (fn
+                            (fname)
+                            (let
+                              ((pair
+                                  (hk-find-rec-pair field-pairs fname)))
+                              (cond
+                                ((nil? pair)
+                                  (raise
+                                    (str
+                                      "rec-create: missing field "
+                                      fname
+                                      " for "
+                                      cname)))
+                                (:else
+                                  (set!
+                                    acc
+                                    (list
+                                      :app
+                                      acc
+                                      (hk-desugar (nth pair 1))))))))
+                          field-order)
+                        acc))))))
             ((= tag "op")
               (list
-                :op
-                (nth node 1)
+                :op (nth node 1)
                 (hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
             ((= tag "neg") (list :neg (hk-desugar (nth node 1))))
             ((= tag "if")
               (list
-                :if
-                (hk-desugar (nth node 1))
+                :if (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
-            ((= tag "tuple")
-              (list :tuple (map hk-desugar (nth node 1))))
-            ((= tag "list")
-              (list :list (map hk-desugar (nth node 1))))
+            ((= tag "tuple") (list :tuple (map hk-desugar (nth node 1))))
+            ((= tag "list") (list :list (map hk-desugar (nth node 1))))
             ((= tag "range")
               (list
-                :range
-                (hk-desugar (nth node 1))
+                :range (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))))
             ((= tag "range-step")
               (list
-                :range-step
-                (hk-desugar (nth node 1))
+                :range-step (hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
             ((= tag "lambda")
-              (list
-                :lambda
-                (nth node 1)
-                (hk-desugar (nth node 2))))
+              (list :lambda (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "let")
               (list
-                :let
-                (map hk-desugar (nth node 1))
+                :let (map hk-desugar (nth node 1))
                 (hk-desugar (nth node 2))))
             ((= tag "case")
               (list
-                :case
-                (hk-desugar (nth node 1))
+                :case (hk-desugar (nth node 1))
                 (map hk-desugar (nth node 2))))
             ((= tag "alt")
-              (list :alt (nth node 1) (hk-desugar (nth node 2))))
+              (list :alt (hk-desugar (nth node 1)) (hk-desugar (nth node 2))))
             ((= tag "do") (hk-desugar-do (nth node 1)))
             ((= tag "sect-left")
-              (list
-                :sect-left
-                (nth node 1)
-                (hk-desugar (nth node 2))))
+              (list :sect-left (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "sect-right")
-              (list
-                :sect-right
-                (nth node 1)
-                (hk-desugar (nth node 2))))
-
-            ;; Top-level
+              (list :sect-right (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "program")
-              (list :program (map hk-desugar (nth node 1))))
+              (list :program (map hk-desugar (hk-expand-records (nth node 1)))))
             ((= tag "module")
               (list
-                :module
-                (nth node 1)
+                :module (nth node 1)
                 (nth node 2)
                 (nth node 3)
-                (map hk-desugar (nth node 4))))
-
-            ;; Decls carrying a body
+                (map hk-desugar (hk-expand-records (nth node 4)))))
             ((= tag "fun-clause")
               (list
-                :fun-clause
-                (nth node 1)
-                (nth node 2)
+                :fun-clause (nth node 1)
+                (map hk-desugar (nth node 2))
                 (hk-desugar (nth node 3))))
+            ((= tag "instance-decl")
+              (list
+                :instance-decl (nth node 1)
+                (nth node 2)
+                (map hk-desugar (nth node 3))))
             ((= tag "pat-bind")
-              (list
-                :pat-bind
-                (nth node 1)
-                (hk-desugar (nth node 2))))
+              (list :pat-bind (nth node 1) (hk-desugar (nth node 2))))
             ((= tag "bind")
-              (list
-                :bind
-                (nth node 1)
-                (hk-desugar (nth node 2))))
-
-            ;; Everything else: leaf literals, vars, cons, patterns,
-            ;; types, imports, type-sigs, data / newtype / fixity, …
+              (list :bind (nth node 1) (hk-desugar (nth node 2))))
             (:else node)))))))
 
 ;; Convenience — tokenize + layout + parse + desugar.
-(define
-  hk-core
-  (fn (src) (hk-desugar (hk-parse-top src))))
+(define hk-record-fields (dict))
 
 (define
-  hk-core-expr
-  (fn (src) (hk-desugar (hk-parse src))))
+  hk-register-record-fields!
+  (fn (cname fields) (dict-set! hk-record-fields cname fields)))
+
+(define
+  hk-record-field-names
+  (fn
+    (cname)
+    (if (has-key? hk-record-fields cname) (get hk-record-fields cname) nil)))
+
+(define
+  hk-record-field-index
+  (fn
+    (cname fname)
+    (let
+      ((fields (hk-record-field-names cname)))
+      (cond
+        ((nil? fields) -1)
+        (:else
+          (let
+            ((i 0) (idx -1))
+            (begin
+              (for-each
+                (fn
+                  (f)
+                  (begin (when (= f fname) (set! idx i)) (set! i (+ i 1))))
+                fields)
+              idx)))))))
+
+(define
+  hk-find-rec-pair
+  (fn
+    (pairs name)
+    (cond
+      ((empty? pairs) nil)
+      ((= (first (first pairs)) name) (first pairs))
+      (:else (hk-find-rec-pair (rest pairs) name)))))
+
+(define
+  hk-record-accessors
+  (fn
+    (cname rec-fields)
+    (let
+      ((n (len rec-fields)) (i 0) (out (list)))
+      (define
+        hk-ra-loop
+        (fn
+          ()
+          (when
+            (< i n)
+            (let
+              ((field (nth rec-fields i)))
+              (let
+                ((fname (first field)) (j 0) (pats (list)))
+                (define
+                  hk-pat-loop
+                  (fn
+                    ()
+                    (when
+                      (< j n)
+                      (begin
+                        (append!
+                          pats
+                          (if
+                            (= j i)
+                            (list "p-var" "__rec_field")
+                            (list "p-wild")))
+                        (set! j (+ j 1))
+                        (hk-pat-loop)))))
+                (hk-pat-loop)
+                (append!
+                  out
+                  (list
+                    "fun-clause"
+                    fname
+                    (list (list "p-con" cname pats))
+                    (list "var" "__rec_field")))
+                (set! i (+ i 1))
+                (hk-ra-loop))))))
+      (hk-ra-loop)
+      out)))
+
+(define
+  hk-expand-records
+  (fn
+    (decls)
+    (let
+      ((out (list)))
+      (for-each
+        (fn
+          (d)
+          (cond
+            ((and (list? d) (= (first d) "data"))
+              (let
+                ((dname (nth d 1))
+                  (tvars (nth d 2))
+                  (cons-list (nth d 3))
+                  (deriving (if (> (len d) 4) (nth d 4) (list)))
+                  (new-cons (list))
+                  (accessors (list)))
+                (begin
+                  (for-each
+                    (fn
+                      (c)
+                      (cond
+                        ((= (first c) "con-rec")
+                          (let
+                            ((cname (nth c 1)) (rec-fields (nth c 2)))
+                            (begin
+                              (hk-register-record-fields!
+                                cname
+                                (map (fn (f) (first f)) rec-fields))
+                              (append!
+                                new-cons
+                                (list
+                                  "con-def"
+                                  cname
+                                  (map (fn (f) (nth f 1)) rec-fields)))
+                              (for-each
+                                (fn (a) (append! accessors a))
+                                (hk-record-accessors cname rec-fields)))))
+                        (:else (append! new-cons c))))
+                    cons-list)
+                  (append!
+                    out
+                    (if
+                      (empty? deriving)
+                      (list "data" dname tvars new-cons)
+                      (list "data" dname tvars new-cons deriving)))
+                  (for-each (fn (a) (append! out a)) accessors))))
+            (:else (append! out d))))
+        decls)
+      out)))
+
+(define hk-core (fn (src) (hk-desugar (hk-parse-top src))))
+
+(define hk-core-expr (fn (src) (hk-desugar (hk-parse src))))

lib/haskell/map.sx

@@ -0,0 +1,520 @@
+;; map.sx — Phase 11 Data.Map: weight-balanced BST in pure SX.
+;;
+;; Algorithm: Adams's weight-balanced tree (the same family as Haskell's
+;; Data.Map). Each node tracks its size; rotations maintain the invariant
+;;
+;;     size(small-side) * delta >= size(large-side)        (delta = 3)
+;;
+;; with single or double rotations chosen by the gamma ratio (gamma = 2).
+;; The size field is an Int and is included so `size`, `lookup`, etc. are
+;; O(log n) on both extremes of the tree.
+;;
+;; Representation:
+;;   Empty → ("Map-Empty")
+;;   Node  → ("Map-Node" key val left right size)
+;;
+;; All operations are pure SX — no mutation of nodes once constructed.
+;; The user-facing Haskell layer (Phase 11 next iteration) wraps these
+;; for `import Data.Map as Map`.
+
+;; ── Constructors ────────────────────────────────────────────
+(define hk-map-empty (list "Map-Empty"))
+
+(define
+  hk-map-node
+  (fn
+    (k v l r)
+    (list "Map-Node" k v l r (+ 1 (+ (hk-map-size l) (hk-map-size r))))))
+
+;; ── Predicates and accessors ────────────────────────────────
+(define hk-map-empty? (fn (m) (and (list? m) (= (first m) "Map-Empty"))))
+
+(define hk-map-node? (fn (m) (and (list? m) (= (first m) "Map-Node"))))
+
+(define
+  hk-map-size
+  (fn (m) (cond ((hk-map-empty? m) 0) (:else (nth m 5)))))
+
+(define hk-map-key (fn (m) (nth m 1)))
+(define hk-map-val (fn (m) (nth m 2)))
+(define hk-map-left (fn (m) (nth m 3)))
+(define hk-map-right (fn (m) (nth m 4)))
+
+;; ── Weight-balanced rotations ───────────────────────────────
+;; delta and gamma per Adams 1992 / Haskell Data.Map.
+
+(define hk-map-delta 3)
+(define hk-map-gamma 2)
+
+(define
+  hk-map-single-l
+  (fn
+    (k v l r)
+    (let
+      ((rk (hk-map-key r))
+        (rv (hk-map-val r))
+        (rl (hk-map-left r))
+        (rr (hk-map-right r)))
+      (hk-map-node rk rv (hk-map-node k v l rl) rr))))
+
+(define
+  hk-map-single-r
+  (fn
+    (k v l r)
+    (let
+      ((lk (hk-map-key l))
+        (lv (hk-map-val l))
+        (ll (hk-map-left l))
+        (lr (hk-map-right l)))
+      (hk-map-node lk lv ll (hk-map-node k v lr r)))))
+
+(define
+  hk-map-double-l
+  (fn
+    (k v l r)
+    (let
+      ((rk (hk-map-key r))
+        (rv (hk-map-val r))
+        (rl (hk-map-left r))
+        (rr (hk-map-right r))
+        (rlk (hk-map-key (hk-map-left r)))
+        (rlv (hk-map-val (hk-map-left r)))
+        (rll (hk-map-left (hk-map-left r)))
+        (rlr (hk-map-right (hk-map-left r))))
+      (hk-map-node
+        rlk
+        rlv
+        (hk-map-node k v l rll)
+        (hk-map-node rk rv rlr rr)))))
+
+(define
+  hk-map-double-r
+  (fn
+    (k v l r)
+    (let
+      ((lk (hk-map-key l))
+        (lv (hk-map-val l))
+        (ll (hk-map-left l))
+        (lr (hk-map-right l))
+        (lrk (hk-map-key (hk-map-right l)))
+        (lrv (hk-map-val (hk-map-right l)))
+        (lrl (hk-map-left (hk-map-right l)))
+        (lrr (hk-map-right (hk-map-right l))))
+      (hk-map-node
+        lrk
+        lrv
+        (hk-map-node lk lv ll lrl)
+        (hk-map-node k v lrr r)))))
+
+;; ── Balanced node constructor ──────────────────────────────
+;; Use this in place of hk-map-node when one side may have grown
+;; or shrunk by one and we need to restore the weight invariant.
+(define
+  hk-map-balance
+  (fn
+    (k v l r)
+    (let
+      ((sl (hk-map-size l)) (sr (hk-map-size r)))
+      (cond
+        ((<= (+ sl sr) 1) (hk-map-node k v l r))
+        ((> sr (* hk-map-delta sl))
+          (let
+            ((rl (hk-map-left r)) (rr (hk-map-right r)))
+            (cond
+              ((< (hk-map-size rl) (* hk-map-gamma (hk-map-size rr)))
+                (hk-map-single-l k v l r))
+              (:else (hk-map-double-l k v l r)))))
+        ((> sl (* hk-map-delta sr))
+          (let
+            ((ll (hk-map-left l)) (lr (hk-map-right l)))
+            (cond
+              ((< (hk-map-size lr) (* hk-map-gamma (hk-map-size ll)))
+                (hk-map-single-r k v l r))
+              (:else (hk-map-double-r k v l r)))))
+        (:else (hk-map-node k v l r))))))
+
+(define
+  hk-map-singleton
+  (fn (k v) (hk-map-node k v hk-map-empty hk-map-empty)))
+
+(define
+  hk-map-insert
+  (fn
+    (k v m)
+    (cond
+      ((hk-map-empty? m) (hk-map-singleton k v))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-insert k v (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-insert k v (hk-map-right m))))
+            (:else (hk-map-node k v (hk-map-left m) (hk-map-right m)))))))))
+
+(define
+  hk-map-lookup
+  (fn
+    (k m)
+    (cond
+      ((hk-map-empty? m) (list "Nothing"))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk) (hk-map-lookup k (hk-map-left m)))
+            ((> k mk) (hk-map-lookup k (hk-map-right m)))
+            (:else (list "Just" (hk-map-val m)))))))))
+
+(define
+  hk-map-member
+  (fn
+    (k m)
+    (cond
+      ((hk-map-empty? m) false)
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk) (hk-map-member k (hk-map-left m)))
+            ((> k mk) (hk-map-member k (hk-map-right m)))
+            (:else true)))))))
+
+(define hk-map-null hk-map-empty?)
+
+(define
+  hk-map-find-min
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-left m))
+        (list (hk-map-key m) (hk-map-val m)))
+      (:else (hk-map-find-min (hk-map-left m))))))
+
+(define
+  hk-map-delete-min
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-left m)) (hk-map-right m))
+      (:else
+        (hk-map-balance
+          (hk-map-key m)
+          (hk-map-val m)
+          (hk-map-delete-min (hk-map-left m))
+          (hk-map-right m))))))
+
+(define
+  hk-map-find-max
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-right m))
+        (list (hk-map-key m) (hk-map-val m)))
+      (:else (hk-map-find-max (hk-map-right m))))))
+
+(define
+  hk-map-delete-max
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? (hk-map-right m)) (hk-map-left m))
+      (:else
+        (hk-map-balance
+          (hk-map-key m)
+          (hk-map-val m)
+          (hk-map-left m)
+          (hk-map-delete-max (hk-map-right m)))))))
+
+(define
+  hk-map-glue
+  (fn
+    (l r)
+    (cond
+      ((hk-map-empty? l) r)
+      ((hk-map-empty? r) l)
+      ((> (hk-map-size l) (hk-map-size r))
+        (let
+          ((mp (hk-map-find-max l)))
+          (hk-map-balance (first mp) (nth mp 1) (hk-map-delete-max l) r)))
+      (:else
+        (let
+          ((mp (hk-map-find-min r)))
+          (hk-map-balance (first mp) (nth mp 1) l (hk-map-delete-min r)))))))
+
+(define
+  hk-map-delete
+  (fn
+    (k m)
+    (cond
+      ((hk-map-empty? m) m)
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-delete k (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-delete k (hk-map-right m))))
+            (:else (hk-map-glue (hk-map-left m) (hk-map-right m)))))))))
+
+(define
+  hk-map-from-list
+  (fn
+    (pairs)
+    (reduce
+      (fn (acc p) (hk-map-insert (first p) (nth p 1) acc))
+      hk-map-empty
+      pairs)))
+
+(define
+  hk-map-to-asc-list
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? m) (list))
+      (:else
+        (append
+          (hk-map-to-asc-list (hk-map-left m))
+          (cons
+            (list (hk-map-key m) (hk-map-val m))
+            (hk-map-to-asc-list (hk-map-right m))))))))
+
+(define hk-map-to-list hk-map-to-asc-list)
+
+(define
+  hk-map-keys
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? m) (list))
+      (:else
+        (append
+          (hk-map-keys (hk-map-left m))
+          (cons (hk-map-key m) (hk-map-keys (hk-map-right m))))))))
+
+(define
+  hk-map-elems
+  (fn
+    (m)
+    (cond
+      ((hk-map-empty? m) (list))
+      (:else
+        (append
+          (hk-map-elems (hk-map-left m))
+          (cons (hk-map-val m) (hk-map-elems (hk-map-right m))))))))
+
+(define
+  hk-map-union-with
+  (fn
+    (f m1 m2)
+    (reduce
+      (fn
+        (acc p)
+        (let
+          ((k (first p)) (v (nth p 1)))
+          (let
+            ((look (hk-map-lookup k acc)))
+            (cond
+              ((= (first look) "Just")
+                (hk-map-insert k (f (nth look 1) v) acc))
+              (:else (hk-map-insert k v acc))))))
+      m1
+      (hk-map-to-asc-list m2))))
+
+(define
+  hk-map-intersection-with
+  (fn
+    (f m1 m2)
+    (reduce
+      (fn
+        (acc p)
+        (let
+          ((k (first p)) (v1 (nth p 1)))
+          (let
+            ((look (hk-map-lookup k m2)))
+            (cond
+              ((= (first look) "Just")
+                (hk-map-insert k (f v1 (nth look 1)) acc))
+              (:else acc)))))
+      hk-map-empty
+      (hk-map-to-asc-list m1))))
+
+(define
+  hk-map-difference
+  (fn
+    (m1 m2)
+    (reduce
+      (fn
+        (acc p)
+        (let
+          ((k (first p)) (v (nth p 1)))
+          (cond ((hk-map-member k m2) acc) (:else (hk-map-insert k v acc)))))
+      hk-map-empty
+      (hk-map-to-asc-list m1))))
+
+(define
+  hk-map-foldl-with-key
+  (fn
+    (f acc m)
+    (cond
+      ((hk-map-empty? m) acc)
+      (:else
+        (let
+          ((acc1 (hk-map-foldl-with-key f acc (hk-map-left m))))
+          (let
+            ((acc2 (f acc1 (hk-map-key m) (hk-map-val m))))
+            (hk-map-foldl-with-key f acc2 (hk-map-right m))))))))
+
+(define
+  hk-map-foldr-with-key
+  (fn
+    (f acc m)
+    (cond
+      ((hk-map-empty? m) acc)
+      (:else
+        (let
+          ((acc1 (hk-map-foldr-with-key f acc (hk-map-right m))))
+          (let
+            ((acc2 (f (hk-map-key m) (hk-map-val m) acc1)))
+            (hk-map-foldr-with-key f acc2 (hk-map-left m))))))))
+
+(define
+  hk-map-map-with-key
+  (fn
+    (f m)
+    (cond
+      ((hk-map-empty? m) m)
+      (:else
+        (list
+          "Map-Node"
+          (hk-map-key m)
+          (f (hk-map-key m) (hk-map-val m))
+          (hk-map-map-with-key f (hk-map-left m))
+          (hk-map-map-with-key f (hk-map-right m))
+          (hk-map-size m))))))
+
+(define
+  hk-map-filter-with-key
+  (fn
+    (p m)
+    (hk-map-foldr-with-key
+      (fn (k v acc) (cond ((p k v) (hk-map-insert k v acc)) (:else acc)))
+      hk-map-empty
+      m)))
+
+(define
+  hk-map-adjust
+  (fn
+    (f k m)
+    (cond
+      ((hk-map-empty? m) m)
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-node
+                mk
+                (hk-map-val m)
+                (hk-map-adjust f k (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-node
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-adjust f k (hk-map-right m))))
+            (:else
+              (hk-map-node
+                mk
+                (f (hk-map-val m))
+                (hk-map-left m)
+                (hk-map-right m)))))))))
+
+(define
+  hk-map-insert-with
+  (fn
+    (f k v m)
+    (cond
+      ((hk-map-empty? m) (hk-map-singleton k v))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-insert-with f k v (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-insert-with f k v (hk-map-right m))))
+            (:else
+              (hk-map-node
+                mk
+                (f v (hk-map-val m))
+                (hk-map-left m)
+                (hk-map-right m)))))))))
+
+(define
+  hk-map-insert-with-key
+  (fn
+    (f k v m)
+    (cond
+      ((hk-map-empty? m) (hk-map-singleton k v))
+      (:else
+        (let
+          ((mk (hk-map-key m)))
+          (cond
+            ((< k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-insert-with-key f k v (hk-map-left m))
+                (hk-map-right m)))
+            ((> k mk)
+              (hk-map-balance
+                mk
+                (hk-map-val m)
+                (hk-map-left m)
+                (hk-map-insert-with-key f k v (hk-map-right m))))
+            (:else
+              (hk-map-node
+                mk
+                (f k v (hk-map-val m))
+                (hk-map-left m)
+                (hk-map-right m)))))))))
+
+(define
+  hk-map-alter
+  (fn
+    (f k m)
+    (let
+      ((look (hk-map-lookup k m)))
+      (let
+        ((res (f look)))
+        (cond
+          ((= (first res) "Nothing") (hk-map-delete k m))
+          (:else (hk-map-insert k (nth res 1) m)))))))

lib/haskell/match.sx

@@ -87,45 +87,41 @@
                   ((nil? res) nil)
                   (:else (assoc res (nth pat 1) val)))))
             (:else
-              (let ((fv (hk-force val)))
+              (let
+                ((fv (hk-force val)))
                 (cond
                   ((= tag "p-int")
-                    (if
-                      (and (number? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (number? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-float")
-                    (if
-                      (and (number? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (number? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-string")
-                    (if
-                      (and (string? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (string? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-char")
-                    (if
-                      (and (string? fv) (= fv (nth pat 1)))
-                      env
-                      nil))
+                    (if (and (string? fv) (= fv (nth pat 1))) env nil))
                   ((= tag "p-con")
                     (let
                       ((pat-name (nth pat 1)) (pat-args (nth pat 2)))
                       (cond
+                        ((and (= pat-name ":") (hk-str? fv) (not (hk-str-null? fv)))
+                          (let
+                            ((str-head (hk-str-head fv))
+                              (str-tail (hk-str-tail fv)))
+                            (let
+                              ((head-pat (nth pat-args 0))
+                                (tail-pat (nth pat-args 1)))
+                              (let
+                                ((res (hk-match head-pat str-head env)))
+                                (cond
+                                  ((nil? res) nil)
+                                  (:else (hk-match tail-pat str-tail res)))))))
                         ((not (hk-is-con-val? fv)) nil)
                         ((not (= (hk-val-con-name fv) pat-name)) nil)
                         (:else
                           (let
                             ((val-args (hk-val-con-args fv)))
                             (cond
-                              ((not (= (len pat-args) (len val-args)))
-                                nil)
-                              (:else
-                                (hk-match-all
-                                  pat-args
-                                  val-args
-                                  env))))))))
+                              ((not (= (len val-args) (len pat-args))) nil)
+                              (:else (hk-match-all pat-args val-args env))))))))
                   ((= tag "p-tuple")
                     (let
                       ((items (nth pat 1)))
@@ -134,13 +130,8 @@
                         ((not (= (hk-val-con-name fv) "Tuple")) nil)
                         ((not (= (len (hk-val-con-args fv)) (len items)))
                           nil)
-                        (:else
-                          (hk-match-all
-                            items
-                            (hk-val-con-args fv)
-                            env)))))
-                  ((= tag "p-list")
-                    (hk-match-list-pat (nth pat 1) fv env))
+                        (:else (hk-match-all items (hk-val-con-args fv) env)))))
+                  ((= tag "p-list") (hk-match-list-pat (nth pat 1) fv env))
                   (:else nil))))))))))
 
 (define
@@ -161,17 +152,26 @@
   hk-match-list-pat
   (fn
     (items val env)
-    (let ((fv (hk-force val)))
+    (let
+      ((fv (hk-force val)))
       (cond
         ((empty? items)
           (if
-            (and
-              (hk-is-con-val? fv)
-              (= (hk-val-con-name fv) "[]"))
+            (or
+              (and (hk-is-con-val? fv) (= (hk-val-con-name fv) "[]"))
+              (and (hk-str? fv) (hk-str-null? fv)))
             env
             nil))
         (:else
           (cond
+            ((and (hk-str? fv) (not (hk-str-null? fv)))
+              (let
+                ((h (hk-str-head fv)) (t (hk-str-tail fv)))
+                (let
+                  ((res (hk-match (first items) h env)))
+                  (cond
+                    ((nil? res) nil)
+                    (:else (hk-match-list-pat (rest items) t res))))))
             ((not (hk-is-con-val? fv)) nil)
             ((not (= (hk-val-con-name fv) ":")) nil)
             (:else
@@ -183,11 +183,7 @@
                     ((res (hk-match (first items) h env)))
                     (cond
                       ((nil? res) nil)
-                      (:else
-                        (hk-match-list-pat
-                          (rest items)
-                          t
-                          res)))))))))))))
+                      (:else (hk-match-list-pat (rest items) t res)))))))))))))
 
 ;; ── Convenience: parse a pattern from source for tests ─────
 ;; (Uses the parser's case-alt entry — `case _ of pat -> 0` —

lib/haskell/parser.sx

@@ -208,9 +208,19 @@
               ((= (get t "type") "char")
                 (do (hk-advance!) (list :char (get t "value"))))
               ((= (get t "type") "varid")
-                (do (hk-advance!) (list :var (get t "value"))))
+                (do
+                  (hk-advance!)
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-update (list :var (get t "value"))))
+                    (:else (list :var (get t "value"))))))
               ((= (get t "type") "conid")
-                (do (hk-advance!) (list :con (get t "value"))))
+                (do
+                  (hk-advance!)
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-create (get t "value")))
+                    (:else (list :con (get t "value"))))))
               ((= (get t "type") "qvarid")
                 (do (hk-advance!) (list :var (get t "value"))))
               ((= (get t "type") "qconid")
@@ -456,6 +466,90 @@
                     (do
                       (hk-expect! "rbracket" nil)
                       (list :list (list first-e))))))))))
+      (define
+        hk-parse-rec-create
+        (fn
+          (cname)
+          (begin
+            (hk-expect! "lbrace" nil)
+            (let
+              ((fields (list)))
+              (define
+                hk-rc-loop
+                (fn
+                  ()
+                  (when
+                    (hk-match? "varid" nil)
+                    (let
+                      ((fname (get (hk-advance!) "value")))
+                      (begin
+                        (hk-expect! "reservedop" "=")
+                        (let
+                          ((fexpr (hk-parse-expr-inner)))
+                          (begin
+                            (append! fields (list fname fexpr))
+                            (when
+                              (hk-match? "comma" nil)
+                              (begin (hk-advance!) (hk-rc-loop))))))))))
+              (hk-rc-loop)
+              (hk-expect! "rbrace" nil)
+              (list :rec-create cname fields)))))
+      (define
+        hk-parse-rec-update
+        (fn
+          (rec-expr)
+          (begin
+            (hk-expect! "lbrace" nil)
+            (let
+              ((fields (list)))
+              (define
+                hk-ru-loop
+                (fn
+                  ()
+                  (when
+                    (hk-match? "varid" nil)
+                    (let
+                      ((fname (get (hk-advance!) "value")))
+                      (begin
+                        (hk-expect! "reservedop" "=")
+                        (let
+                          ((fexpr (hk-parse-expr-inner)))
+                          (begin
+                            (append! fields (list fname fexpr))
+                            (when
+                              (hk-match? "comma" nil)
+                              (begin (hk-advance!) (hk-ru-loop))))))))))
+              (hk-ru-loop)
+              (hk-expect! "rbrace" nil)
+              (list :rec-update rec-expr fields)))))
+      (define
+        hk-parse-rec-pat
+        (fn
+          (cname)
+          (begin
+            (hk-expect! "lbrace" nil)
+            (let
+              ((field-pats (list)))
+              (define
+                hk-rp-loop
+                (fn
+                  ()
+                  (when
+                    (hk-match? "varid" nil)
+                    (let
+                      ((fname (get (hk-advance!) "value")))
+                      (begin
+                        (hk-expect! "reservedop" "=")
+                        (let
+                          ((fpat (hk-parse-pat)))
+                          (begin
+                            (append! field-pats (list fname fpat))
+                            (when
+                              (hk-match? "comma" nil)
+                              (begin (hk-advance!) (hk-rp-loop))))))))))
+              (hk-rp-loop)
+              (hk-expect! "rbrace" nil)
+              (list :p-rec cname field-pats)))))
       (define
         hk-parse-fexp
         (fn
@@ -696,7 +790,12 @@
                     (:else
                       (do (hk-advance!) (list :p-var (get t "value")))))))
               ((= (get t "type") "conid")
-                (do (hk-advance!) (list :p-con (get t "value") (list))))
+                (do
+                  (hk-advance!)
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-pat (get t "value")))
+                    (:else (list :p-con (get t "value") (list))))))
               ((= (get t "type") "qconid")
                 (do (hk-advance!) (list :p-con (get t "value") (list))))
               ((= (get t "type") "lparen") (hk-parse-paren-pat))
@@ -762,16 +861,24 @@
             (cond
               ((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
                 (let
-                  ((name (get (hk-advance!) "value")) (args (list)))
-                  (define
-                    hk-pca-loop
-                    (fn
-                      ()
-                      (when
-                        (hk-apat-start? (hk-peek))
-                        (do (append! args (hk-parse-apat)) (hk-pca-loop)))))
-                  (hk-pca-loop)
-                  (list :p-con name args)))
+                  ((name (get (hk-advance!) "value")))
+                  (cond
+                    ((hk-match? "lbrace" nil)
+                      (hk-parse-rec-pat name))
+                    (:else
+                      (let
+                        ((args (list)))
+                        (define
+                          hk-pca-loop
+                          (fn
+                            ()
+                            (when
+                              (hk-apat-start? (hk-peek))
+                              (do
+                                (append! args (hk-parse-apat))
+                                (hk-pca-loop)))))
+                        (hk-pca-loop)
+                        (list :p-con name args))))))
               (:else (hk-parse-apat))))))
       (define
         hk-parse-pat
@@ -1212,16 +1319,47 @@
             (not (hk-match? "conid" nil))
             (hk-err "expected constructor name"))
           (let
-            ((name (get (hk-advance!) "value")) (fields (list)))
-            (define
-              hk-cd-loop
-              (fn
-                ()
-                (when
-                  (hk-atype-start? (hk-peek))
-                  (do (append! fields (hk-parse-atype)) (hk-cd-loop)))))
-            (hk-cd-loop)
-            (list :con-def name fields))))
+            ((name (get (hk-advance!) "value")))
+            (cond
+              ((hk-match? "lbrace" nil)
+                (begin
+                  (hk-advance!)
+                  (let
+                    ((rec-fields (list)))
+                    (define
+                      hk-rec-loop
+                      (fn
+                        ()
+                        (when
+                          (hk-match? "varid" nil)
+                          (let
+                            ((fname (get (hk-advance!) "value")))
+                            (begin
+                              (hk-expect! "reservedop" "::")
+                              (let
+                                ((ftype (hk-parse-type)))
+                                (begin
+                                  (append! rec-fields (list fname ftype))
+                                  (when
+                                    (hk-match? "comma" nil)
+                                    (begin (hk-advance!) (hk-rec-loop))))))))))
+                    (hk-rec-loop)
+                    (hk-expect! "rbrace" nil)
+                    (list :con-rec name rec-fields))))
+              (:else
+                (let
+                  ((fields (list)))
+                  (define
+                    hk-cd-loop
+                    (fn
+                      ()
+                      (when
+                        (hk-atype-start? (hk-peek))
+                        (begin
+                          (append! fields (hk-parse-atype))
+                          (hk-cd-loop)))))
+                  (hk-cd-loop)
+                  (list :con-def name fields)))))))
       (define
         hk-parse-tvars
         (fn

lib/haskell/runtime.sx

@@ -12,12 +12,7 @@
 
 (define
   hk-register-con!
-  (fn
-    (cname arity type-name)
-    (dict-set!
-      hk-constructors
-      cname
-      {:arity arity :type type-name})))
+  (fn (cname arity type-name) (dict-set! hk-constructors cname {:arity arity :type type-name})))
 
 (define hk-is-con? (fn (name) (has-key? hk-constructors name)))
 
@@ -48,26 +43,15 @@
   (fn
     (data-node)
     (let
-      ((type-name (nth data-node 1))
-        (cons-list (nth data-node 3)))
+      ((type-name (nth data-node 1)) (cons-list (nth data-node 3)))
       (for-each
-        (fn
-          (cd)
-          (hk-register-con!
-            (nth cd 1)
-            (len (nth cd 2))
-            type-name))
+        (fn (cd) (hk-register-con! (nth cd 1) (len (nth cd 2)) type-name))
         cons-list))))
 
 ;; (:newtype NAME TVARS CNAME FIELD)
 (define
   hk-register-newtype!
-  (fn
-    (nt-node)
-    (hk-register-con!
-      (nth nt-node 3)
-      1
-      (nth nt-node 1))))
+  (fn (nt-node) (hk-register-con! (nth nt-node 3) 1 (nth nt-node 1))))
 
 ;; Walk a decls list, registering every `data` / `newtype` decl.
 (define
@@ -78,15 +62,9 @@
       (fn
         (d)
         (cond
-          ((and
-              (list? d)
-              (not (empty? d))
-              (= (first d) "data"))
+          ((and (list? d) (not (empty? d)) (= (first d) "data"))
             (hk-register-data! d))
-          ((and
-              (list? d)
-              (not (empty? d))
-              (= (first d) "newtype"))
+          ((and (list? d) (not (empty? d)) (= (first d) "newtype"))
             (hk-register-newtype! d))
           (:else nil)))
       decls)))
@@ -99,16 +77,12 @@
       ((nil? ast) nil)
       ((not (list? ast)) nil)
       ((empty? ast) nil)
-      ((= (first ast) "program")
-        (hk-register-decls! (nth ast 1)))
-      ((= (first ast) "module")
-        (hk-register-decls! (nth ast 4)))
+      ((= (first ast) "program") (hk-register-decls! (nth ast 1)))
+      ((= (first ast) "module") (hk-register-decls! (nth ast 4)))
       (:else nil))))
 
 ;; Convenience: source → AST → desugar → register.
-(define
-  hk-load-source!
-  (fn (src) (hk-register-program! (hk-core src))))
+(define hk-load-source! (fn (src) (hk-register-program! (hk-core src))))
 
 ;; ── Built-in constructors pre-registered ─────────────────────
 ;; Bool — used implicitly by `if`, comparison operators.
@@ -122,9 +96,55 @@
 ;; Standard Prelude types — pre-registered so expression-level
 ;; programs can use them without a `data` decl.
 (hk-register-con! "Nothing" 0 "Maybe")
-(hk-register-con! "Just"    1 "Maybe")
-(hk-register-con! "Left"    1 "Either")
-(hk-register-con! "Right"   1 "Either")
+(hk-register-con! "Just" 1 "Maybe")
+(hk-register-con! "Left" 1 "Either")
+(hk-register-con! "Right" 1 "Either")
 (hk-register-con! "LT" 0 "Ordering")
 (hk-register-con! "EQ" 0 "Ordering")
 (hk-register-con! "GT" 0 "Ordering")
+(hk-register-con! "SomeException" 1 "SomeException")
+
+(define
+  hk-str?
+  (fn (v) (or (string? v) (and (dict? v) (has-key? v "hk-str")))))
+
+(define
+  hk-str-head
+  (fn
+    (v)
+    (if
+      (string? v)
+      (char-code (char-at v 0))
+      (char-code (char-at (get v "hk-str") (get v "hk-off"))))))
+
+(define
+  hk-str-tail
+  (fn
+    (v)
+    (let
+      ((buf (if (string? v) v (get v "hk-str")))
+        (off (if (string? v) 1 (+ (get v "hk-off") 1))))
+      (if (>= off (string-length buf)) (list "[]") {:hk-off off :hk-str buf}))))
+
+(define
+  hk-str-null?
+  (fn
+    (v)
+    (if
+      (string? v)
+      (= (string-length v) 0)
+      (>= (get v "hk-off") (string-length (get v "hk-str"))))))
+
+(define
+  hk-str-to-native
+  (fn
+    (v)
+    (if
+      (string? v)
+      v
+      (let
+        ((buf (get v "hk-str")) (off (get v "hk-off")))
+        (reduce
+          (fn (acc i) (str acc (char-at buf i)))
+          ""
+          (range off (string-length buf)))))))

lib/haskell/scoreboard.json

@@ -1,6 +1,6 @@
 {
-  "date": "2026-05-06",
-  "total_pass": 156,
+  "date": "2026-05-08",
+  "total_pass": 285,
   "total_fail": 0,
   "programs": {
     "fib": {"pass": 2, "fail": 0},
@@ -9,7 +9,7 @@
     "nqueens": {"pass": 2, "fail": 0},
     "calculator": {"pass": 5, "fail": 0},
     "collatz": {"pass": 11, "fail": 0},
-    "palindrome": {"pass": 8, "fail": 0},
+    "palindrome": {"pass": 12, "fail": 0},
     "maybe": {"pass": 12, "fail": 0},
     "fizzbuzz": {"pass": 12, "fail": 0},
     "anagram": {"pass": 9, "fail": 0},
@@ -19,7 +19,25 @@
     "primes": {"pass": 12, "fail": 0},
     "zipwith": {"pass": 9, "fail": 0},
     "matrix": {"pass": 8, "fail": 0},
-    "wordcount": {"pass": 7, "fail": 0},
-    "powers": {"pass": 14, "fail": 0}
+    "wordcount": {"pass": 10, "fail": 0},
+    "powers": {"pass": 14, "fail": 0},
+    "caesar": {"pass": 8, "fail": 0},
+    "runlength-str": {"pass": 9, "fail": 0},
+    "showadt": {"pass": 5, "fail": 0},
+    "showio": {"pass": 5, "fail": 0},
+    "partial": {"pass": 7, "fail": 0},
+    "statistics": {"pass": 5, "fail": 0},
+    "newton": {"pass": 5, "fail": 0},
+    "wordfreq": {"pass": 7, "fail": 0},
+    "mapgraph": {"pass": 6, "fail": 0},
+    "uniquewords": {"pass": 4, "fail": 0},
+    "setops": {"pass": 8, "fail": 0},
+    "shapes": {"pass": 5, "fail": 0},
+    "person": {"pass": 7, "fail": 0},
+    "config": {"pass": 10, "fail": 0},
+    "counter": {"pass": 7, "fail": 0},
+    "accumulate": {"pass": 8, "fail": 0},
+    "safediv": {"pass": 8, "fail": 0},
+    "trycatch": {"pass": 8, "fail": 0}
   }
 }

lib/haskell/scoreboard.md

@@ -1,6 +1,6 @@
 # Haskell-on-SX Scoreboard
 
-Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
+Updated 2026-05-08 · Phase 6 (prelude extras + 18 programs)
 
 | Program | Tests | Status |
 |---------|-------|--------|
@@ -10,7 +10,7 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
 | nqueens.hs | 2/2 | ✓ |
 | calculator.hs | 5/5 | ✓ |
 | collatz.hs | 11/11 | ✓ |
-| palindrome.hs | 8/8 | ✓ |
+| palindrome.hs | 12/12 | ✓ |
 | maybe.hs | 12/12 | ✓ |
 | fizzbuzz.hs | 12/12 | ✓ |
 | anagram.hs | 9/9 | ✓ |
@@ -20,6 +20,24 @@ Updated 2026-05-06 · Phase 6 (prelude extras + 18 programs)
 | primes.hs | 12/12 | ✓ |
 | zipwith.hs | 9/9 | ✓ |
 | matrix.hs | 8/8 | ✓ |
-| wordcount.hs | 7/7 | ✓ |
+| wordcount.hs | 10/10 | ✓ |
 | powers.hs | 14/14 | ✓ |
-| **Total** | **156/156** | **18/18 programs** |
+| caesar.hs | 8/8 | ✓ |
+| runlength-str.hs | 9/9 | ✓ |
+| showadt.hs | 5/5 | ✓ |
+| showio.hs | 5/5 | ✓ |
+| partial.hs | 7/7 | ✓ |
+| statistics.hs | 5/5 | ✓ |
+| newton.hs | 5/5 | ✓ |
+| wordfreq.hs | 7/7 | ✓ |
+| mapgraph.hs | 6/6 | ✓ |
+| uniquewords.hs | 4/4 | ✓ |
+| setops.hs | 8/8 | ✓ |
+| shapes.hs | 5/5 | ✓ |
+| person.hs | 7/7 | ✓ |
+| config.hs | 10/10 | ✓ |
+| counter.hs | 7/7 | ✓ |
+| accumulate.hs | 8/8 | ✓ |
+| safediv.hs | 8/8 | ✓ |
+| trycatch.hs | 8/8 | ✓ |
+| **Total** | **285/285** | **36/36 programs** |

lib/haskell/set.sx

@@ -0,0 +1,62 @@
+;; set.sx — Phase 12 Data.Set: wraps Data.Map with unit values.
+;;
+;; A Set is a Map from key to (). All set operations delegate to the map
+;; ops, ignoring the value side. Storage representation matches Data.Map:
+;;
+;;   Empty → ("Map-Empty")
+;;   Node  → ("Map-Node" key () left right size)
+;;
+;; Tradeoff: trivial maintenance burden, slight overhead per node from
+;; the unused value slot. Faster path forward than re-implementing the
+;; weight-balanced BST.
+;;
+;; Functions live in this file; the Haskell-level `import Data.Set` /
+;; `import qualified Data.Set as Set` wiring (next Phase 12 box) binds
+;; them under the chosen alias.
+
+(define hk-set-unit (list "Tuple"))
+
+(define hk-set-empty hk-map-empty)
+
+(define hk-set-singleton (fn (k) (hk-map-singleton k hk-set-unit)))
+
+(define hk-set-insert (fn (k s) (hk-map-insert k hk-set-unit s)))
+
+(define hk-set-delete hk-map-delete)
+(define hk-set-member hk-map-member)
+(define hk-set-size hk-map-size)
+(define hk-set-null hk-map-null)
+(define hk-set-to-asc-list hk-map-keys)
+(define hk-set-to-list hk-map-keys)
+
+(define
+  hk-set-from-list
+  (fn (xs) (reduce (fn (acc k) (hk-set-insert k acc)) hk-set-empty xs)))
+
+(define
+  hk-set-union
+  (fn (a b) (hk-map-union-with (fn (x y) hk-set-unit) a b)))
+
+(define
+  hk-set-intersection
+  (fn (a b) (hk-map-intersection-with (fn (x y) hk-set-unit) a b)))
+
+(define hk-set-difference hk-map-difference)
+
+(define
+  hk-set-is-subset-of
+  (fn (a b) (= (hk-map-size (hk-map-difference a b)) 0)))
+
+(define
+  hk-set-filter
+  (fn (p s) (hk-map-filter-with-key (fn (k v) (p k)) s)))
+
+(define hk-set-map (fn (f s) (hk-set-from-list (map f (hk-map-keys s)))))
+
+(define
+  hk-set-foldr
+  (fn (f z s) (hk-map-foldr-with-key (fn (k v acc) (f k acc)) z s)))
+
+(define
+  hk-set-foldl
+  (fn (f z s) (hk-map-foldl-with-key (fn (acc k v) (f acc k)) z s)))

lib/haskell/test.sh

@@ -55,6 +55,8 @@ for FILE in "${FILES[@]}"; do
 (load "lib/haskell/runtime.sx")
 (load "lib/haskell/match.sx")
 (load "lib/haskell/eval.sx")
+(load "lib/haskell/map.sx")
+(load "lib/haskell/set.sx")
 $INFER_LOAD
 (load "lib/haskell/testlib.sx")
 (epoch 2)
@@ -98,6 +100,8 @@ EPOCHS
 (load "lib/haskell/runtime.sx")
 (load "lib/haskell/match.sx")
 (load "lib/haskell/eval.sx")
+(load "lib/haskell/map.sx")
+(load "lib/haskell/set.sx")
 $INFER_LOAD
 (load "lib/haskell/testlib.sx")
 (epoch 2)

lib/haskell/testlib.sx

@@ -56,3 +56,21 @@
         (append!
           hk-test-fails
           {:actual actual :expected expected :name name})))))
+
+(define
+  hk-test-error
+  (fn
+    (name thunk expected-substring)
+    (let
+      ((caught (guard (e (true (if (string? e) e (str e)))) (begin (thunk) nil))))
+      (cond
+        ((nil? caught)
+          (do
+            (set! hk-test-fail (+ hk-test-fail 1))
+            (append! hk-test-fails {:actual "no error raised" :expected (str "error containing: " expected-substring) :name name})))
+        ((>= (index-of caught expected-substring) 0)
+          (set! hk-test-pass (+ hk-test-pass 1)))
+        (:else
+          (do
+            (set! hk-test-fail (+ hk-test-fail 1))
+            (append! hk-test-fails {:actual caught :expected (str "error containing: " expected-substring) :name name})))))))

lib/haskell/tests/class-defaults.sx

@@ -0,0 +1,86 @@
+;; class-defaults.sx — Phase 13: class default method implementations.
+
+;; ── Eq default: myNeq derived from myEq via `not (myEq x y)` ──
+(define
+  hk-myeq-source
+  "class MyEq a where\n  myEq :: a -> a -> Bool\n  myNeq :: a -> a -> Bool\n  myNeq x y = not (myEq x y)\ninstance MyEq Int where\n  myEq x y = x == y\n")
+
+(hk-test
+  "Eq default: myNeq 3 5 = True (no explicit myNeq in instance)"
+  (hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 5\n")))
+  (list "True"))
+
+(hk-test
+  "Eq default: myNeq 3 3 = False"
+  (hk-deep-force (hk-run (str hk-myeq-source "main = myNeq 3 3\n")))
+  (list "False"))
+
+(hk-test
+  "Eq default: myEq still works in same instance"
+  (hk-deep-force (hk-run (str hk-myeq-source "main = myEq 7 7\n")))
+  (list "True"))
+
+;; ── Override path: instance can still provide the method explicitly. ──
+(hk-test
+  "Default override: instance-provided beats class default"
+  (hk-deep-force
+    (hk-run
+      "class Hi a where\n  greet :: a -> String\n  greet x = \"default\"\ninstance Hi Bool where\n  greet x = \"override\"\nmain = greet True"))
+  "override")
+
+(hk-test
+  "Default fallback: empty instance picks default"
+  (hk-deep-force
+    (hk-run
+      "class Hi a where\n  greet :: a -> String\n  greet x = \"default\"\ninstance Hi Bool where\nmain = greet True"))
+  "default")
+
+(define
+  hk-myord-source
+  "class MyOrd a where\n  myCmp :: a -> a -> Bool\n  myMax :: a -> a -> a\n  myMin :: a -> a -> a\n  myMax a b = if myCmp a b then a else b\n  myMin a b = if myCmp a b then b else a\ninstance MyOrd Int where\n  myCmp x y = x >= y\n")
+
+(hk-test
+  "Ord default: myMax 3 5 = 5"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMax 3 5\n")))
+  5)
+
+(hk-test
+  "Ord default: myMax 8 2 = 8"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMax 8 2\n")))
+  8)
+
+(hk-test
+  "Ord default: myMin 3 5 = 3"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMin 3 5\n")))
+  3)
+
+(hk-test
+  "Ord default: myMin 8 2 = 2"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMin 8 2\n")))
+  2)
+
+(hk-test
+  "Ord default: myMax of equals returns first"
+  (hk-deep-force (hk-run (str hk-myord-source "main = myMax 4 4\n")))
+  4)
+
+(define
+  hk-mynum-source
+  "class MyNum a where\n  mySub :: a -> a -> a\n  myLt :: a -> a -> Bool\n  myNegate :: a -> a\n  myAbs :: a -> a\n  myNegate x = mySub (mySub x x) x\n  myAbs x = if myLt x (mySub x x) then myNegate x else x\ninstance MyNum Int where\n  mySub x y = x - y\n  myLt x y = x < y\n")
+
+(hk-test
+  "Num default: myNegate 5 = -5"
+  (hk-deep-force (hk-run (str hk-mynum-source "main = myNegate 5\n")))
+  -5)
+
+(hk-test
+  "Num default: myAbs (myNegate 7) = 7"
+  (hk-deep-force (hk-run (str hk-mynum-source "main = myAbs (myNegate 7)\n")))
+  7)
+
+(hk-test
+  "Num default: myAbs 9 = 9"
+  (hk-deep-force (hk-run (str hk-mynum-source "main = myAbs 9\n")))
+  9)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/deriving.sx

@@ -12,14 +12,14 @@
   "deriving Show: constructor with arg"
   (hk-deep-force
     (hk-run "data Wrapper = Wrap Int deriving (Show)\nmain = show (Wrap 42)"))
-  "(Wrap 42)")
+  "Wrap 42")
 
 (hk-test
   "deriving Show: nested constructors"
   (hk-deep-force
     (hk-run
       "data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf Leaf)"))
-  "(Node 1 Leaf Leaf)")
+  "Node 1 Leaf Leaf")
 
 (hk-test
   "deriving Show: second constructor"
@@ -30,6 +30,31 @@
 
 ;; ─── Eq ──────────────────────────────────────────────────────────────────────
 
+(hk-test
+  "deriving Show: nested ADT wraps inner constructor in parens"
+  (hk-deep-force
+    (hk-run
+      "data Tree = Leaf | Node Int Tree Tree deriving (Show)\nmain = show (Node 1 Leaf (Node 2 Leaf Leaf))"))
+  "Node 1 Leaf (Node 2 Leaf Leaf)")
+
+(hk-test
+  "deriving Show: Maybe Maybe wraps inner Just"
+  (hk-deep-force (hk-run "main = show (Just (Just 3))"))
+  "Just (Just 3)")
+
+(hk-test
+  "deriving Show: negative argument wrapped in parens"
+  (hk-deep-force (hk-run "main = show (Just (negate 3))"))
+  "Just (-3)")
+
+(hk-test
+  "deriving Show: list element does not need parens"
+  (hk-deep-force
+    (hk-run "data Box = Box [Int] deriving (Show)\nmain = show (Box [1,2,3])"))
+  "Box [1,2,3]")
+
+;; ─── combined Eq + Show ───────────────────────────────────────────────────────
+
 (hk-test
   "deriving Eq: same constructor"
   (hk-deep-force
@@ -58,14 +83,12 @@
       "data Color = Red | Green | Blue deriving (Eq)\nmain = show (Red /= Blue)"))
   "True")
 
-;; ─── combined Eq + Show ───────────────────────────────────────────────────────
-
 (hk-test
-  "deriving Eq Show: combined in parens"
+  "deriving Eq Show: combined"
   (hk-deep-force
     (hk-run
       "data Shape = Circle Int | Square Int deriving (Eq, Show)\nmain = show (Circle 5)"))
-  "(Circle 5)")
+  "Circle 5")
 
 (hk-test
   "deriving Eq Show: eq on constructor with arg"

lib/haskell/tests/errors.sx

@@ -0,0 +1,99 @@
+;; errors.sx — Phase 9 error / undefined / partial-fn coverage via hk-test-error.
+
+;; ── error builtin ────────────────────────────────────────────
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(hk-test-error
+  "error: raises with literal message"
+  (fn () (hk-deep-force (hk-run "main = error \"boom\"")))
+  "hk-error: boom")
+
+(hk-test-error
+  "error: raises with computed message"
+  (fn () (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)")))
+  "hk-error: oops: 42")
+
+;; ── undefined ────────────────────────────────────────────────
+(hk-test-error
+  "error: nested in if branch (only fires when forced)"
+  (fn
+    ()
+    (hk-deep-force (hk-run "main = if 1 == 1 then error \"taken\" else 0")))
+  "taken")
+
+(hk-test-error
+  "undefined: raises Prelude.undefined"
+  (fn () (hk-deep-force (hk-run "main = undefined")))
+  "Prelude.undefined")
+
+;; The non-strict path: undefined doesn't fire when not forced.
+(hk-test-error
+  "undefined: forced via arithmetic"
+  (fn () (hk-deep-force (hk-run "main = undefined + 1")))
+  "Prelude.undefined")
+
+;; ── partial functions ───────────────────────────────────────
+(hk-test
+  "undefined: lazy, not forced when discarded"
+  (hk-deep-force (hk-run "main = let _ = undefined in 5"))
+  5)
+
+(hk-test-error
+  "head []: raises Prelude.head: empty list"
+  (fn () (hk-deep-force (hk-run "main = head []")))
+  "Prelude.head: empty list")
+
+(hk-test-error
+  "tail []: raises Prelude.tail: empty list"
+  (fn () (hk-deep-force (hk-run "main = tail []")))
+  "Prelude.tail: empty list")
+
+;; head and tail still work on non-empty lists.
+(hk-test-error
+  "fromJust Nothing: raises Maybe.fromJust: Nothing"
+  (fn () (hk-deep-force (hk-run "main = fromJust Nothing")))
+  "Maybe.fromJust: Nothing")
+
+(hk-test
+  "head [42]: still works"
+  (hk-deep-force (hk-run "main = head [42]"))
+  42)
+
+;; ── error in IO context ─────────────────────────────────────
+(hk-test
+  "tail [1,2,3]: still works"
+  (hk-as-list (hk-deep-force (hk-run "main = tail [1,2,3]")))
+  (list 2 3))
+
+(hk-test
+  "hk-run-io: error in main lands in io-lines"
+  (let
+    ((lines (hk-run-io "main = error \"caught here\"")))
+    (>= (index-of (str lines) "caught here") 0))
+  true)
+
+;; ── hk-test-error helper itself ─────────────────────────────
+(hk-test
+  "hk-run-io: putStrLn before error preserves earlier output"
+  (let
+    ((lines (hk-run-io "main = do { putStrLn \"first\"; error \"died\"; putStrLn \"never\" }")))
+    (and
+      (>= (index-of (str lines) "first") 0)
+      (>= (index-of (str lines) "died") 0)))
+  true)
+
+;; hk-as-list helper for converting a forced Haskell cons into an SX list.
+(hk-test-error
+  "hk-test-error: matches partial substring inside wrapped exception"
+  (fn () (hk-deep-force (hk-run "main = error \"unique-marker-xyz\"")))
+  "unique-marker-xyz")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/eval.sx

@@ -231,16 +231,82 @@
   1)
 
 ;; ── Laziness: app args evaluate only when forced ──
+(hk-test
+  "error builtin: raises with hk-error prefix"
+  (guard
+    (e (true (>= (index-of e "hk-error: boom") 0)))
+    (begin (hk-deep-force (hk-run "main = error \"boom\"")) false))
+  true)
+
+(hk-test
+  "error builtin: raises with computed message"
+  (guard
+    (e (true (>= (index-of e "hk-error: oops: 42") 0)))
+    (begin
+      (hk-deep-force (hk-run "main = error (\"oops: \" ++ show 42)"))
+      false))
+  true)
+
+(hk-test
+  "undefined: raises hk-error with Prelude.undefined message"
+  (guard
+    (e (true (>= (index-of e "hk-error: Prelude.undefined") 0)))
+    (begin (hk-deep-force (hk-run "main = undefined")) false))
+  true)
+
+(hk-test
+  "undefined: lazy — only fires when forced"
+  (hk-deep-force (hk-run "main = if True then 42 else undefined"))
+  42)
+
+(hk-test
+  "head []: raises Prelude.head: empty list"
+  (guard
+    (e (true (>= (index-of e "Prelude.head: empty list") 0)))
+    (begin (hk-deep-force (hk-run "main = head []")) false))
+  true)
+
+(hk-test
+  "tail []: raises Prelude.tail: empty list"
+  (guard
+    (e (true (>= (index-of e "Prelude.tail: empty list") 0)))
+    (begin (hk-deep-force (hk-run "main = tail []")) false))
+  true)
+
+;; ── not / id built-ins ──
+(hk-test
+  "fromJust Nothing: raises Maybe.fromJust: Nothing"
+  (guard
+    (e (true (>= (index-of e "Maybe.fromJust: Nothing") 0)))
+    (begin (hk-deep-force (hk-run "main = fromJust Nothing")) false))
+  true)
+(hk-test
+  "fromJust (Just 5) = 5"
+  (hk-deep-force (hk-run "main = fromJust (Just 5)"))
+  5)
+(hk-test
+  "head [42] = 42 (still works for non-empty)"
+  (hk-deep-force (hk-run "main = head [42]"))
+  42)
+
+(hk-test-error
+  "hk-test-error helper: catches matching error"
+  (fn () (hk-deep-force (hk-run "main = error \"boom\"")))
+  "hk-error: boom")
+
+(hk-test-error
+  "hk-test-error helper: catches head [] error"
+  (fn () (hk-deep-force (hk-run "main = head []")))
+  "Prelude.head: empty list")
+
 (hk-test
   "second arg never forced"
-  (hk-eval-expr-source
-    "(\\x y -> x) 1 (error \"never\")")
+  (hk-eval-expr-source "(\\x y -> x) 1 (error \"never\")")
   1)
 
 (hk-test
   "first arg never forced"
-  (hk-eval-expr-source
-    "(\\x y -> y) (error \"never\") 99")
+  (hk-eval-expr-source "(\\x y -> y) (error \"never\") 99")
   99)
 
 (hk-test
@@ -251,9 +317,7 @@
 
 (hk-test
   "lazy: const drops its second argument"
-  (hk-prog-val
-    "const x y = x\nresult = const 5 (error \"boom\")"
-    "result")
+  (hk-prog-val "const x y = x\nresult = const 5 (error \"boom\")" "result")
   5)
 
 (hk-test
@@ -270,9 +334,10 @@
     "result")
   (list "True"))
 
-;; ── not / id built-ins ──
 (hk-test "not True" (hk-eval-expr-source "not True") (list "False"))
+
 (hk-test "not False" (hk-eval-expr-source "not False") (list "True"))
+
 (hk-test "id" (hk-eval-expr-source "id 42") 42)
 
 {:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/exceptions.sx

@@ -0,0 +1,105 @@
+;; Phase 16 — Exception handling unit tests.
+
+(hk-test
+  "catch — success path returns the action result"
+  (hk-deep-force
+    (hk-run
+      "main = catch (return 42) (\\(SomeException m) -> return 0)"))
+  (list "IO" 42))
+
+(hk-test
+  "catch — error caught, handler receives message"
+  (hk-deep-force
+    (hk-run
+      "main = catch (error \"boom\") (\\(SomeException m) -> return m)"))
+  (list "IO" "boom"))
+
+(hk-test
+  "try — success returns Right v"
+  (hk-deep-force
+    (hk-run "main = try (return 42)"))
+  (list "IO" (list "Right" 42)))
+
+(hk-test
+  "try — error returns Left (SomeException msg)"
+  (hk-deep-force
+    (hk-run "main = try (error \"oops\")"))
+  (list "IO" (list "Left" (list "SomeException" "oops"))))
+
+(hk-test
+  "handle — flip catch — caught error message"
+  (hk-deep-force
+    (hk-run
+      "main = handle (\\(SomeException m) -> return m) (error \"hot\")"))
+  (list "IO" "hot"))
+
+(hk-test
+  "throwIO + catch — handler sees the SomeException"
+  (hk-deep-force
+    (hk-run
+      "main = catch (throwIO (SomeException \"bang\")) (\\(SomeException m) -> return m)"))
+  (list "IO" "bang"))
+
+(hk-test
+  "throwIO + try — Left side"
+  (hk-deep-force
+    (hk-run
+      "main = try (throwIO (SomeException \"x\"))"))
+  (list "IO" (list "Left" (list "SomeException" "x"))))
+
+(hk-test
+  "evaluate — pure value returns IO v"
+  (hk-deep-force
+    (hk-run "main = evaluate (1 + 2 + 3)"))
+  (list "IO" 6))
+
+(hk-test
+  "evaluate — error surfaces as catchable exception"
+  (hk-deep-force
+    (hk-run
+      "main = catch (evaluate (error \"deep\")) (\\(SomeException m) -> return m)"))
+  (list "IO" "deep"))
+
+(hk-test
+  "nested catch — inner handler runs first"
+  (hk-deep-force
+    (hk-run
+      "main = catch (catch (error \"inner\") (\\(SomeException m) -> error (m ++ \"-rethrown\"))) (\\(SomeException m) -> return m)"))
+  (list "IO" "inner-rethrown"))
+
+(hk-test
+  "catch chain — handler can succeed inside IO"
+  (hk-deep-force
+    (hk-run
+      "main = do { x <- catch (error \"e1\") (\\(SomeException m) -> return 100); return (x + 1) }"))
+  (list "IO" 101))
+
+(hk-test
+  "try then bind on Right"
+  (hk-deep-force
+    (hk-run
+      "branch (Right v) = return (v * 2)
+branch (Left _) = return 0
+main = do { r <- try (return 21); branch r }"))
+  (list "IO" 42))
+
+(hk-test
+  "try then bind on Left"
+  (hk-deep-force
+    (hk-run
+      "branch (Right _) = return \"ok\"
+branch (Left (SomeException m)) = return m
+main = do { r <- try (error \"failed\"); branch r }"))
+  (list "IO" "failed"))
+
+(hk-test
+  "catch — handler can use closed-over IORef"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef
+main = do
+  r <- IORef.newIORef 0
+  catch (error \"x\") (\\(SomeException m) -> IORef.writeIORef r 7)
+  v <- IORef.readIORef r
+  return v"))
+  (list "IO" 7))

lib/haskell/tests/instance-where.sx

@@ -0,0 +1,31 @@
+;; instance-where.sx — Phase 13: where-clauses inside instance bodies.
+
+(hk-test
+  "instance method body with where-helper (Bool)"
+  (hk-deep-force
+    (hk-run
+      "class Greet a where\n  greet :: a -> String\ninstance Greet Bool where\n  greet x = mkMsg x\n    where mkMsg True = \"yes\"\n          mkMsg False = \"no\"\nmain = greet True"))
+  "yes")
+
+(hk-test
+  "instance method body with where-helper (False branch)"
+  (hk-deep-force
+    (hk-run
+      "class Greet a where\n  greet :: a -> String\ninstance Greet Bool where\n  greet x = mkMsg x\n    where mkMsg True = \"yes\"\n          mkMsg False = \"no\"\nmain = greet False"))
+  "no")
+
+(hk-test
+  "instance method body with where-binding referenced multiple times"
+  (hk-deep-force
+    (hk-run
+      "class Twice a where\n  twice :: a -> Int\ninstance Twice Int where\n  twice x = h + h\n    where h = x + 1\nmain = twice 5"))
+  12)
+
+(hk-test
+  "instance method body with multi-binding where"
+  (hk-deep-force
+    (hk-run
+      "class Calc a where\n  calc :: a -> Int\ninstance Calc Int where\n  calc x = a + b\n    where a = x * 2\n          b = x + 1\nmain = calc 3"))
+  10)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/io-input.sx

@@ -64,12 +64,11 @@
 
 (hk-test
   "readFile error on missing file"
-  (guard
-    (e (true (>= (index-of e "file not found") 0)))
-    (begin
-      (set! hk-vfs (dict))
-      (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")
-      false))
+  (begin
+    (set! hk-vfs (dict))
+    (let
+      ((lines (hk-run-io "main = readFile \"no.txt\" >>= putStrLn")))
+      (>= (index-of (str lines) "file not found") 0)))
   true)
 
 (hk-test

lib/haskell/tests/ioref.sx

@@ -0,0 +1,94 @@
+;; Phase 15 — IORef unit tests.
+
+(hk-test
+  "newIORef + readIORef returns initial value"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 42; v <- IORef.readIORef r; return v }"))
+  (list "IO" 42))
+
+(hk-test
+  "writeIORef updates the cell"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 99; v <- IORef.readIORef r; return v }"))
+  (list "IO" 99))
+
+(hk-test
+  "writeIORef returns IO ()"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 0; IORef.writeIORef r 1 }"))
+  (list "IO" (list "Tuple")))
+
+(hk-test
+  "modifyIORef applies a function"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 5; IORef.modifyIORef r (\\x -> x * 2); v <- IORef.readIORef r; return v }"))
+  (list "IO" 10))
+
+(hk-test
+  "modifyIORef' (strict) applies a function"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 7; IORef.modifyIORef' r (\\x -> x + 3); v <- IORef.readIORef r; return v }"))
+  (list "IO" 10))
+
+(hk-test
+  "two reads return the same value"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 11; a <- IORef.readIORef r; b <- IORef.readIORef r; return (a + b) }"))
+  (list "IO" 22))
+
+(hk-test
+  "shared ref across do-steps: write then read"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef 1; IORef.writeIORef r 2; IORef.writeIORef r 3; v <- IORef.readIORef r; return v }"))
+  (list "IO" 3))
+
+(hk-test
+  "two refs are independent"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r1 <- IORef.newIORef 1; r2 <- IORef.newIORef 2; IORef.writeIORef r1 10; a <- IORef.readIORef r1; b <- IORef.readIORef r2; return (a + b) }"))
+  (list "IO" 12))
+
+(hk-test
+  "string-valued IORef"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef \"hi\"; IORef.writeIORef r \"bye\"; v <- IORef.readIORef r; return v }"))
+  (list "IO" "bye"))
+
+(hk-test
+  "list-valued IORef + cons"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nmain = do { r <- IORef.newIORef [1,2,3]; IORef.modifyIORef r (\\xs -> 0 : xs); v <- IORef.readIORef r; return v }"))
+  (list
+    "IO"
+    (list ":" 0 (list ":" 1 (list ":" 2 (list ":" 3 (list "[]")))))))
+
+(hk-test
+  "counter loop: increment N times"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nloop r 0 = return ()\nloop r n = do { IORef.modifyIORef r (\\x -> x + 1); loop r (n - 1) }\nmain = do { r <- IORef.newIORef 0; loop r 10; v <- IORef.readIORef r; return v }"))
+  (list "IO" 10))
+
+(hk-test
+  "modifyIORef' inside a loop"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\ngo r 0 = return ()\ngo r n = do { IORef.modifyIORef' r (\\x -> x + n); go r (n - 1) }\nmain = do { r <- IORef.newIORef 0; go r 5; v <- IORef.readIORef r; return v }"))
+  (list "IO" 15))
+
+(hk-test
+  "newIORef inside a function passed via parameter"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.IORef as IORef\nbump r = IORef.modifyIORef r (\\x -> x + 100)\nmain = do { r <- IORef.newIORef 1; bump r; v <- IORef.readIORef r; return v }"))
+  (list "IO" 101))

lib/haskell/tests/map.sx

@@ -0,0 +1,196 @@
+;; map.sx — Phase 11 Data.Map unit tests.
+;;
+;; Tests both the SX-level `hk-map-*` helpers and the Haskell-level
+;; `Map.*` aliases bound by the import handler.
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+;; ── SX-level (direct hk-map-*) ───────────────────────────────
+(hk-test
+  "hk-map-empty: size 0, null true"
+  (list (hk-map-size hk-map-empty) (hk-map-null hk-map-empty))
+  (list 0 true))
+
+(hk-test
+  "hk-map-singleton: lookup hit"
+  (let
+    ((m (hk-map-singleton 5 "five")))
+    (list (hk-map-size m) (hk-map-lookup 5 m)))
+  (list 1 (list "Just" "five")))
+
+(hk-test
+  "hk-map-insert: lookup hit on inserted"
+  (let ((m (hk-map-insert 1 "a" hk-map-empty))) (hk-map-lookup 1 m))
+  (list "Just" "a"))
+
+(hk-test
+  "hk-map-lookup: miss returns Nothing"
+  (hk-map-lookup 99 (hk-map-singleton 1 "a"))
+  (list "Nothing"))
+
+(hk-test
+  "hk-map-insert: overwrites existing key"
+  (let
+    ((m (hk-map-insert 1 "second" (hk-map-insert 1 "first" hk-map-empty))))
+    (hk-map-lookup 1 m))
+  (list "Just" "second"))
+
+(hk-test
+  "hk-map-delete: removes key"
+  (let
+    ((m (hk-map-insert 2 "b" (hk-map-insert 1 "a" hk-map-empty))))
+    (let
+      ((m2 (hk-map-delete 1 m)))
+      (list (hk-map-size m2) (hk-map-lookup 1 m2) (hk-map-lookup 2 m2))))
+  (list 1 (list "Nothing") (list "Just" "b")))
+
+(hk-test
+  "hk-map-delete: missing key is no-op"
+  (let ((m (hk-map-singleton 1 "a"))) (hk-map-size (hk-map-delete 99 m)))
+  1)
+
+(hk-test
+  "hk-map-member: true on existing"
+  (hk-map-member 1 (hk-map-singleton 1 "a"))
+  true)
+
+(hk-test
+  "hk-map-member: false on missing"
+  (hk-map-member 99 (hk-map-singleton 1 "a"))
+  false)
+
+(hk-test
+  "hk-map-from-list: builds map; keys sorted"
+  (hk-map-keys
+    (hk-map-from-list
+      (list (list 3 "c") (list 1 "a") (list 5 "e") (list 2 "b"))))
+  (list 1 2 3 5))
+
+(hk-test
+  "hk-map-from-list: duplicates — last wins"
+  (hk-map-lookup
+    1
+    (hk-map-from-list (list (list 1 "first") (list 1 "second"))))
+  (list "Just" "second"))
+
+(hk-test
+  "hk-map-to-asc-list: ordered traversal"
+  (hk-map-to-asc-list
+    (hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
+  (list (list 1 "a") (list 2 "b") (list 3 "c")))
+
+(hk-test
+  "hk-map-elems: in key order"
+  (hk-map-elems
+    (hk-map-from-list (list (list 3 30) (list 1 10) (list 2 20))))
+  (list 10 20 30))
+
+(hk-test
+  "hk-map-union-with: combines duplicates"
+  (hk-map-to-asc-list
+    (hk-map-union-with
+      (fn (a b) (str a "+" b))
+      (hk-map-from-list (list (list 1 "a") (list 2 "b")))
+      (hk-map-from-list (list (list 2 "B") (list 3 "c")))))
+  (list (list 1 "a") (list 2 "b+B") (list 3 "c")))
+
+(hk-test
+  "hk-map-intersection-with: keeps shared keys"
+  (hk-map-to-asc-list
+    (hk-map-intersection-with
+      +
+      (hk-map-from-list (list (list 1 10) (list 2 20)))
+      (hk-map-from-list (list (list 2 200) (list 3 30)))))
+  (list (list 2 220)))
+
+(hk-test
+  "hk-map-difference: drops m2 keys"
+  (hk-map-keys
+    (hk-map-difference
+      (hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))
+      (hk-map-from-list (list (list 2 "x")))))
+  (list 1 3))
+
+(hk-test
+  "hk-map-foldl-with-key: in-order accumulate"
+  (hk-map-foldl-with-key
+    (fn (acc k v) (str acc k v))
+    ""
+    (hk-map-from-list (list (list 3 "c") (list 1 "a") (list 2 "b"))))
+  "1a2b3c")
+
+(hk-test
+  "hk-map-map-with-key: transforms values"
+  (hk-map-to-asc-list
+    (hk-map-map-with-key
+      (fn (k v) (* k v))
+      (hk-map-from-list (list (list 2 10) (list 3 100)))))
+  (list (list 2 20) (list 3 300)))
+
+(hk-test
+  "hk-map-filter-with-key: keeps matches"
+  (hk-map-keys
+    (hk-map-filter-with-key
+      (fn (k v) (> k 1))
+      (hk-map-from-list (list (list 1 "a") (list 2 "b") (list 3 "c")))))
+  (list 2 3))
+
+(hk-test
+  "hk-map-adjust: applies f to existing"
+  (hk-map-lookup
+    1
+    (hk-map-adjust (fn (v) (* v 10)) 1 (hk-map-singleton 1 5)))
+  (list "Just" 50))
+
+(hk-test
+  "hk-map-insert-with: combines on existing"
+  (hk-map-lookup 1 (hk-map-insert-with + 1 5 (hk-map-singleton 1 10)))
+  (list "Just" 15))
+
+(hk-test
+  "hk-map-alter: Nothing → delete"
+  (hk-map-size
+    (hk-map-alter
+      (fn (mv) (list "Nothing"))
+      1
+      (hk-map-from-list (list (list 1 "a") (list 2 "b")))))
+  1)
+
+;; ── Haskell-level (Map.*) via import wiring ─────────────────
+(hk-test
+  "Map.size after Map.insert chain"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.size (Map.insert 2 \"b\" (Map.insert 1 \"a\" Map.empty))"))
+  2)
+
+(hk-test
+  "Map.lookup hit"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.lookup 1 (Map.insert 1 \"a\" Map.empty)"))
+  (list "Just" "a"))
+
+(hk-test
+  "Map.lookup miss"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.lookup 99 (Map.insert 1 \"a\" Map.empty)"))
+  (list "Nothing"))
+
+(hk-test
+  "Map.member true"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Map as Map\nmain = Map.member 5 (Map.insert 5 \"x\" Map.empty)"))
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/numerics.sx

@@ -0,0 +1,180 @@
+;; numerics.sx — Phase 10 numeric tower verification.
+;;
+;; Practical integer-precision limit in Haskell-on-SX:
+;;   • Raw SX `(* a b)` stays exact up to ±2^62 (≈ 4.6e18, OCaml int63).
+;;   • BUT the Haskell tokenizer/parser parses an integer literal as a float
+;;     once it exceeds 2^53 (≈ 9.007e15). Once any operand is a float, the
+;;     binop result is a float (and decimal-precision is lost past 2^53).
+;;   • Therefore: programs that stay below ~9e15 are exact; larger literals
+;;     or accumulated products silently become floats. `factorial 18` is the
+;;     last factorial that stays exact (6.4e15); `factorial 19` already floats.
+;;
+;; In Haskell terms, `Int` and `Integer` both currently map to SX number, so
+;; we don't yet support arbitrary-precision Integer. Documented; unbounded
+;; Integer is out of scope for Phase 10 — see Phase 11+ if it becomes needed.
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(hk-test
+  "factorial 10 = 3628800 (small, exact)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 10"))
+  3628800)
+
+(hk-test
+  "factorial 15 = 1307674368000 (mid-range, exact)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 15"))
+  1307674368000)
+
+(hk-test
+  "factorial 18 = 6402373705728000 (last exact factorial)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = fact 18"))
+  6402373705728000)
+
+(hk-test
+  "1000000 * 1000000 = 10^12 (exact)"
+  (hk-deep-force (hk-run "main = 1000000 * 1000000"))
+  1000000000000)
+
+(hk-test
+  "1000000000 * 1000000000 = 10^18 (exact, at boundary)"
+  (hk-deep-force (hk-run "main = 1000000000 * 1000000000"))
+  1e+18)
+
+(hk-test
+  "2^62 boundary: pow accumulates exactly"
+  (hk-deep-force
+    (hk-run "pow b 0 = 1\npow b n = b * pow b (n - 1)\nmain = pow 2 62"))
+  4.6116860184273879e+18)
+
+(hk-test
+  "show factorial 12 = 479001600 (whole, fits in 32-bit)"
+  (hk-deep-force
+    (hk-run "fact 0 = 1\nfact n = n * fact (n - 1)\nmain = show (fact 12)"))
+  "479001600")
+
+(hk-test
+  "negate large positive — preserves magnitude"
+  (hk-deep-force (hk-run "main = negate 1000000000000000000"))
+  -1e+18)
+
+(hk-test
+  "abs negative large — preserves magnitude"
+  (hk-deep-force (hk-run "main = abs (negate 1000000000000000000)"))
+  1e+18)
+
+(hk-test
+  "div on large ints"
+  (hk-deep-force (hk-run "main = div 1000000000000000000 1000000000"))
+  1000000000)
+
+(hk-test
+  "fromIntegral 42 = 42 (identity in our runtime)"
+  (hk-deep-force (hk-run "main = fromIntegral 42"))
+  42)
+
+(hk-test
+  "fromIntegral preserves negative"
+  (hk-deep-force (hk-run "main = fromIntegral (negate 7)"))
+  -7)
+
+(hk-test
+  "fromIntegral round-trips through arithmetic"
+  (hk-deep-force (hk-run "main = fromIntegral 5 + fromIntegral 3"))
+  8)
+
+(hk-test
+  "fromIntegral in a program (mixing with map)"
+  (hk-as-list (hk-deep-force (hk-run "main = map fromIntegral [1,2,3]")))
+  (list 1 2 3))
+
+(hk-test
+  "toInteger 100 = 100 (identity)"
+  (hk-deep-force (hk-run "main = toInteger 100"))
+  100)
+
+(hk-test
+  "fromInteger 7 = 7 (identity)"
+  (hk-deep-force (hk-run "main = fromInteger 7"))
+  7)
+
+(hk-test
+  "toInteger / fromInteger round-trip"
+  (hk-deep-force (hk-run "main = fromInteger (toInteger 42)"))
+  42)
+
+(hk-test
+  "toInteger preserves negative"
+  (hk-deep-force (hk-run "main = toInteger (negate 13)"))
+  -13)
+
+(hk-test
+  "show 3.14 = 3.14"
+  (hk-deep-force (hk-run "main = show 3.14"))
+  "3.14")
+
+(hk-test
+  "show 1.0e10 — whole-valued float renders as decimal (int/float ambiguity)"
+  (hk-deep-force (hk-run "main = show 1.0e10"))
+  "10000000000")
+
+(hk-test
+  "show 0.001 uses scientific form (sub-0.1)"
+  (hk-deep-force (hk-run "main = show 0.001"))
+  "1.0e-3")
+
+(hk-test
+  "show negative float"
+  (hk-deep-force (hk-run "main = show (negate 3.14)"))
+  "-3.14")
+
+(hk-test "sqrt 16 = 4" (hk-deep-force (hk-run "main = sqrt 16")) 4)
+
+(hk-test "floor 3.7 = 3" (hk-deep-force (hk-run "main = floor 3.7")) 3)
+
+(hk-test "ceiling 3.2 = 4" (hk-deep-force (hk-run "main = ceiling 3.2")) 4)
+
+(hk-test
+  "ceiling on whole = self"
+  (hk-deep-force (hk-run "main = ceiling 4"))
+  4)
+
+(hk-test "round 2.6 = 3" (hk-deep-force (hk-run "main = round 2.6")) 3)
+
+(hk-test
+  "truncate -3.7 = -3"
+  (hk-deep-force (hk-run "main = truncate (negate 3.7)"))
+  -3)
+
+(hk-test "recip 4.0 = 0.25" (hk-deep-force (hk-run "main = recip 4.0")) 0.25)
+
+(hk-test "1.0 / 4.0 = 0.25" (hk-deep-force (hk-run "main = 1.0 / 4.0")) 0.25)
+
+(hk-test
+  "fromRational 0.5 = 0.5 (identity)"
+  (hk-deep-force (hk-run "main = fromRational 0.5"))
+  0.5)
+
+(hk-test "pi ≈ 3.14159" (hk-deep-force (hk-run "main = pi")) 3.14159)
+
+(hk-test "exp 0 = 1" (hk-deep-force (hk-run "main = exp 0")) 1)
+
+(hk-test "sin 0 = 0" (hk-deep-force (hk-run "main = sin 0")) 0)
+
+(hk-test "cos 0 = 1" (hk-deep-force (hk-run "main = cos 0")) 1)
+
+(hk-test "2 ** 10 = 1024" (hk-deep-force (hk-run "main = 2 ** 10")) 1024)
+
+(hk-test "log (exp 5) ≈ 5" (hk-deep-force (hk-run "main = log (exp 5)")) 5)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-accumulate.sx

@@ -0,0 +1,81 @@
+;; accumulate.hs — accumulate results into an IORef [Int] (Phase 15 conformance).
+
+(define
+  hk-accumulate-source
+  "import qualified Data.IORef as IORef\n\npush :: IORef [Int] -> Int -> IO ()\npush r x = IORef.modifyIORef r (\\xs -> x : xs)\n\npushAll :: IORef [Int] -> [Int] -> IO ()\npushAll r [] = return ()\npushAll r (x:xs) = do\n  push r x\n  pushAll r xs\n\nreadReversed :: IORef [Int] -> IO [Int]\nreadReversed r = do\n  xs <- IORef.readIORef r\n  return (reverse xs)\n\ndoubleEach :: IORef [Int] -> [Int] -> IO ()\ndoubleEach r [] = return ()\ndoubleEach r (x:xs) = do\n  push r (x * 2)\n  doubleEach r xs\n\nsumIntoRef :: IORef Int -> [Int] -> IO ()\nsumIntoRef r [] = return ()\nsumIntoRef r (x:xs) = do\n  IORef.modifyIORef r (\\acc -> acc + x)\n  sumIntoRef r xs\n\n")
+
+(hk-test
+  "accumulate.hs — push three then read length"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; push r 1; push r 2; push r 3; xs <- IORef.readIORef r; return (length xs) }")))
+  (list "IO" 3))
+
+(hk-test
+  "accumulate.hs — pushAll preserves reverse order"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; pushAll r [1,2,3,4]; xs <- IORef.readIORef r; return xs }")))
+  (list
+    "IO"
+    (list ":" 4 (list ":" 3 (list ":" 2 (list ":" 1 (list "[]")))))))
+
+(hk-test
+  "accumulate.hs — readReversed gives original order"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; pushAll r [10,20,30]; readReversed r }")))
+  (list "IO" (list ":" 10 (list ":" 20 (list ":" 30 (list "[]"))))))
+
+(hk-test
+  "accumulate.hs — doubleEach maps then accumulates"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef []; doubleEach r [1,2,3]; readReversed r }")))
+  (list "IO" (list ":" 2 (list ":" 4 (list ":" 6 (list "[]"))))))
+
+(hk-test
+  "accumulate.hs — sum into Int IORef"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef 0; sumIntoRef r [1,2,3,4,5]; v <- IORef.readIORef r; return v }")))
+  (list "IO" 15))
+
+(hk-test
+  "accumulate.hs — empty list leaves ref untouched"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef [99]; pushAll r []; xs <- IORef.readIORef r; return xs }")))
+  (list "IO" (list ":" 99 (list "[]"))))
+
+(hk-test
+  "accumulate.hs — pushAll then sumIntoRef on the same input"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "main = do { r <- IORef.newIORef 0; sumIntoRef r [10,20,30,40]; v <- IORef.readIORef r; return v }")))
+  (list "IO" 100))
+
+(hk-test
+  "accumulate.hs — accumulate results from a recursive helper"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-accumulate-source
+        "squaresUpTo r 0 = return ()\nsquaresUpTo r n = do { push r (n * n); squaresUpTo r (n - 1) }\nmain = do { r <- IORef.newIORef []; squaresUpTo r 4; readReversed r }")))
+  (list
+    "IO"
+    (list ":" 16 (list ":" 9 (list ":" 4 (list ":" 1 (list "[]")))))))

lib/haskell/tests/program-caesar.sx

@@ -0,0 +1,80 @@
+;; caesar.hs — Caesar cipher.
+;; Source: https://rosettacode.org/wiki/Caesar_cipher#Haskell (adapted).
+;;
+;; Exercises chr, ord, isUpper, isLower, mod, string pattern matching
+;; (x:xs) over a String (which is now a [Char] string view), and map
+;; from the Phase 7 string=[Char] foundation.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(define
+  hk-caesar-source
+  "shift n c = if isUpper c\n              then chr (mod ((ord c) - 65 + n) 26 + 65)\n              else if isLower c\n                     then chr (mod ((ord c) - 97 + n) 26 + 97)\n                     else chr c\n\ncaesarRec n []     = []\ncaesarRec n (x:xs) = shift n x : caesarRec n xs\n\ncaesarMap n s = map (shift n) s\n")
+
+(hk-test
+  "caesar.hs — caesarRec 3 \"ABC\" = DEF"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"ABC\"\n") "r"))
+  (list "D" "E" "F"))
+
+(hk-test
+  "caesar.hs — caesarRec 13 \"Hello\" = Uryyb"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 13 \"Hello\"\n") "r"))
+  (list "U" "r" "y" "y" "b"))
+
+(hk-test
+  "caesar.hs — caesarRec 1 \"AZ\" wraps to BA"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 1 \"AZ\"\n") "r"))
+  (list "B" "A"))
+
+(hk-test
+  "caesar.hs — caesarRec 0 \"World\" identity"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 0 \"World\"\n") "r"))
+  (list "W" "o" "r" "l" "d"))
+
+(hk-test
+  "caesar.hs — caesarRec preserves punctuation"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 3 \"Hi!\"\n") "r"))
+  (list "K" "l" "!"))
+
+(hk-test
+  "caesar.hs — caesarMap 3 \"abc\" via map"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarMap 3 \"abc\"\n") "r"))
+  (list "d" "e" "f"))
+
+(hk-test
+  "caesar.hs — caesarMap 13 round-trips with caesarMap 13"
+  (hk-as-list
+    (hk-prog-val
+      (str
+        hk-caesar-source
+        "r = caesarMap 13 (foldr (\\c acc -> c : acc) [] (caesarMap 13 \"Hello\"))\n")
+      "r"))
+  (list "H" "e" "l" "l" "o"))
+
+(hk-test
+  "caesar.hs — caesarRec 25 \"AB\" = ZA"
+  (hk-as-list
+    (hk-prog-val (str hk-caesar-source "r = caesarRec 25 \"AB\"\n") "r"))
+  (list "Z" "A"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-config.sx

@@ -0,0 +1,63 @@
+;; config.hs — multi-field config record; partial update; defaultConfig
+;;            constant.
+;;
+;; Exercises Phase 14: 4-field record, defaultConfig as a CAF, partial
+;; updates that change one or two fields, accessors over derived configs.
+
+(define
+  hk-config-source
+  "data Config = Config { host :: String, port :: Int, retries :: Int, debug :: Bool } deriving (Show)\n\ndefaultConfig = Config { host = \"localhost\", port = 8080, retries = 3, debug = False }\n\ndevConfig = defaultConfig { debug = True }\nremoteConfig = defaultConfig { host = \"api.example.com\", port = 443 }\n")
+
+(hk-test
+  "config.hs — defaultConfig host"
+  (hk-deep-force (hk-run (str hk-config-source "main = host defaultConfig")))
+  "localhost")
+
+(hk-test
+  "config.hs — defaultConfig port"
+  (hk-deep-force (hk-run (str hk-config-source "main = port defaultConfig")))
+  8080)
+
+(hk-test
+  "config.hs — defaultConfig retries"
+  (hk-deep-force
+    (hk-run (str hk-config-source "main = retries defaultConfig")))
+  3)
+
+(hk-test
+  "config.hs — devConfig flips debug"
+  (hk-deep-force (hk-run (str hk-config-source "main = debug devConfig")))
+  (list "True"))
+
+(hk-test
+  "config.hs — devConfig preserves host"
+  (hk-deep-force (hk-run (str hk-config-source "main = host devConfig")))
+  "localhost")
+
+(hk-test
+  "config.hs — devConfig preserves port"
+  (hk-deep-force (hk-run (str hk-config-source "main = port devConfig")))
+  8080)
+
+(hk-test
+  "config.hs — remoteConfig new host"
+  (hk-deep-force (hk-run (str hk-config-source "main = host remoteConfig")))
+  "api.example.com")
+
+(hk-test
+  "config.hs — remoteConfig new port"
+  (hk-deep-force (hk-run (str hk-config-source "main = port remoteConfig")))
+  443)
+
+(hk-test
+  "config.hs — remoteConfig preserves retries"
+  (hk-deep-force
+    (hk-run (str hk-config-source "main = retries remoteConfig")))
+  3)
+
+(hk-test
+  "config.hs — remoteConfig preserves debug"
+  (hk-deep-force (hk-run (str hk-config-source "main = debug remoteConfig")))
+  (list "False"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-counter.sx

@@ -0,0 +1,66 @@
+;; counter.hs — IORef-backed mutable counter (Phase 15 conformance).
+
+(define
+  hk-counter-source
+  "import qualified Data.IORef as IORef\n\ncount :: IORef Int -> Int -> IO ()\ncount r 0 = return ()\ncount r n = do\n  IORef.modifyIORef r (\\x -> x + 1)\n  count r (n - 1)\n\ncountBy :: IORef Int -> Int -> Int -> IO ()\ncountBy r step 0 = return ()\ncountBy r step n = do\n  IORef.modifyIORef r (\\x -> x + step)\n  countBy r step (n - 1)\n\nnewCounter :: Int -> IO (IORef Int)\nnewCounter v = IORef.newIORef v\n\nbumpAndRead :: IORef Int -> IO Int\nbumpAndRead r = do\n  IORef.modifyIORef r (\\x -> x + 1)\n  IORef.readIORef r\n\n")
+
+(hk-test
+  "counter.hs — start at 0, count 5 ⇒ 5"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 0; count r 5; v <- IORef.readIORef r; return v }")))
+  (list "IO" 5))
+
+(hk-test
+  "counter.hs — start at 100, count 10 ⇒ 110"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 100; count r 10; v <- IORef.readIORef r; return v }")))
+  (list "IO" 110))
+
+(hk-test
+  "counter.hs — countBy step 5, n 4 ⇒ 20"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 0; countBy r 5 4; v <- IORef.readIORef r; return v }")))
+  (list "IO" 20))
+
+(hk-test
+  "counter.hs — bumpAndRead returns updated value"
+  (hk-deep-force
+    (hk-run
+      (str hk-counter-source "main = do { r <- newCounter 41; bumpAndRead r }")))
+  (list "IO" 42))
+
+(hk-test
+  "counter.hs — count then countBy compose"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { r <- newCounter 0; count r 3; countBy r 10 2; v <- IORef.readIORef r; return v }")))
+  (list "IO" 23))
+
+(hk-test
+  "counter.hs — two independent counters"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "main = do { a <- newCounter 0; b <- newCounter 0; count a 7; countBy b 100 2; va <- IORef.readIORef a; vb <- IORef.readIORef b; return (va + vb) }")))
+  (list "IO" 207))
+
+(hk-test
+  "counter.hs — modifyIORef' (strict) variant"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-counter-source
+        "tick r 0 = return ()\ntick r n = do { IORef.modifyIORef' r (\\x -> x + 1); tick r (n - 1) }\nmain = do { r <- newCounter 0; tick r 50; v <- IORef.readIORef r; return v }")))
+  (list "IO" 50))

lib/haskell/tests/program-mapgraph.sx

@@ -0,0 +1,46 @@
+;; mapgraph.hs — adjacency-list using Data.Map (BFS-style traversal).
+;;
+;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
+;; `Map.insert`, `Map.lookup`, `Map.findWithDefault`. Adjacency lists are
+;; stored as `Map Int [Int]`; `neighbors` does a default-empty lookup.
+
+(define
+  hk-mapgraph-source
+  "import qualified Data.Map as Map\n\nemptyG = Map.empty\n\naddEdge u v g = Map.insertWith add u [v] g\n  where add new old = new ++ old\n\nbuild = addEdge 1 2 (addEdge 1 3 (addEdge 2 4 (addEdge 3 4 (addEdge 4 5 emptyG))))\n\nneighbors n g = Map.findWithDefault [] n g\n")
+
+(hk-test
+  "mapgraph.hs — neighbors of 1"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 1 build\n")))
+  (list ":" 2 (list ":" 3 (list "[]"))))
+
+(hk-test
+  "mapgraph.hs — neighbors of 4"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 4 build\n")))
+  (list ":" 5 (list "[]")))
+
+(hk-test
+  "mapgraph.hs — neighbors of 5 (leaf, no entry) defaults to []"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 5 build\n")))
+  (list "[]"))
+
+(hk-test
+  "mapgraph.hs — neighbors of 99 (absent) defaults to []"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = neighbors 99 build\n")))
+  (list "[]"))
+
+(hk-test
+  "mapgraph.hs — Map.member 1"
+  (hk-deep-force
+    (hk-run (str hk-mapgraph-source "main = Map.member 1 build\n")))
+  (list "True"))
+
+(hk-test
+  "mapgraph.hs — Map.size = 4 source nodes"
+  (hk-deep-force (hk-run (str hk-mapgraph-source "main = Map.size build\n")))
+  4)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-newton.sx

@@ -0,0 +1,49 @@
+;; newton.hs — Newton's method for square root.
+;; Source: classic numerical analysis exercise.
+;;
+;; Exercises Phase 10: `Float`, `abs`, `/`, iteration via `until`.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-newton-source
+  "improve x guess = (guess + x / guess) / 2\n\ngoodEnough x guess = abs (guess * guess - x) < 0.0001\n\nnewtonSqrt x = newtonHelp x 1.0\n\nnewtonHelp x guess = if goodEnough x guess\n                       then guess\n                       else newtonHelp x (improve x guess)\n")
+
+(hk-test
+  "newton.hs — newtonSqrt 4 ≈ 2"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 4.0 - 2.0) < 0.001\n")
+    "r")
+  (list "True"))
+
+(hk-test
+  "newton.hs — newtonSqrt 9 ≈ 3"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 9.0 - 3.0) < 0.001\n")
+    "r")
+  (list "True"))
+
+(hk-test
+  "newton.hs — newtonSqrt 2 ≈ 1.41421"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 2.0 - 1.41421) < 0.001\n")
+    "r")
+  (list "True"))
+
+(hk-test
+  "newton.hs — improve converges (one step)"
+  (hk-prog-val (str hk-newton-source "r = improve 4.0 1.0\n") "r")
+  2.5)
+
+(hk-test
+  "newton.hs — newtonSqrt 100 ≈ 10"
+  (hk-prog-val
+    (str hk-newton-source "r = abs (newtonSqrt 100.0 - 10.0) < 0.001\n")
+    "r")
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-partial.sx

@@ -0,0 +1,58 @@
+;; partial.hs — exercises Phase 9 partial functions caught at the top level.
+;;
+;; Each program calls a partial function on bad input; hk-run-io catches the
+;; raise and appends the error message to io-lines so tests can inspect.
+
+(hk-test
+  "partial.hs — main = print (head [])"
+  (let
+    ((lines (hk-run-io "main = print (head [])")))
+    (>= (index-of (str lines) "Prelude.head: empty list") 0))
+  true)
+
+(hk-test
+  "partial.hs — main = print (tail [])"
+  (let
+    ((lines (hk-run-io "main = print (tail [])")))
+    (>= (index-of (str lines) "Prelude.tail: empty list") 0))
+  true)
+
+(hk-test
+  "partial.hs — main = print (fromJust Nothing)"
+  (let
+    ((lines (hk-run-io "main = print (fromJust Nothing)")))
+    (>= (index-of (str lines) "Maybe.fromJust: Nothing") 0))
+  true)
+
+(hk-test
+  "partial.hs — putStrLn before error preserves prior output"
+  (let
+    ((lines (hk-run-io "main = do { putStrLn \"step 1\"; putStrLn (show (head [])); putStrLn \"never\" }")))
+    (and
+      (>= (index-of (str lines) "step 1") 0)
+      (>= (index-of (str lines) "Prelude.head: empty list") 0)
+      (= (index-of (str lines) "never") -1)))
+  true)
+
+(hk-test
+  "partial.hs — undefined as IO action"
+  (let
+    ((lines (hk-run-io "main = print undefined")))
+    (>= (index-of (str lines) "Prelude.undefined") 0))
+  true)
+
+(hk-test
+  "partial.hs — catches error from a user-thrown error"
+  (let
+    ((lines (hk-run-io "main = error \"boom from main\"")))
+    (>= (index-of (str lines) "boom from main") 0))
+  true)
+
+;; Negative case: when no error is raised, io-lines doesn't contain
+;; "Prelude" prefixes from our error path.
+(hk-test
+  "partial.hs — happy path: head [42] succeeds, no error in output"
+  (hk-run-io "main = print (head [42])")
+  (list "42"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-person.sx

@@ -0,0 +1,51 @@
+;; person.hs — record type with accessors, update, deriving Show.
+;;
+;; Exercises Phase 14: data with record syntax, accessor functions,
+;; record creation, record update, deriving Show on a record.
+
+(define
+  hk-person-source
+  "data Person = Person { name :: String, age :: Int } deriving (Show)\n\nalice = Person { name = \"alice\", age = 30 }\nbob = Person { name = \"bob\", age = 25 }\n\nbirthday p = p { age = age p + 1 }\n")
+
+(hk-test
+  "person.hs — alice's name"
+  (hk-deep-force (hk-run (str hk-person-source "main = name alice")))
+  "alice")
+
+(hk-test
+  "person.hs — alice's age"
+  (hk-deep-force (hk-run (str hk-person-source "main = age alice")))
+  30)
+
+(hk-test
+  "person.hs — birthday adds one year"
+  (hk-deep-force
+    (hk-run (str hk-person-source "main = age (birthday alice)")))
+  31)
+
+(hk-test
+  "person.hs — birthday preserves name"
+  (hk-deep-force
+    (hk-run (str hk-person-source "main = name (birthday alice)")))
+  "alice")
+
+(hk-test
+  "person.hs — show alice"
+  (hk-deep-force (hk-run (str hk-person-source "main = show alice")))
+  "Person \"alice\" 30")
+
+(hk-test
+  "person.hs — bob has different name"
+  (hk-deep-force (hk-run (str hk-person-source "main = name bob")))
+  "bob")
+
+(hk-test
+  "person.hs — pattern match in function"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "greet (Person { name = n }) = \"Hi, \" ++ n\nmain = greet alice")))
+  "Hi, alice")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-runlength-str.sx

@@ -0,0 +1,83 @@
+;; runlength-str.hs — run-length encoding on a String.
+;; Source: https://rosettacode.org/wiki/Run-length_encoding#Haskell (adapted).
+;;
+;; Exercises String pattern matching `(x:xs)`, `span` over a string view,
+;; tuple construction `(Int, Char)`, character equality, and tuple-in-cons
+;; patterns `((n, c) : rest)` — all enabled by Phase 7 string=[Char].
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-as-list
+  (fn
+    (xs)
+    (cond
+      ((and (list? xs) (= (first xs) "[]")) (list))
+      ((and (list? xs) (= (first xs) ":"))
+        (cons (nth xs 1) (hk-as-list (nth xs 2))))
+      (:else xs))))
+
+(define
+  hk-rle-source
+  "encodeRL []     = []\nencodeRL (x:xs) = let (same, rest) = span eqX xs\n                      eqX y         = y == x\n                  in (1 + length same, x) : encodeRL rest\n\nreplicateRL 0 _ = []\nreplicateRL n c = c : replicateRL (n - 1) c\n\ndecodeRL []                = []\ndecodeRL ((n, c) : rest)   = replicateRL n c ++ decodeRL rest\n")
+
+(hk-test
+  "rle.hs — encodeRL [] = []"
+  (hk-as-list (hk-prog-val (str hk-rle-source "r = encodeRL \"\"\n") "r"))
+  (list))
+
+(hk-test
+  "rle.hs — length (encodeRL \"aabbbcc\") = 3"
+  (hk-prog-val (str hk-rle-source "r = length (encodeRL \"aabbbcc\")\n") "r")
+  3)
+
+(hk-test
+  "rle.hs — map fst (encodeRL \"aabbbcc\") = [2,3,2]"
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"aabbbcc\")\n") "r"))
+  (list 2 3 2))
+
+(hk-test
+  "rle.hs — map snd (encodeRL \"aabbbcc\") = [97,98,99]"
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = map snd (encodeRL \"aabbbcc\")\n") "r"))
+  (list 97 98 99))
+
+(hk-test
+  "rle.hs — counts of encodeRL \"aabbbccddddee\" = [2,3,2,4,2]"
+  (hk-as-list
+    (hk-prog-val
+      (str hk-rle-source "r = map fst (encodeRL \"aabbbccddddee\")\n")
+      "r"))
+  (list 2 3 2 4 2))
+
+(hk-test
+  "rle.hs — chars of encodeRL \"aabbbccddddee\" = [97,98,99,100,101]"
+  (hk-as-list
+    (hk-prog-val
+      (str hk-rle-source "r = map snd (encodeRL \"aabbbccddddee\")\n")
+      "r"))
+  (list 97 98 99 100 101))
+
+(hk-test
+  "rle.hs — singleton encodeRL \"x\""
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = map fst (encodeRL \"x\")\n") "r"))
+  (list 1))
+
+(hk-test
+  "rle.hs — decodeRL round-trip preserves \"aabbbcc\""
+  (hk-as-list
+    (hk-prog-val (str hk-rle-source "r = decodeRL (encodeRL \"aabbbcc\")\n") "r"))
+  (list 97 97 98 98 98 99 99))
+
+(hk-test
+  "rle.hs — replicateRL 4 65 = [65,65,65,65]"
+  (hk-as-list (hk-prog-val (str hk-rle-source "r = replicateRL 4 65\n") "r"))
+  (list 65 65 65 65))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-safediv.sx

@@ -0,0 +1,80 @@
+;; safediv.hs — safe division using catch (Phase 16 conformance).
+
+(define
+  hk-safediv-source
+  "safeDiv :: Int -> Int -> IO Int
+safeDiv _ 0 = throwIO (SomeException \"division by zero\")
+safeDiv x y = return (x `div` y)
+
+guarded :: Int -> Int -> IO Int
+guarded x y = catch (safeDiv x y) (\\(SomeException _) -> return 0)
+
+reason :: Int -> Int -> IO String
+reason x y = catch (safeDiv x y `seq` return \"ok\")
+  (\\(SomeException m) -> return m)
+
+bothBranches :: Int -> Int -> IO Int
+bothBranches x y = do
+  v <- catch (safeDiv x y) (\\(SomeException _) -> return (-1))
+  return (v + 100)
+
+")
+
+(hk-test
+  "safediv.hs — divide by non-zero"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = guarded 10 2")))
+  (list "IO" 5))
+
+(hk-test
+  "safediv.hs — divide by zero returns 0"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = guarded 10 0")))
+  (list "IO" 0))
+
+(hk-test
+  "safediv.hs — divide by zero — reason captured"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = catch (safeDiv 1 0) (\\(SomeException m) -> return 0) >> reason 1 0")))
+  (list "IO" "division by zero"))
+
+(hk-test
+  "safediv.hs — bothBranches success path"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = bothBranches 8 2")))
+  (list "IO" 104))
+
+(hk-test
+  "safediv.hs — bothBranches failure path"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source "main = bothBranches 8 0")))
+  (list "IO" 99))
+
+(hk-test
+  "safediv.hs — chained safeDiv with catch"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source
+        "main = do { a <- guarded 20 4; b <- guarded 7 0; return (a + b) }")))
+  (list "IO" 5))
+
+(hk-test
+  "safediv.hs — try then bind through Either"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source
+        "main = do { r <- try (safeDiv 1 0); case r of { Right v -> return v; Left (SomeException m) -> return 999 } }")))
+  (list "IO" 999))
+
+(hk-test
+  "safediv.hs — handle (flip catch)"
+  (hk-deep-force
+    (hk-run
+      (str hk-safediv-source
+        "main = handle (\\(SomeException _) -> return 0) (safeDiv 5 0)")))
+  (list "IO" 0))

lib/haskell/tests/program-setops.sx

@@ -0,0 +1,61 @@
+;; setops.hs — set union/intersection/difference on integer sets.
+;;
+;; Exercises Phase 12: `import qualified Data.Set as Set`, all three
+;; combining operations + isSubsetOf.
+
+(define
+  hk-setops-source
+  "import qualified Data.Set as Set\n\ns1 = Set.insert 1 (Set.insert 2 (Set.insert 3 Set.empty))\ns2 = Set.insert 3 (Set.insert 4 (Set.insert 5 Set.empty))\ns3 = Set.insert 1 (Set.insert 2 Set.empty)\n")
+
+(hk-test
+  "setops.hs — union size = 5"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.size (Set.union s1 s2)\n")))
+  5)
+
+(hk-test
+  "setops.hs — intersection size = 1"
+  (hk-deep-force
+    (hk-run
+      (str hk-setops-source "main = Set.size (Set.intersection s1 s2)\n")))
+  1)
+
+(hk-test
+  "setops.hs — intersection contains 3"
+  (hk-deep-force
+    (hk-run
+      (str hk-setops-source "main = Set.member 3 (Set.intersection s1 s2)\n")))
+  (list "True"))
+
+(hk-test
+  "setops.hs — difference s1 s2 size = 2"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.size (Set.difference s1 s2)\n")))
+  2)
+
+(hk-test
+  "setops.hs — difference doesn't contain shared key"
+  (hk-deep-force
+    (hk-run
+      (str hk-setops-source "main = Set.member 3 (Set.difference s1 s2)\n")))
+  (list "False"))
+
+(hk-test
+  "setops.hs — s3 is subset of s1"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.isSubsetOf s3 s1\n")))
+  (list "True"))
+
+(hk-test
+  "setops.hs — s1 not subset of s3"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.isSubsetOf s1 s3\n")))
+  (list "False"))
+
+(hk-test
+  "setops.hs — empty set is subset of anything"
+  (hk-deep-force
+    (hk-run (str hk-setops-source "main = Set.isSubsetOf Set.empty s1\n")))
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-shapes.sx

@@ -0,0 +1,40 @@
+;; shapes.hs — class Area with a default perimeter, two instances
+;;             using where-local helpers.
+;;
+;; Exercises Phase 13: class default method (perimeter), instance
+;; methods that use `where`-bindings.
+
+(define
+  hk-shapes-source
+  "class Shape a where\n  area :: a -> Int\n  perimeter :: a -> Int\n  perimeter x = quadrilateral x\n    where quadrilateral y = 2 * (sideA y + sideB y)\n          sideA z = 1\n          sideB z = 1\n\ndata Square = Square Int\ndata Rect = Rect Int Int\n\ninstance Shape Square where\n  area (Square s) = s * s\n  perimeter (Square s) = 4 * s\n\ninstance Shape Rect where\n  area (Rect w h) = w * h\n  perimeter (Rect w h) = peri\n    where peri = 2 * (w + h)\n")
+
+(hk-test
+  "shapes.hs — area of Square 5 = 25"
+  (hk-deep-force (hk-run (str hk-shapes-source "main = area (Square 5)\n")))
+  25)
+
+(hk-test
+  "shapes.hs — perimeter of Square 5 = 20"
+  (hk-deep-force
+    (hk-run (str hk-shapes-source "main = perimeter (Square 5)\n")))
+  20)
+
+(hk-test
+  "shapes.hs — area of Rect 3 4 = 12"
+  (hk-deep-force (hk-run (str hk-shapes-source "main = area (Rect 3 4)\n")))
+  12)
+
+(hk-test
+  "shapes.hs — perimeter of Rect 3 4 = 14 (via where-bound)"
+  (hk-deep-force
+    (hk-run (str hk-shapes-source "main = perimeter (Rect 3 4)\n")))
+  14)
+
+(hk-test
+  "shapes.hs — Square sums area + perimeter"
+  (hk-deep-force
+    (hk-run
+      (str hk-shapes-source "main = area (Square 4) + perimeter (Square 4)\n")))
+  32)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-showadt.sx

@@ -0,0 +1,45 @@
+;; showadt.hs — `deriving (Show)` on a multi-constructor recursive ADT.
+;; Source: classic exposition example, e.g. Real World Haskell ch.6.
+;;
+;; Exercises Phase 8: `deriving (Show)` on an ADT whose constructors recurse
+;; into themselves; precedence-based paren wrapping for nested arguments;
+;; `print` from the prelude (which is `putStrLn (show x)`).
+
+(define
+  hk-showadt-source
+  "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\n\nmain = do\n  print (Lit 3)\n  print (Add (Lit 1) (Lit 2))\n  print (Mul (Lit 3) (Add (Lit 4) (Lit 5)))\n")
+
+(hk-test
+  "showadt.hs — main prints three lines"
+  (hk-run-io hk-showadt-source)
+  (list "Lit 3" "Add (Lit 1) (Lit 2)" "Mul (Lit 3) (Add (Lit 4) (Lit 5))"))
+
+(hk-test
+  "showadt.hs — show Lit 3"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit 3)"))
+  "Lit 3")
+
+(hk-test
+  "showadt.hs — show Add wraps both args"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Add (Lit 1) (Lit 2))"))
+  "Add (Lit 1) (Lit 2)")
+
+(hk-test
+  "showadt.hs — fully nested Mul of Adds"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4)))"))
+  "Mul (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4))")
+
+(hk-test
+  "showadt.hs — Lit with negative literal wraps int in parens"
+  (hk-deep-force
+    (hk-run
+      "data Expr = Lit Int | Add Expr Expr | Mul Expr Expr deriving (Show)\nmain = show (Lit (negate 7))"))
+  "Lit (-7)")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-showio.sx

@@ -0,0 +1,36 @@
+;; showio.hs — `print` on various types inside a `do` block.
+;;
+;; Exercises Phase 8 `print x = putStrLn (show x)` and the IO monad's
+;; statement sequencing. Each `print` produces one io-line.
+
+(define
+  hk-showio-source
+  "main = do\n  print 42\n  print True\n  print False\n  print [1,2,3]\n  print (1, 2)\n  print (Just 5)\n  print Nothing\n  print \"hello\"\n")
+
+(hk-test
+  "showio.hs — main produces 8 lines, all show-formatted"
+  (hk-run-io hk-showio-source)
+  (list "42" "True" "False" "[1,2,3]" "(1,2)" "Just 5" "Nothing" "\"hello\""))
+
+(hk-test
+  "showio.hs — print Int alone"
+  (hk-run-io "main = print 42")
+  (list "42"))
+
+(hk-test
+  "showio.hs — print list of Maybe"
+  (hk-run-io "main = print [Just 1, Nothing, Just 3]")
+  (list "[Just 1,Nothing,Just 3]"))
+
+(hk-test
+  "showio.hs — print nested tuple"
+  (hk-run-io "main = print ((1, 2), (3, 4))")
+  (list "((1,2),(3,4))"))
+
+(hk-test
+  "showio.hs — print derived ADT inside do"
+  (hk-run-io
+    "data Color = Red | Green | Blue deriving (Show)\nmain = do { print Red; print Green; print Blue }")
+  (list "Red" "Green" "Blue"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-statistics.sx

@@ -0,0 +1,45 @@
+;; statistics.hs — mean, variance, std-dev on a [Double].
+;; Source: classic textbook example.
+;;
+;; Exercises Phase 10: `fromIntegral`, `/`, `sqrt`, list ops on `[Double]`.
+
+(define
+  hk-prog-val
+  (fn
+    (src name)
+    (hk-deep-force (get (hk-eval-program (hk-core src)) name))))
+
+(define
+  hk-stats-source
+  "mean xs = sum xs / fromIntegral (length xs)\n\nvariance xs = let m = mean xs\n                  sqDiff x = (x - m) * (x - m)\n              in sum (map sqDiff xs) / fromIntegral (length xs)\n\nstdDev xs = sqrt (variance xs)\n")
+
+(hk-test
+  "statistics.hs — mean [1,2,3,4,5] = 3"
+  (hk-prog-val (str hk-stats-source "r = mean [1.0,2.0,3.0,4.0,5.0]\n") "r")
+  3)
+
+(hk-test
+  "statistics.hs — mean [10,20,30] = 20"
+  (hk-prog-val (str hk-stats-source "r = mean [10.0,20.0,30.0]\n") "r")
+  20)
+
+(hk-test
+  "statistics.hs — variance [2,4,4,4,5,5,7,9] = 4"
+  (hk-prog-val
+    (str hk-stats-source "r = variance [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
+    "r")
+  4)
+
+(hk-test
+  "statistics.hs — stdDev [2,4,4,4,5,5,7,9] = 2"
+  (hk-prog-val
+    (str hk-stats-source "r = stdDev [2.0,4.0,4.0,4.0,5.0,5.0,7.0,9.0]\n")
+    "r")
+  2)
+
+(hk-test
+  "statistics.hs — variance of constant list = 0"
+  (hk-prog-val (str hk-stats-source "r = variance [5.0,5.0,5.0,5.0]\n") "r")
+  0)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-trycatch.sx

@@ -0,0 +1,95 @@
+;; trycatch.hs — try pattern: branch on Left/Right (Phase 16 conformance).
+
+(define
+  hk-trycatch-source
+  "parseInt :: String -> IO Int
+parseInt \"zero\" = return 0
+parseInt \"one\"  = return 1
+parseInt \"two\"  = return 2
+parseInt s = throwIO (SomeException (\"unknown: \" ++ s))
+
+describe :: Either SomeException Int -> String
+describe (Right v) = \"got \" ++ show v
+describe (Left (SomeException m)) = \"err: \" ++ m
+
+trial :: String -> IO String
+trial s = do
+  r <- try (parseInt s)
+  return (describe r)
+
+run3 :: String -> String -> String -> IO [String]
+run3 a b c = do
+  ra <- trial a
+  rb <- trial b
+  rc <- trial c
+  return [ra, rb, rc]
+
+")
+
+(hk-test
+  "trycatch.hs — Right branch"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = trial \"one\"")))
+  (list "IO" "got 1"))
+
+(hk-test
+  "trycatch.hs — Left branch with message"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = trial \"banana\"")))
+  (list "IO" "err: unknown: banana"))
+
+(hk-test
+  "trycatch.hs — chain over three inputs, all good"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = run3 \"zero\" \"one\" \"two\"")))
+  (list "IO"
+    (list ":" "got 0"
+      (list ":" "got 1"
+        (list ":" "got 2"
+          (list "[]"))))))
+
+(hk-test
+  "trycatch.hs — chain over three inputs, mixed"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source "main = run3 \"zero\" \"qux\" \"two\"")))
+  (list "IO"
+    (list ":" "got 0"
+      (list ":" "err: unknown: qux"
+        (list ":" "got 2"
+          (list "[]"))))))
+
+(hk-test
+  "trycatch.hs — Left from throwIO carries message"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = do { r <- try (throwIO (SomeException \"explicit\")); return (describe r) }")))
+  (list "IO" "err: explicit"))
+
+(hk-test
+  "trycatch.hs — Right preserves the int"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = do { r <- try (return 42); return (describe r) }")))
+  (list "IO" "got 42"))
+
+(hk-test
+  "trycatch.hs — pattern-bind on Right inside do"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = do { Right v <- try (parseInt \"two\"); return (v + 100) }")))
+  (list "IO" 102))
+
+(hk-test
+  "trycatch.hs — handle alias on parseInt failure"
+  (hk-deep-force
+    (hk-run
+      (str hk-trycatch-source
+        "main = handle (\\(SomeException m) -> return (\"caught: \" ++ m)) (parseInt \"nope\" >>= (\\v -> return (show v)))")))
+  (list "IO" "caught: unknown: nope"))

lib/haskell/tests/program-uniquewords.sx

@@ -0,0 +1,35 @@
+;; uniquewords.hs — count unique words using Data.Set.
+;;
+;; Exercises Phase 12: `import qualified Data.Set as Set`, `Set.empty`,
+;; `Set.insert`, `Set.size`, `foldl`.
+
+(define
+  hk-uniquewords-source
+  "import qualified Data.Set as Set\n\naddWord s w = Set.insert w s\n\nuniqueWords ws = foldl addWord Set.empty ws\n\nresult = uniqueWords [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
+
+(hk-test
+  "uniquewords.hs — unique count = 3"
+  (hk-deep-force
+    (hk-run (str hk-uniquewords-source "main = Set.size result\n")))
+  3)
+
+(hk-test
+  "uniquewords.hs — \"the\" present"
+  (hk-deep-force
+    (hk-run (str hk-uniquewords-source "main = Set.member \"the\" result\n")))
+  (list "True"))
+
+(hk-test
+  "uniquewords.hs — \"missing\" absent"
+  (hk-deep-force
+    (hk-run (str hk-uniquewords-source "main = Set.member \"missing\" result\n")))
+  (list "False"))
+
+(hk-test
+  "uniquewords.hs — empty list yields empty set"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as Set\nmain = Set.size (foldl (\\s w -> Set.insert w s) Set.empty [])"))
+  0)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/program-wordfreq.sx

@@ -0,0 +1,54 @@
+;; wordfreq.hs — word-frequency histogram using Data.Map.
+;; Source: Rosetta Code "Word frequency" (Haskell entry, simplified).
+;;
+;; Exercises Phase 11: `import qualified Data.Map as Map`, `Map.empty`,
+;; `Map.insertWith`, `Map.lookup`, `Map.findWithDefault`, `foldl`.
+
+(define
+  hk-wordfreq-source
+  "import qualified Data.Map as Map\n\ncountWord m w = Map.insertWith (+) w 1 m\n\nwordFreq xs = foldl countWord Map.empty xs\n\nresult = wordFreq [\"the\", \"cat\", \"the\", \"dog\", \"the\", \"cat\"]\n")
+
+(hk-test
+  "wordfreq.hs — \"the\" counted 3 times"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"the\" result\n")))
+  (list "Just" 3))
+
+(hk-test
+  "wordfreq.hs — \"cat\" counted 2 times"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"cat\" result\n")))
+  (list "Just" 2))
+
+(hk-test
+  "wordfreq.hs — \"dog\" counted 1 time"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"dog\" result\n")))
+  (list "Just" 1))
+
+(hk-test
+  "wordfreq.hs — \"missing\" not present"
+  (hk-deep-force
+    (hk-run (str hk-wordfreq-source "main = Map.lookup \"missing\" result\n")))
+  (list "Nothing"))
+
+(hk-test
+  "wordfreq.hs — Map.size = 3 unique words"
+  (hk-deep-force (hk-run (str hk-wordfreq-source "main = Map.size result\n")))
+  3)
+
+(hk-test
+  "wordfreq.hs — findWithDefault for missing returns 0"
+  (hk-deep-force
+    (hk-run
+      (str hk-wordfreq-source "main = Map.findWithDefault 0 \"absent\" result\n")))
+  0)
+
+(hk-test
+  "wordfreq.hs — findWithDefault for present returns count"
+  (hk-deep-force
+    (hk-run
+      (str hk-wordfreq-source "main = Map.findWithDefault 0 \"the\" result\n")))
+  3)
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/records.sx

@@ -0,0 +1,127 @@
+;; records.sx — Phase 14 record syntax tests.
+
+(define
+  hk-person-source
+  "data Person = Person { name :: String, age :: Int }\n")
+
+(define hk-pt-source "data Pt = Pt { x :: Int, y :: Int }\n")
+
+;; ── Creation ────────────────────────────────────────────────
+(hk-test
+  "creation: Person { name = \"a\", age = 1 } via accessor name"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "main = name (Person { name = \"alice\", age = 30 })")))
+  "alice")
+
+(hk-test
+  "creation: source order doesn't matter (age first)"
+  (hk-deep-force
+    (hk-run
+      (str hk-person-source "main = name (Person { age = 99, name = \"bob\" })")))
+  "bob")
+
+(hk-test
+  "creation: age accessor returns the right field"
+  (hk-deep-force
+    (hk-run
+      (str hk-person-source "main = age (Person { age = 99, name = \"bob\" })")))
+  99)
+
+;; ── Accessors ──────────────────────────────────────────────
+(hk-test
+  "accessor: x of Pt"
+  (hk-deep-force
+    (hk-run (str hk-pt-source "main = x (Pt { x = 7, y = 99 })")))
+  7)
+
+(hk-test
+  "accessor: y of Pt"
+  (hk-deep-force
+    (hk-run (str hk-pt-source "main = y (Pt { x = 7, y = 99 })")))
+  99)
+
+;; ── Update — single field ──────────────────────────────────
+(hk-test
+  "update one field: age changes"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nmain = age (alice { age = 31 })")))
+  31)
+
+(hk-test
+  "update one field: name preserved"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nmain = name (alice { age = 31 })")))
+  "alice")
+
+;; ── Update — two fields ────────────────────────────────────
+(hk-test
+  "update two fields: both changed"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = age bob")))
+  50)
+
+(hk-test
+  "update two fields: name takes new value"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "alice = Person { name = \"alice\", age = 30 }\nbob = alice { name = \"bob\", age = 50 }\nmain = name bob")))
+  "bob")
+
+;; ── Record patterns ────────────────────────────────────────
+(hk-test
+  "case-alt record pattern: Pt { x = a }"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-pt-source
+        "getX p = case p of Pt { x = a } -> a\nmain = getX (Pt { x = 7, y = 99 })")))
+  7)
+
+(hk-test
+  "case-alt record pattern: multi-field bind"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-pt-source
+        "sumPt p = case p of Pt { x = a, y = b } -> a + b\nmain = sumPt (Pt { x = 3, y = 4 })")))
+  7)
+
+(hk-test
+  "fun-LHS record pattern"
+  (hk-deep-force
+    (hk-run
+      (str
+        hk-person-source
+        "getName (Person { name = n }) = n\nmain = getName (Person { name = \"alice\", age = 30 })")))
+  "alice")
+
+;; ── deriving Show on a record ───────────────────────────────
+(hk-test
+  "deriving Show on a record produces positional output"
+  (hk-deep-force
+    (hk-run
+      "data Person = Person { name :: String, age :: Int } deriving (Show)\nmain = show (Person { name = \"alice\", age = 30 })"))
+  "Person \"alice\" 30")
+
+(hk-test
+  "deriving Show on Pt"
+  (hk-deep-force
+    (hk-run
+      "data Pt = Pt { x :: Int, y :: Int } deriving (Show)\nmain = show (Pt { x = 3, y = 4 })"))
+  "Pt 3 4")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/set.sx

@@ -0,0 +1,119 @@
+;; set.sx — Phase 12 Data.Set unit tests.
+
+;; ── SX-level (direct hk-set-*) ───────────────────────────────
+(hk-test
+  "hk-set-empty: size 0 + null"
+  (list (hk-set-size hk-set-empty) (hk-set-null hk-set-empty))
+  (list 0 true))
+
+(hk-test
+  "hk-set-singleton: member yes"
+  (let
+    ((s (hk-set-singleton 5)))
+    (list (hk-set-size s) (hk-set-member 5 s) (hk-set-member 99 s)))
+  (list 1 true false))
+
+(hk-test
+  "hk-set-insert: idempotent"
+  (let
+    ((s (hk-set-insert 1 (hk-set-insert 1 hk-set-empty))))
+    (hk-set-size s))
+  1)
+
+(hk-test
+  "hk-set-from-list: dedupes"
+  (hk-set-to-asc-list (hk-set-from-list (list 3 1 4 1 5 9 2 6)))
+  (list 1 2 3 4 5 6 9))
+
+(hk-test
+  "hk-set-delete: removes"
+  (let
+    ((s (hk-set-from-list (list 1 2 3))))
+    (hk-set-to-asc-list (hk-set-delete 2 s)))
+  (list 1 3))
+
+(hk-test
+  "hk-set-union"
+  (hk-set-to-asc-list
+    (hk-set-union
+      (hk-set-from-list (list 1 2 3))
+      (hk-set-from-list (list 3 4 5))))
+  (list 1 2 3 4 5))
+
+(hk-test
+  "hk-set-intersection"
+  (hk-set-to-asc-list
+    (hk-set-intersection
+      (hk-set-from-list (list 1 2 3 4))
+      (hk-set-from-list (list 3 4 5 6))))
+  (list 3 4))
+
+(hk-test
+  "hk-set-difference"
+  (hk-set-to-asc-list
+    (hk-set-difference
+      (hk-set-from-list (list 1 2 3 4))
+      (hk-set-from-list (list 3 4 5))))
+  (list 1 2))
+
+(hk-test
+  "hk-set-is-subset-of: yes"
+  (hk-set-is-subset-of
+    (hk-set-from-list (list 2 3))
+    (hk-set-from-list (list 1 2 3 4)))
+  true)
+
+(hk-test
+  "hk-set-is-subset-of: no"
+  (hk-set-is-subset-of
+    (hk-set-from-list (list 5 6))
+    (hk-set-from-list (list 1 2 3 4)))
+  false)
+
+(hk-test
+  "hk-set-filter"
+  (hk-set-to-asc-list
+    (hk-set-filter (fn (k) (> k 2)) (hk-set-from-list (list 1 2 3 4 5))))
+  (list 3 4 5))
+
+(hk-test
+  "hk-set-map"
+  (hk-set-to-asc-list
+    (hk-set-map (fn (k) (* k 10)) (hk-set-from-list (list 1 2 3))))
+  (list 10 20 30))
+
+(hk-test
+  "hk-set-foldr: sum"
+  (hk-set-foldr + 0 (hk-set-from-list (list 1 2 3 4 5)))
+  15)
+
+;; ── Haskell-level (Set.* via import wiring) ──────────────────
+(hk-test
+  "Set.size after Set.insert chain"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as Set\nmain = Set.size (Set.insert 3 (Set.insert 1 (Set.insert 2 Set.empty)))"))
+  3)
+
+(hk-test
+  "Set.member true"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as Set\nmain = Set.member 5 (Set.insert 5 Set.empty)"))
+  (list "True"))
+
+(hk-test
+  "Set.union via Haskell"
+  (hk-deep-force
+    (hk-run
+      "import Data.Set\nmain = Set.size (Set.union (Set.insert 1 Set.empty) (Set.insert 2 Set.empty))"))
+  2)
+
+(hk-test
+  "Set.isSubsetOf via Haskell"
+  (hk-deep-force
+    (hk-run
+      "import qualified Data.Set as S\nmain = S.isSubsetOf (S.insert 1 S.empty) (S.insert 2 (S.insert 1 S.empty))"))
+  (list "True"))
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/show.sx

@@ -0,0 +1,140 @@
+;; show.sx — tests for the Show / Read class plumbing.
+;;
+;; Covers Phase 8:
+;;  - showsPrec / showParen / shows / showString stubs
+;;  - Read class stubs (reads / readsPrec / read)
+;;  - direct show coverage (Int, Bool, String, list, tuple, Maybe, ADT, ...)
+
+;; ── ShowS / showsPrec / showParen stubs ──────────────────────
+(hk-test
+  "shows: prepends show output"
+  (hk-deep-force (hk-run "main = shows 5 \"abc\""))
+  "5abc")
+
+(hk-test
+  "shows: works on True"
+  (hk-deep-force (hk-run "main = shows True \"x\""))
+  "Truex")
+
+(hk-test
+  "showString: prepends literal"
+  (hk-deep-force (hk-run "main = showString \"hello\" \" world\""))
+  "hello world")
+
+(hk-test
+  "showParen True: wraps inner output in parens"
+  (hk-deep-force (hk-run "main = showParen True (showString \"inside\") \"\""))
+  "(inside)")
+
+(hk-test
+  "showParen False: passes through unchanged"
+  (hk-deep-force (hk-run "main = showParen False (showString \"inside\") \"\""))
+  "inside")
+
+(hk-test
+  "showsPrec: prepends show output regardless of prec"
+  (hk-deep-force (hk-run "main = showsPrec 11 42 \"end\""))
+  "42end")
+
+(hk-test
+  "showParen + manual composition: build (Just 3)"
+  (hk-deep-force
+    (hk-run
+      "buildJust3 s = showString \"Just \" (shows 3 s)\nmain = showParen True buildJust3 \"\""))
+  "(Just 3)")
+
+;; ── Read stubs ───────────────────────────────────────────────
+(hk-test
+  "reads: stub returns empty list (null-check)"
+  (hk-deep-force (hk-run "main = show (null (reads \"42\"))"))
+  "True")
+
+(hk-test
+  "readsPrec: stub returns empty list"
+  (hk-deep-force (hk-run "main = show (null (readsPrec 0 \"True\"))"))
+  "True")
+
+(hk-test
+  "reads: type-checks in expression context (length)"
+  (hk-deep-force (hk-run "main = show (length (reads \"abc\"))"))
+  "0")
+
+;; ── Direct `show` audit coverage ─────────────────────────────
+(hk-test "show Int" (hk-deep-force (hk-run "main = show 42")) "42")
+
+(hk-test
+  "show negative Int"
+  (hk-deep-force (hk-run "main = show (negate 5)"))
+  "-5")
+
+(hk-test "show Bool True" (hk-deep-force (hk-run "main = show True")) "True")
+
+(hk-test
+  "show Bool False"
+  (hk-deep-force (hk-run "main = show False"))
+  "False")
+
+(hk-test
+  "show String quotes the value"
+  (hk-deep-force (hk-run "main = show \"hello\""))
+  "\"hello\"")
+
+(hk-test
+  "show list of Int"
+  (hk-deep-force (hk-run "main = show [1,2,3]"))
+  "[1,2,3]")
+
+(hk-test
+  "show empty list"
+  (hk-deep-force (hk-run "main = show (drop 5 [1,2,3])"))
+  "[]")
+
+(hk-test
+  "show pair tuple"
+  (hk-deep-force (hk-run "main = show (1, True)"))
+  "(1,True)")
+
+(hk-test
+  "show triple tuple"
+  (hk-deep-force (hk-run "main = show (1, 2, 3)"))
+  "(1,2,3)")
+
+(hk-test
+  "show Maybe Nothing"
+  (hk-deep-force (hk-run "main = show Nothing"))
+  "Nothing")
+
+(hk-test
+  "show Maybe Just"
+  (hk-deep-force (hk-run "main = show (Just 3)"))
+  "Just 3")
+
+(hk-test
+  "show nested Just wraps inner in parens"
+  (hk-deep-force (hk-run "main = show (Just (Just 3))"))
+  "Just (Just 3)")
+
+(hk-test
+  "show Just (negate 3) wraps negative in parens"
+  (hk-deep-force (hk-run "main = show (Just (negate 3))"))
+  "Just (-3)")
+
+(hk-test
+  "show custom nullary ADT"
+  (hk-deep-force
+    (hk-run "data Day = Mon | Tue | Wed deriving (Show)\nmain = show Tue"))
+  "Tue")
+
+(hk-test
+  "show custom multi-constructor ADT"
+  (hk-deep-force
+    (hk-run
+      "data Shape = Pt | Sq Int | Rect Int Int deriving (Show)\nmain = show (Rect 3 4)"))
+  "Rect 3 4")
+
+(hk-test
+  "show list of Maybe wraps each element"
+  (hk-deep-force (hk-run "main = show [Just 1, Nothing, Just 2]"))
+  "[Just 1,Nothing,Just 2]")
+
+{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail}

lib/haskell/tests/stdlib.sx

@@ -37,11 +37,11 @@
 (hk-ts "show neg" "negate 7" "-7")
 (hk-ts "show bool T" "True" "True")
 (hk-ts "show bool F" "False" "False")
-(hk-ts "show list" "[1,2,3]" "[1, 2, 3]")
-(hk-ts "show Just" "Just 5" "(Just 5)")
+(hk-ts "show list" "[1,2,3]" "[1,2,3]")
+(hk-ts "show Just" "Just 5" "Just 5")
 (hk-ts "show Nothing" "Nothing" "Nothing")
 (hk-ts "show LT" "LT" "LT")
-(hk-ts "show tuple" "(1, True)" "(1, True)")
+(hk-ts "show tuple" "(1, True)" "(1,True)")
 
 ;; ── Num extras ───────────────────────────────────────────────
 (hk-test "signum pos" (hk-deep-force (hk-run "main = signum 5")) 1)
@@ -59,13 +59,13 @@
 (hk-test
   "foldr cons"
   (hk-deep-force (hk-run "main = show (foldr (:) [] [1,2,3])"))
-  "[1, 2, 3]")
+  "[1,2,3]")
 
 ;; ── List ops ─────────────────────────────────────────────────
 (hk-test
   "reverse"
   (hk-deep-force (hk-run "main = show (reverse [1,2,3])"))
-  "[3, 2, 1]")
+  "[3,2,1]")
 (hk-test "null []" (hk-deep-force (hk-run "main = null []")) (list "True"))
 (hk-test
   "null xs"
@@ -82,7 +82,7 @@
 (hk-test
   "zip"
   (hk-deep-force (hk-run "main = show (zip [1,2] [3,4])"))
-  "[(1, 3), (2, 4)]")
+  "[(1,3),(2,4)]")
 (hk-test "sum" (hk-deep-force (hk-run "main = sum [1,2,3,4,5]")) 15)
 (hk-test "product" (hk-deep-force (hk-run "main = product [1,2,3,4]")) 24)
 (hk-test "maximum" (hk-deep-force (hk-run "main = maximum [3,1,9,2]")) 9)
@@ -112,7 +112,7 @@
 (hk-test
   "fmap list"
   (hk-deep-force (hk-run "main = show (fmap (+1) [1,2,3])"))
-  "[2, 3, 4]")
+  "[2,3,4]")
 
 ;; ── Monad / Applicative ──────────────────────────────────────
 (hk-test "return" (hk-deep-force (hk-run "main = return 7")) (list "IO" 7))
@@ -134,7 +134,7 @@
 (hk-test
   "lookup hit"
   (hk-deep-force (hk-run "main = show (lookup 2 [(1,10),(2,20)])"))
-  "(Just 20)")
+  "Just 20")
 (hk-test
   "lookup miss"
   (hk-deep-force (hk-run "main = show (lookup 9 [(1,10)])"))

lib/haskell/tests/string-char.sx

@@ -0,0 +1,139 @@
+;; String / Char tests — Phase 7 items 1-4.
+;;
+;; Covers:
+;;   hk-str? / hk-str-head / hk-str-tail / hk-str-null?   (runtime helpers)
+;;   chr / ord / toUpper / toLower                          (builtins in eval)
+;;   cons-pattern on strings via match.sx                   (":"-intercept)
+;;   empty-list pattern on strings via match.sx             ("[]"-intercept)
+
+;; ── hk-str? predicate ────────────────────────────────────────────────────
+(hk-test "hk-str? native string" (hk-str? "hello") true)
+
+(hk-test "hk-str? empty string" (hk-str? "") true)
+
+(hk-test "hk-str? view dict" (hk-str? {:hk-off 1 :hk-str "hi"}) true)
+
+(hk-test "hk-str? rejects number" (hk-str? 42) false)
+
+;; ── hk-str-null? predicate ───────────────────────────────────────────────
+(hk-test "hk-str-null? empty string" (hk-str-null? "") true)
+
+(hk-test "hk-str-null? non-empty" (hk-str-null? "a") false)
+
+(hk-test "hk-str-null? exhausted view" (hk-str-null? {:hk-off 2 :hk-str "hi"}) true)
+
+(hk-test "hk-str-null? live view" (hk-str-null? {:hk-off 1 :hk-str "hi"}) false)
+
+;; ── hk-str-head ──────────────────────────────────────────────────────────
+(hk-test "hk-str-head native string" (hk-str-head "hello") 104)
+
+(hk-test "hk-str-head view at offset" (hk-str-head {:hk-off 1 :hk-str "hello"}) 101)
+
+;; ── hk-str-tail ──────────────────────────────────────────────────────────
+(hk-test "hk-str-tail of single char is nil" (hk-str-tail "h") (list "[]"))
+
+(hk-test
+  "hk-str-tail of two-char string is live view"
+  (hk-str-null? (hk-str-tail "hi"))
+  false)
+
+(hk-test
+  "hk-str-tail head of tail of hi is i"
+  (hk-str-head (hk-str-tail "hi"))
+  105)
+
+;; ── chr / ord ────────────────────────────────────────────────────────────
+(hk-test "chr 65 = A" (hk-eval-expr-source "chr 65") "A")
+
+(hk-test "chr 104 = h" (hk-eval-expr-source "chr 104") "h")
+
+(hk-test "ord char literal 'A' = 65" (hk-eval-expr-source "ord 'A'") 65)
+
+(hk-test "ord char literal 'a' = 97" (hk-eval-expr-source "ord 'a'") 97)
+
+(hk-test
+  "ord of head string = char code"
+  (hk-eval-expr-source "ord (head \"hello\")")
+  104)
+
+;; ── toUpper / toLower ────────────────────────────────────────────────────
+(hk-test "toUpper 97 = 65 (a->A)" (hk-eval-expr-source "toUpper 97") 65)
+
+(hk-test
+  "toUpper 65 = 65 (already upper)"
+  (hk-eval-expr-source "toUpper 65")
+  65)
+
+(hk-test
+  "toUpper 48 = 48 (digit unchanged)"
+  (hk-eval-expr-source "toUpper 48")
+  48)
+
+(hk-test "toLower 65 = 97 (A->a)" (hk-eval-expr-source "toLower 65") 97)
+
+(hk-test
+  "toLower 97 = 97 (already lower)"
+  (hk-eval-expr-source "toLower 97")
+  97)
+
+(hk-test
+  "toLower 48 = 48 (digit unchanged)"
+  (hk-eval-expr-source "toLower 48")
+  48)
+
+;; ── Pattern matching on strings ──────────────────────────────────────────
+(hk-test
+  "cons pattern: head of hello = 104"
+  (hk-eval-expr-source "case \"hello\" of { (x:_) -> x }")
+  104)
+
+(hk-test
+  "cons pattern: tail is traversable"
+  (hk-eval-expr-source "case \"hi\" of { (_:xs) -> case xs of { (y:_) -> y } }")
+  105)
+
+(hk-test
+  "empty list pattern matches empty string"
+  (hk-eval-expr-source "case \"\" of { [] -> True; _ -> False }")
+  (list "True"))
+
+(hk-test
+  "empty list pattern fails on non-empty"
+  (hk-eval-expr-source "case \"a\" of { [] -> True; _ -> False }")
+  (list "False"))
+
+(hk-test
+  "cons pattern fails on empty string"
+  (hk-eval-expr-source "case \"\" of { (_:_) -> True; _ -> False }")
+  (list "False"))
+
+;; ── Haskell programs using string traversal ──────────────────────────────
+(hk-test
+  "null prelude on empty string"
+  (hk-eval-expr-source "null \"\"")
+  (list "True"))
+
+(hk-test
+  "null prelude on non-empty string"
+  (hk-eval-expr-source "null \"abc\"")
+  (list "False"))
+
+(hk-test
+  "length of string via cons recursion"
+  (hk-eval-expr-source "let { f [] = 0; f (_:xs) = 1 + f xs } in f \"hello\"")
+  5)
+
+(hk-test
+  "map ord over string gives char codes"
+  (hk-deep-force (hk-eval-expr-source "map ord \"abc\""))
+  (list ":" 97 (list ":" 98 (list ":" 99 (list "[]")))))
+
+(hk-test
+  "map toUpper over char codes then chr"
+  (hk-eval-expr-source "chr (toUpper (ord (head \"abc\")))")
+  "A")
+
+(hk-test
+  "head then ord using prelude head"
+  (hk-eval-expr-source "ord (head \"hello\")")
+  104)

lib/hyperscript/compiler.sx

@@ -226,6 +226,28 @@
                             value)
                           (list (quote set!) (hs-to-sx target) value)))))))
               (true (list (quote set!) (hs-to-sx target) value)))))))
+    ;; Throttle/debounce extraction state — module-level so they don't get
+    ;; redefined on every emit-on call (which was causing JIT churn). Set
+    ;; via _strip-throttle-debounce at the start of each emit-on, used in
+    ;; the handler-build step inside scan-on.
+    (define _throttle-ms nil)
+    (define _debounce-ms nil)
+    (define
+      _strip-throttle-debounce
+      (fn
+        (lst)
+        (cond
+          ((<= (len lst) 1) lst)
+          ((= (first lst) :throttle)
+            (do
+              (set! _throttle-ms (nth lst 1))
+              (_strip-throttle-debounce (rest (rest lst)))))
+          ((= (first lst) :debounce)
+            (do
+              (set! _debounce-ms (nth lst 1))
+              (_strip-throttle-debounce (rest (rest lst)))))
+          (true
+            (cons (first lst) (_strip-throttle-debounce (rest lst)))))))
     (define
       emit-on
       (fn
@@ -234,6 +256,8 @@
           ((parts (rest ast)))
           (let
             ((event-name (first parts)))
+            (set! _throttle-ms nil)
+            (set! _debounce-ms nil)
             (define
               scan-on
               (fn
@@ -266,6 +290,13 @@
                                   ((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
                                   (let
                                     ((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler)))))
+                                    (let
+                                      ((handler (cond
+                                                  (_throttle-ms
+                                                    (list (quote hs-throttle!) handler (hs-to-sx _throttle-ms)))
+                                                  (_debounce-ms
+                                                    (list (quote hs-debounce!) handler (hs-to-sx _debounce-ms)))
+                                                  (true handler))))
                                     (let
                                       ((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
                                       (cond
@@ -325,7 +356,7 @@
                                                       (first pair)
                                                       handler))
                                                   or-sources)))
-                                            on-call)))))))))))))
+                                            on-call))))))))))))))
                   ((= (first items) :from)
                     (scan-on
                       (rest (rest items))
@@ -469,7 +500,7 @@
                       count-filter-info
                       elsewhere?
                       or-sources)))))
-            (scan-on (rest parts) nil nil false nil nil nil nil nil false nil)))))
+            (scan-on (_strip-throttle-debounce (rest parts)) nil nil false nil nil nil nil nil false nil)))))
     (define
       emit-send
       (fn
@@ -2490,6 +2521,15 @@
                             (quote fn)
                             (list (quote it))
                             (hs-to-sx body))))
+                      ((and (list? expr) (= (first expr) (quote attr)))
+                        (list
+                          (quote hs-attr-watch!)
+                          (hs-to-sx (nth expr 2))
+                          (nth expr 1)
+                          (list
+                            (quote fn)
+                            (list (quote it))
+                            (hs-to-sx body))))
                       (true nil))))
                 ((= head (quote init))
                   (list

lib/hyperscript/parser.sx

@@ -1358,7 +1358,17 @@
                           cls
                           (first extra-classes)
                           tgt))
-                      ((match-kw "for")
+                      ((and
+                          (= (tp-type) "keyword") (= (tp-val) "for")
+                          ;; Only consume 'for' as a duration clause if the next
+                          ;; token is NOT '<ident> in ...' — that pattern is a
+                          ;; for-in loop, not a toggle duration.
+                          (not
+                            (and
+                              (> (len tokens) (+ p 2))
+                              (= (get (nth tokens (+ p 1)) "type") "ident")
+                              (= (get (nth tokens (+ p 2)) "value") "in")))
+                          (do (adv!) true))
                         (let
                           ((dur (parse-expr)))
                           (list (quote toggle-class-for) cls tgt dur)))
@@ -3090,7 +3100,17 @@
                               (= (tp-val) "queue"))
                             (do (adv!) (adv!)))
                           (let
-                            ((every? (match-kw "every")))
+                            ((every? (match-kw "every"))
+                             (throttle-ms nil)
+                             (debounce-ms nil))
+                            ;; 'throttled at <duration>' / 'debounced at <duration>'
+                            ;; — parsed as handler modifiers, captured as :throttle / :debounce parts.
+                            (when (and (= (tp-type) "ident") (= (tp-val) "throttled"))
+                              (adv!)
+                              (when (match-kw "at") (set! throttle-ms (parse-expr))))
+                            (when (and (= (tp-type) "ident") (= (tp-val) "debounced"))
+                              (adv!)
+                              (when (match-kw "at") (set! debounce-ms (parse-expr))))
                             (let
                               ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
                               (let
@@ -3105,6 +3125,10 @@
                                   (match-kw "end")
                                   (let
                                     ((parts (list (quote on) event-name)))
+                                    (let
+                                      ((parts (if throttle-ms (append parts (list :throttle throttle-ms)) parts)))
+                                    (let
+                                      ((parts (if debounce-ms (append parts (list :debounce debounce-ms)) parts)))
                                     (let
                                       ((parts (if every? (append parts (list :every true)) parts)))
                                       (let
@@ -3127,7 +3151,7 @@
                                                         ((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
                                                         (let
                                                           ((parts (append parts (list (if (> (len event-vars) 0) (cons (quote do) (append (map (fn (nm) (list (quote ref) nm)) event-vars) (if (and (list? body) (= (first body) (quote do))) (rest body) (list body)))) body)))))
-                                                          parts))))))))))))))))))))))))))
+                                                          parts))))))))))))))))))))))))))))
       (define
         parse-init-feat
         (fn
@@ -3177,6 +3201,7 @@
             (or
               (= (tp-type) "hat")
               (= (tp-type) "local")
+              (= (tp-type) "attr")
               (and (= (tp-type) "keyword") (= (tp-val) "dom")))
             (let
               ((expr (parse-expr)))

lib/hyperscript/runtime.sx

@@ -12,6 +12,29 @@
 
 ;; Register an event listener. Returns unlisten function.
 ;; (hs-on target event-name handler) → unlisten-fn
+(begin
+  (define _hs-config-log-all false)
+  (define _hs-log-captured (list))
+  (define
+    hs-set-log-all!
+    (fn (flag) (set! _hs-config-log-all (if flag true false))))
+  (define hs-get-log-captured (fn () _hs-log-captured))
+  (define
+    hs-clear-log-captured!
+    (fn () (begin (set! _hs-log-captured (list)) nil)))
+  (define
+    hs-log-event!
+    (fn
+      (msg)
+      (when
+        _hs-config-log-all
+        (begin
+          (set! _hs-log-captured (append _hs-log-captured (list msg)))
+          (host-call (host-global "console") "log" msg)
+          nil)))))
+
+;; Run an initializer function immediately.
+;; (hs-init thunk) — called at element boot time
 (define
   hs-each
   (fn
@@ -22,17 +45,52 @@
 ;; (hs-init thunk) — called at element boot time
 (define meta (host-new "Object"))
 
-;; Run an initializer function immediately.
-;; (hs-init thunk) — called at element boot time
-(define
-  hs-on-every
-  (fn (target event-name handler) (dom-listen target event-name handler)))
-
 ;; ── Async / timing ──────────────────────────────────────────────
 
 ;; Wait for a duration in milliseconds.
 ;; In hyperscript, wait is async-transparent — execution pauses.
 ;; Here we use perform/IO suspension for true pause semantics.
+(define
+  hs-on-every
+  (fn (target event-name handler) (dom-listen target event-name handler)))
+
+;; Throttle: drops events that arrive within the window. First event fires
+;; immediately; subsequent events within `ms` of the previous fire are dropped.
+;; Returns a wrapped handler suitable for hs-on / hs-on-every.
+(define
+  hs-throttle!
+  (fn
+    (handler ms)
+    (let
+      ((__hs-last-fire 0))
+      (fn
+        (event)
+        (let
+          ((__hs-now (host-call (host-global "Date") "now")))
+          (when
+            (>= (- __hs-now __hs-last-fire) ms)
+            (set! __hs-last-fire __hs-now)
+            (handler event)))))))
+
+;; Debounce: waits until `ms` has elapsed since the last event before firing.
+;; In our synchronous test mock no time passes, so the timer fires immediately
+;; via setTimeout(_, 0); the wrapped handler still gets called once per burst.
+(define
+  hs-debounce!
+  (fn
+    (handler ms)
+    (let
+      ((__hs-timer nil))
+      (fn
+        (event)
+        (when __hs-timer (host-call (host-global "window") "clearTimeout" __hs-timer))
+        (set! __hs-timer
+          (host-call (host-global "window") "setTimeout"
+            (host-new-function (list "ev") "return arguments[0](arguments[1]);")
+            ms handler event))))))
+
+;; Wait for a DOM event on a target.
+;; (hs-wait-for target event-name) — suspends until event fires
 (define
   _hs-on-caller
   (let
@@ -45,8 +103,7 @@
       (host-set! _ctx "meta" _m)
       _ctx)))
 
-;; Wait for a DOM event on a target.
-;; (hs-wait-for target event-name) — suspends until event fires
+;; Wait for CSS transitions/animations to settle on an element.
 (define
   hs-on
   (fn
@@ -66,14 +123,14 @@
               (append prev (list unlisten)))
             unlisten))))))
 
-;; Wait for CSS transitions/animations to settle on an element.
+;; ── Class manipulation ──────────────────────────────────────────
+
+;; Toggle a single class on an element.
 (define
   hs-on-every
   (fn (target event-name handler) (dom-listen target event-name handler)))
 
-;; ── Class manipulation ──────────────────────────────────────────
-
-;; Toggle a single class on an element.
+;; Toggle between two classes — exactly one is active at a time.
 (define
   hs-on-intersection-attach!
   (fn
@@ -89,7 +146,8 @@
           (host-call observer "observe" target)
           observer)))))
 
-;; Toggle between two classes — exactly one is active at a time.
+;; Take a class from siblings — add to target, remove from others.
+;; (hs-take! target cls) — like radio button class behavior
 (define
   hs-on-mutation-attach!
   (fn
@@ -110,19 +168,18 @@
             (host-call observer "observe" target opts)
             observer))))))
 
-;; Take a class from siblings — add to target, remove from others.
-;; (hs-take! target cls) — like radio button class behavior
-(define hs-init (fn (thunk) (thunk)))
-
 ;; ── DOM insertion ───────────────────────────────────────────────
 
 ;; Put content at a position relative to a target.
 ;; pos: "into" | "before" | "after"
-(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
+(define hs-init (fn (thunk) (thunk)))
 
 ;; ── Navigation / traversal ──────────────────────────────────────
 
 ;; Navigate to a URL.
+(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
+
+;; Find next sibling matching a selector (or any sibling).
 (begin
   (define
     hs-wait-for
@@ -135,7 +192,7 @@
       (target event-name timeout-ms)
       (perform (list (quote io-wait-event) target event-name timeout-ms)))))
 
-;; Find next sibling matching a selector (or any sibling).
+;; Find previous sibling matching a selector.
 (define
   hs-settle
   (fn
@@ -143,7 +200,7 @@
     (hs-null-raise! target)
     (when (not (nil? target)) (perform (list (quote io-settle) target)))))
 
-;; Find previous sibling matching a selector.
+;; First element matching selector within a scope.
 (define
   hs-toggle-class!
   (fn
@@ -153,7 +210,7 @@
       (not (nil? target))
       (host-call (host-get target "classList") "toggle" cls))))
 
-;; First element matching selector within a scope.
+;; Last element matching selector.
 (define
   hs-toggle-var-cycle!
   (fn
@@ -175,7 +232,7 @@
           var-name
           (if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
 
-;; Last element matching selector.
+;; First/last within a specific scope.
 (define
   hs-toggle-between!
   (fn
@@ -188,7 +245,6 @@
         (do (dom-remove-class target cls1) (dom-add-class target cls2))
         (do (dom-remove-class target cls2) (dom-add-class target cls1))))))
 
-;; First/last within a specific scope.
 (define
   hs-toggle-style!
   (fn
@@ -212,6 +268,9 @@
             (dom-set-style target prop "hidden")
             (dom-set-style target prop "")))))))
 
+;; ── Iteration ───────────────────────────────────────────────────
+
+;; Repeat a thunk N times.
 (define
   hs-toggle-style-between!
   (fn
@@ -223,9 +282,7 @@
         (dom-set-style target prop val2)
         (dom-set-style target prop val1)))))
 
-;; ── Iteration ───────────────────────────────────────────────────
-
-;; Repeat a thunk N times.
+;; Repeat forever (until break — relies on exception/continuation).
 (define
   hs-toggle-style-cycle!
   (fn
@@ -246,7 +303,10 @@
             (true (find-next (rest remaining))))))
       (dom-set-style target prop (find-next vals)))))
 
-;; Repeat forever (until break — relies on exception/continuation).
+;; ── Fetch ───────────────────────────────────────────────────────
+
+;; Fetch a URL, parse response according to format.
+;; (hs-fetch url format) — format is "json" | "text" | "html"
 (define
   hs-take!
   (fn
@@ -269,8 +329,7 @@
             (when with-cls (dom-remove-class target with-cls))))
         (let
           ((attr-val (if (> (len extra) 0) (first extra) nil))
-            (with-val
-              (if (> (len extra) 1) (nth extra 1) nil)))
+            (with-val (if (> (len extra) 1) (nth extra 1) nil)))
           (do
             (for-each
               (fn
@@ -287,10 +346,10 @@
               (dom-set-attr target name attr-val)
               (dom-set-attr target name ""))))))))
 
-;; ── Fetch ───────────────────────────────────────────────────────
+;; ── Type coercion ───────────────────────────────────────────────
 
-;; Fetch a URL, parse response according to format.
-;; (hs-fetch url format) — format is "json" | "text" | "html"
+;; Coerce a value to a type by name.
+;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
 (begin
   (define
     hs-element?
@@ -447,10 +506,10 @@
                     (dom-insert-adjacent-html target "beforeend" value)
                     (hs-boot-subtree! target)))))))))))
 
-;; ── Type coercion ───────────────────────────────────────────────
+;; ── Object creation ─────────────────────────────────────────────
 
-;; Coerce a value to a type by name.
-;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
+;; Make a new object of a given type.
+;; (hs-make type-name) — creates empty object/collection
 (define
   hs-add-to!
   (fn
@@ -464,10 +523,11 @@
       ((hs-is-set? target) (do (host-call target "add" value) target))
       (true (do (host-call target "push" value) target)))))
 
-;; ── Object creation ─────────────────────────────────────────────
+;; ── Behavior installation ───────────────────────────────────────
 
-;; Make a new object of a given type.
-;; (hs-make type-name) — creates empty object/collection
+;; Install a behavior on an element.
+;; A behavior is a function that takes (me ...params) and sets up features.
+;; (hs-install behavior-fn me ...args)
 (define
   hs-remove-from!
   (fn
@@ -477,11 +537,10 @@
       ((hs-is-set? target) (do (host-call target "delete" value) target))
       (true (host-call target "splice" (host-call target "indexOf" value) 1)))))
 
-;; ── Behavior installation ───────────────────────────────────────
+;; ── Measurement ─────────────────────────────────────────────────
 
-;; Install a behavior on an element.
-;; A behavior is a function that takes (me ...params) and sets up features.
-;; (hs-install behavior-fn me ...args)
+;; Measure an element's bounding rect, store as local variables.
+;; Returns a dict with x, y, width, height, top, left, right, bottom.
 (define
   hs-splice-at!
   (fn
@@ -494,10 +553,7 @@
           ((i (if (< idx 0) (+ n idx) idx)))
           (cond
             ((or (< i 0) (>= i n)) target)
-            (true
-              (concat
-                (slice target 0 i)
-                (slice target (+ i 1) n))))))
+            (true (concat (slice target 0 i) (slice target (+ i 1) n))))))
       (do
         (when
           target
@@ -508,10 +564,10 @@
               (host-call target "splice" i 1))))
         target))))
 
-;; ── Measurement ─────────────────────────────────────────────────
-
-;; Measure an element's bounding rect, store as local variables.
-;; Returns a dict with x, y, width, height, top, left, right, bottom.
+;; Return the current text selection as a string.  In the browser this is
+;; `window.getSelection().toString()`.  In the mock test runner, a test
+;; setup stashes the desired selection text at `window.__test_selection`
+;; and the fallback path returns that so tests can assert on the result.
 (define
   hs-index
   (fn
@@ -523,10 +579,11 @@
       ((string? obj) (nth obj key))
       (true (host-get obj key)))))
 
-;; Return the current text selection as a string.  In the browser this is
-;; `window.getSelection().toString()`.  In the mock test runner, a test
-;; setup stashes the desired selection text at `window.__test_selection`
-;; and the fallback path returns that so tests can assert on the result.
+
+;; ── Transition ──────────────────────────────────────────────────
+
+;; Transition a CSS property to a value, optionally with duration.
+;; (hs-transition target prop value duration)
 (define
   hs-put-at!
   (fn
@@ -548,11 +605,6 @@
                 ((= pos "start") (host-call target "unshift" value)))
               target)))))))
 
-
-;; ── Transition ──────────────────────────────────────────────────
-
-;; Transition a CSS property to a value, optionally with duration.
-;; (hs-transition target prop value duration)
 (define
   hs-dict-without
   (fn
@@ -589,6 +641,11 @@
       ((w (host-global "window")))
       (if w (host-call w "prompt" msg) nil))))
 
+
+;; ── Transition ──────────────────────────────────────────────────
+
+;; Transition a CSS property to a value, optionally with duration.
+;; (hs-transition target prop value duration)
 (define
   hs-answer
   (fn
@@ -597,11 +654,6 @@
       ((w (host-global "window")))
       (if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
 
-
-;; ── Transition ──────────────────────────────────────────────────
-
-;; Transition a CSS property to a value, optionally with duration.
-;; (hs-transition target prop value duration)
 (define
   hs-answer-alert
   (fn
@@ -662,6 +714,10 @@
             (if (nil? sel) "" (host-call sel "toString" (list))))
           stash)))))
 
+
+
+
+
 (define
   hs-reset!
   (fn
@@ -708,10 +764,6 @@
                   (when default-val (dom-set-prop target "value" default-val)))))
             (true nil)))))))
 
-
-
-
-
 (define
   hs-next
   (fn
@@ -730,7 +782,8 @@
               ((dom-matches? el sel) el)
               (true (find-next (dom-next-sibling el))))))
         (find-next sibling)))))
-
+;; ── Sandbox/test runtime additions ──────────────────────────────
+;; Property access — dot notation and .length
 (define
   hs-previous
   (fn
@@ -749,10 +802,9 @@
               ((dom-matches? el sel) el)
               (true (find-prev (dom-get-prop el "previousElementSibling"))))))
         (find-prev sibling)))))
-;; ── Sandbox/test runtime additions ──────────────────────────────
-;; Property access — dot notation and .length
-(define _hs-last-query-sel nil)
 ;; DOM query stub — sandbox returns empty list
+(define _hs-last-query-sel nil)
+;; Method dispatch — obj.method(args)
 (define
   hs-null-raise!
   (fn
@@ -763,7 +815,9 @@
         ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
         (host-set! (host-global "window") "_hs_null_error" msg)
         (guard (_null-e (true nil)) (raise msg))))))
-;; Method dispatch — obj.method(args)
+
+;; ── 0.9.90 features ─────────────────────────────────────────────
+;; beep! — debug logging, returns value unchanged
 (define
   hs-empty-raise!
   (fn
@@ -777,9 +831,7 @@
         ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
         (host-set! (host-global "window") "_hs_null_error" msg)
         (guard (_null-e (true nil)) (raise msg))))))
-
-;; ── 0.9.90 features ─────────────────────────────────────────────
-;; beep! — debug logging, returns value unchanged
+;; Property-based is — check obj.key truthiness
 (define
   hs-query-all-checked
   (fn
@@ -787,14 +839,14 @@
     (let
       ((result (hs-query-all sel)))
       (do (hs-empty-raise! result) result))))
-;; Property-based is — check obj.key truthiness
+;; Array slicing (inclusive both ends)
 (define
   hs-dispatch!
   (fn
     (target event detail)
     (hs-null-raise! target)
     (when (not (nil? target)) (dom-dispatch target event detail))))
-;; Array slicing (inclusive both ends)
+;; Collection: sorted by
 (define
   hs-query-all
   (fn
@@ -802,7 +854,7 @@
     (do
       (host-set! (host-global "window") "_hs_last_query_sel" sel)
       (dom-query-all (dom-document) sel))))
-;; Collection: sorted by
+;; Collection: sorted by descending
 (define
   hs-query-all-in
   (fn
@@ -811,17 +863,17 @@
       (nil? target)
       (hs-query-all sel)
       (host-call target "querySelectorAll" sel))))
-;; Collection: sorted by descending
+;; Collection: split by
 (define
   hs-list-set
   (fn
     (lst idx val)
     (append (take lst idx) (cons val (drop lst (+ idx 1))))))
-;; Collection: split by
+;; Collection: joined by
 (define
   hs-to-number
   (fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
-;; Collection: joined by
+
 (define
   hs-query-first
   (fn
@@ -951,7 +1003,7 @@
                   ((= (str ex) "hs-continue") (do-loop (rest remaining)))
                   (true (raise ex))))))))
       (do-loop items))))
-
+;; Collection: joined by
 (begin
   (define
     hs-append
@@ -992,7 +1044,7 @@
               (host-get value "outerHTML")
               (str value))))
         (true nil)))))
-;; Collection: joined by
+
 (define
   hs-sender
   (fn
@@ -1084,6 +1136,7 @@
               (hs-host-to-sx (perform (list "io-parse-json" raw))))
             ((= fmt "number")
               (hs-to-number (perform (list "io-parse-text" raw))))
+            ((= fmt "html") (perform (list "io-parse-html" raw)))
             (true (perform (list "io-parse-text" raw)))))))))
 
 (define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
@@ -1623,14 +1676,10 @@
                 ((ch (substring sel i (+ i 1))))
                 (cond
                   ((= ch ".")
-                    (do
-                      (flush!)
-                      (set! mode "class")
-                      (walk (+ i 1))))
+                    (do (flush!) (set! mode "class") (walk (+ i 1))))
                   ((= ch "#")
                     (do (flush!) (set! mode "id") (walk (+ i 1))))
-                  (true
-                    (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
+                  (true (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
         (walk 0)
         (flush!)
         {:tag tag :classes classes :id id}))))
@@ -1724,11 +1773,11 @@
     (value type-name)
     (if (nil? value) false (hs-type-check value type-name))))
 
+
 (define
   hs-strict-eq
   (fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
 
-
 (define
   hs-id=
   (fn
@@ -1760,6 +1809,20 @@
       ((nil? suffix) false)
       (true (ends-with? (str s) (str suffix))))))
 
+(define
+  hs-attr-watch!
+  (fn
+    (target attr-name handler)
+    (let
+      ((mo-class (host-get (host-global "window") "MutationObserver")))
+      (when
+        mo-class
+        (let
+          ((cb (fn (records observer) (for-each (fn (rec) (when (= (host-get rec "attributeName") attr-name) (handler (host-call target "getAttribute" attr-name)))) records))))
+          (let
+            ((mo (host-new "MutationObserver" cb)))
+            (host-call mo "observe" target {:attributeFilter (list attr-name) :attributes true})))))))
+
 (define
   hs-scoped-set!
   (fn
@@ -1805,10 +1868,7 @@
       ((and (dict? a) (dict? b))
         (let
           ((pos (host-call a "compareDocumentPosition" b)))
-          (if
-            (number? pos)
-            (not (= 0 (mod (/ pos 4) 2)))
-            false)))
+          (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
       (true (< (str a) (str b))))))
 
 (define
@@ -1929,10 +1989,7 @@
       ((and (dict? a) (dict? b))
         (let
           ((pos (host-call a "compareDocumentPosition" b)))
-          (if
-            (number? pos)
-            (not (= 0 (mod (/ pos 4) 2)))
-            false)))
+          (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
       (true (< (str a) (str b))))))
 
 (define
@@ -1985,9 +2042,7 @@
 
 (define
   hs-morph-char
-  (fn
-    (s p)
-    (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
+  (fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
 
 (define
   hs-morph-index-from
@@ -2015,10 +2070,7 @@
         (q)
         (let
           ((c (hs-morph-char s q)))
-          (if
-            (and c (< (index-of stop c) 0))
-            (loop (+ q 1))
-            q))))
+          (if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q))))
     (let ((e (loop p))) (list (substring s p e) e))))
 
 (define
@@ -2060,9 +2112,7 @@
                                 (append
                                   acc
                                   (list
-                                    (list
-                                      name
-                                      (substring s (+ p4 1) close)))))))
+                                    (list name (substring s (+ p4 1) close)))))))
                           ((= c2 "'")
                             (let
                               ((close (hs-morph-index-from s "'" (+ p4 1))))
@@ -2072,9 +2122,7 @@
                                 (append
                                   acc
                                   (list
-                                    (list
-                                      name
-                                      (substring s (+ p4 1) close)))))))
+                                    (list name (substring s (+ p4 1) close)))))))
                           (true
                             (let
                               ((r2 (hs-morph-read-until s p4 " \t\n/>")))
@@ -2158,9 +2206,7 @@
               (for-each
                 (fn
                   (c)
-                  (when
-                    (> (string-length c) 0)
-                    (dom-add-class el c)))
+                  (when (> (string-length c) 0) (dom-add-class el c)))
                 (split v " ")))
             ((and keep-id (= n "id")) nil)
             (true (dom-set-attr el n v)))))
@@ -2261,8 +2307,7 @@
           ((parts (split resolved ":")))
           (let
             ((prop (first parts))
-              (val
-                (if (> (len parts) 1) (nth parts 1) nil)))
+              (val (if (> (len parts) 1) (nth parts 1) nil)))
             (cond
               ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
                 (let
@@ -2302,8 +2347,7 @@
           ((parts (split resolved ":")))
           (let
             ((prop (first parts))
-              (val
-                (if (> (len parts) 1) (nth parts 1) nil)))
+              (val (if (> (len parts) 1) (nth parts 1) nil)))
             (cond
               ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
                 (let
@@ -2408,14 +2452,10 @@
                             (if
                               (= depth 1)
                               j
-                              (find-close
-                                (+ j 1)
-                                (- depth 1)))
+                              (find-close (+ j 1) (- depth 1)))
                             (if
                               (= (nth raw j) "{")
-                              (find-close
-                                (+ j 1)
-                                (+ depth 1))
+                              (find-close (+ j 1) (+ depth 1))
                               (find-close (+ j 1) depth))))))
                     (let
                       ((close (find-close start 1)))
@@ -2526,10 +2566,7 @@
               (if
                 (= (len lst) 0)
                 -1
-                (if
-                  (= (first lst) item)
-                  i
-                  (idx-loop (rest lst) (+ i 1))))))
+                (if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
           (idx-loop obj 0)))
       (true
         (let
@@ -2621,8 +2658,7 @@
                 (cond
                   ((= end "hs-pick-end") n)
                   ((= end "hs-pick-start") 0)
-                  ((and (number? end) (< end 0))
-                    (max 0 (+ n end)))
+                  ((and (number? end) (< end 0)) (max 0 (+ n end)))
                   (true end))))
             (cond
               ((string? col) (slice col s e))
@@ -2802,6 +2838,8 @@
   hs-sorted-by-desc
   (fn (col key-fn) (reverse (hs-sorted-by col key-fn))))
 
+;; ── SourceInfo API ────────────────────────────────────────────────
+
 (define
   hs-dom-has-var?
   (fn
@@ -2821,8 +2859,6 @@
       ((store (host-get el "__hs_vars")))
       (if (nil? store) nil (host-get store name)))))
 
-;; ── SourceInfo API ────────────────────────────────────────────────
-
 (define
   hs-dom-set-var-raw!
   (fn
@@ -2913,7 +2949,12 @@
 
 (define
   hs-null-error!
-  (fn (selector) (raise (str "'" selector "' is null"))))
+  (fn
+    (selector)
+    (let
+      ((msg (str "'" selector "' is null")))
+      (host-set! (host-global "window") "_hs_null_error" msg)
+      (guard (_null-e (true nil)) (raise msg)))))
 
 (define
   hs-named-target
@@ -2933,9 +2974,7 @@
       ((results (hs-query-all selector)))
       (if
         (and
-          (or
-            (nil? results)
-            (and (list? results) (= (len results) 0)))
+          (or (nil? results) (and (list? results) (= (len results) 0)))
           (string? selector)
           (> (len selector) 0)
           (= (substring selector 0 1) "#"))

lib/hyperscript/tokenizer.sx

@@ -855,4 +855,230 @@
                 :else (do (t-advance! 1) (scan-template!)))))))
       (scan-template!)
       (t-emit! "eof" nil)
-      tokens)))
+      tokens)))
+
+;; ── Stream wrapper for upstream-style stateful tokenizer API ───────────────
+;;
+;; Upstream _hyperscript exposes a Tokens object with cursor + follow-set
+;; semantics on _hyperscript.internals.tokenizer. Our hs-tokenize returns a
+;; flat list; the stream wrapper adds the stateful operations.
+;;
+;; Type names map ours → upstream's (e.g. "ident" → "IDENTIFIER").
+
+(define
+  hs-stream-type-map
+  (fn
+    (t)
+    (cond
+      ((= t "ident") "IDENTIFIER")
+      ((= t "number") "NUMBER")
+      ((= t "string") "STRING")
+      ((= t "class") "CLASS_REF")
+      ((= t "id") "ID_REF")
+      ((= t "attr") "ATTRIBUTE_REF")
+      ((= t "style") "STYLE_REF")
+      ((= t "whitespace") "WHITESPACE")
+      ((= t "op") "OPERATOR")
+      ((= t "eof") "EOF")
+      (true (upcase t)))))
+
+;; Create a stream from a source string.
+;; Returns a dict — mutable via dict-set!.
+(define
+  hs-stream
+  (fn
+    (src)
+    {:tokens (hs-tokenize src) :pos 0 :follows (list) :last-match nil :last-ws nil}))
+
+;; Skip whitespace tokens, advancing pos to the next non-WS token.
+;; Captures the last skipped whitespace value into :last-ws.
+(define
+  hs-stream-skip-ws!
+  (fn
+    (s)
+    (let
+      ((tokens (get s :tokens)))
+      (define
+        loop
+        (fn
+          ()
+          (let
+            ((p (get s :pos)))
+            (when
+              (and (< p (len tokens))
+                   (= (get (nth tokens p) :type) "whitespace"))
+              (do
+                (dict-set! s :last-ws (get (nth tokens p) :value))
+                (dict-set! s :pos (+ p 1))
+                (loop))))))
+      (loop))))
+
+;; Current token (after skipping whitespace).
+(define
+  hs-stream-current
+  (fn
+    (s)
+    (do
+      (hs-stream-skip-ws! s)
+      (let
+        ((tokens (get s :tokens)) (p (get s :pos)))
+        (if (< p (len tokens)) (nth tokens p) nil)))))
+
+;; Returns the current token if its value matches; advances and updates
+;; :last-match. Returns nil otherwise (no advance).
+;; Honors the follow set: tokens whose value is in :follows do NOT match.
+(define
+  hs-stream-match
+  (fn
+    (s value)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((some (fn (f) (= f value)) (get s :follows)) nil)
+        ((= (get cur :value) value)
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Match by upstream-style type name. Accepts any number of allowed types.
+(define
+  hs-stream-match-type
+  (fn
+    (s &rest types)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((some (fn (t) (= (hs-stream-type-map (get cur :type)) t)) types)
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Match if value is one of the given names.
+(define
+  hs-stream-match-any
+  (fn
+    (s &rest names)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((some (fn (n) (= (get cur :value) n)) names)
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Match an op token whose value is in the list.
+(define
+  hs-stream-match-any-op
+  (fn
+    (s &rest ops)
+    (let
+      ((cur (hs-stream-current s)))
+      (cond
+        ((nil? cur) nil)
+        ((and (= (get cur :type) "op")
+              (some (fn (o) (= (get cur :value) o)) ops))
+          (do
+            (dict-set! s :pos (+ (get s :pos) 1))
+            (dict-set! s :last-match cur)
+            cur))
+        (true nil)))))
+
+;; Peek N non-WS tokens ahead. Returns the token if its value matches; nil otherwise.
+(define
+  hs-stream-peek
+  (fn
+    (s value offset)
+    (let
+      ((tokens (get s :tokens)))
+      (define
+        skip-n-non-ws
+        (fn
+          (p remaining)
+          (cond
+            ((>= p (len tokens)) -1)
+            ((= (get (nth tokens p) :type) "whitespace")
+              (skip-n-non-ws (+ p 1) remaining))
+            ((= remaining 0) p)
+            (true (skip-n-non-ws (+ p 1) (- remaining 1))))))
+      (let
+        ((p (skip-n-non-ws (get s :pos) offset)))
+        (if (and (>= p 0) (< p (len tokens))
+                 (= (get (nth tokens p) :value) value))
+          (nth tokens p)
+          nil)))))
+
+;; Consume tokens until one whose value matches the marker. Returns
+;; the consumed list (excluding the marker). Marker becomes current.
+(define
+  hs-stream-consume-until
+  (fn
+    (s marker)
+    (let
+      ((tokens (get s :tokens)) (out (list)))
+      (define
+        loop
+        (fn
+          (acc)
+          (let
+            ((p (get s :pos)))
+            (cond
+              ((>= p (len tokens)) acc)
+              ((= (get (nth tokens p) :value) marker) acc)
+              (true
+                (do
+                  (dict-set! s :pos (+ p 1))
+                  (loop (append acc (list (nth tokens p))))))))))
+      (loop out))))
+
+;; Consume until the next whitespace token; returns the consumed list.
+(define
+  hs-stream-consume-until-ws
+  (fn
+    (s)
+    (let
+      ((tokens (get s :tokens)))
+      (define
+        loop
+        (fn
+          (acc)
+          (let
+            ((p (get s :pos)))
+            (cond
+              ((>= p (len tokens)) acc)
+              ((= (get (nth tokens p) :type) "whitespace") acc)
+              (true
+                (do
+                  (dict-set! s :pos (+ p 1))
+                  (loop (append acc (list (nth tokens p))))))))))
+      (loop (list)))))
+
+;; Follow-set management.
+(define hs-stream-push-follow! (fn (s v) (dict-set! s :follows (cons v (get s :follows)))))
+(define
+  hs-stream-pop-follow!
+  (fn (s) (let ((f (get s :follows))) (when (> (len f) 0) (dict-set! s :follows (rest f))))))
+(define
+  hs-stream-push-follows!
+  (fn (s vs) (for-each (fn (v) (hs-stream-push-follow! s v)) vs)))
+(define
+  hs-stream-pop-follows!
+  (fn (s n) (when (> n 0) (do (hs-stream-pop-follow! s) (hs-stream-pop-follows! s (- n 1))))))
+(define
+  hs-stream-clear-follows!
+  (fn (s) (let ((saved (get s :follows))) (do (dict-set! s :follows (list)) saved))))
+(define
+  hs-stream-restore-follows!
+  (fn (s saved) (dict-set! s :follows saved)))
+
+;; Last-consumed token / whitespace.
+(define hs-stream-last-match (fn (s) (get s :last-match)))
+(define hs-stream-last-ws (fn (s) (get s :last-ws)))

lib/lua/parser.sx

@@ -3,28 +3,33 @@
 (define lua-tok-value (fn (t) (if (= t nil) nil (get t :value))))
 
 (define
-  lua-binop-prec
-  (fn
-    (op)
-    (cond
-      ((= op "or") 1)
-      ((= op "and") 2)
-      ((= op "<") 3)
-      ((= op ">") 3)
-      ((= op "<=") 3)
-      ((= op ">=") 3)
-      ((= op "==") 3)
-      ((= op "~=") 3)
-      ((= op "..") 5)
-      ((= op "+") 6)
-      ((= op "-") 6)
-      ((= op "*") 7)
-      ((= op "/") 7)
-      ((= op "%") 7)
-      ((= op "^") 10)
-      (else 0))))
+  lua-op-table
+  (list
+    (list "or"  1 :left)
+    (list "and" 2 :left)
+    (list "<"   3 :left)
+    (list ">"   3 :left)
+    (list "<="  3 :left)
+    (list ">="  3 :left)
+    (list "=="  3 :left)
+    (list "~="  3 :left)
+    (list ".."  5 :right)
+    (list "+"   6 :left)
+    (list "-"   6 :left)
+    (list "*"   7 :left)
+    (list "/"   7 :left)
+    (list "%"   7 :left)
+    (list "^"  10 :right)))
 
-(define lua-binop-right? (fn (op) (or (= op "..") (= op "^"))))
+(define lua-binop-prec
+  (fn (op)
+    (let ((entry (pratt-op-lookup lua-op-table op)))
+      (if (= entry nil) 0 (pratt-op-prec entry)))))
+
+(define lua-binop-right?
+  (fn (op)
+    (let ((entry (pratt-op-lookup lua-op-table op)))
+      (and (not (= entry nil)) (= (pratt-op-assoc entry) :right)))))
 
 (define
   lua-parse

lib/lua/test.sh

@@ -30,6 +30,7 @@ cat > "$TMPFILE" << 'EPOCHS'
 (epoch 1)
 (load "lib/guest/lex.sx")
 (load "lib/guest/prefix.sx")
+(load "lib/guest/pratt.sx")
 (load "lib/lua/tokenizer.sx")
 (epoch 2)
 (load "lib/lua/parser.sx")

lib/minikanren/clpfd.sx

@@ -0,0 +1,590 @@
+;; lib/minikanren/clpfd.sx — Phase 6: native CLP(FD) on miniKanren.
+;;
+;; The substitution dict carries an extra reserved key "_fd" that holds a
+;; constraint-store record:
+;;
+;;   {:domains    {var-name -> sorted-int-list}
+;;    :constraints (... pending constraint closures ...)}
+;;
+;; Domains are sorted SX lists of ints (no duplicates).
+;; Constraints are functions s -> s-or-nil that propagate / re-check.
+;; They are re-fired after every label binding via fd-fire-store.
+
+(define fd-key "_fd")
+
+;; --- domain primitives ---
+
+(define
+  fd-dom-rev
+  (fn
+    (xs acc)
+    (cond
+      ((empty? xs) acc)
+      (:else (fd-dom-rev (rest xs) (cons (first xs) acc))))))
+
+(define
+  fd-dom-insert
+  (fn
+    (x desc)
+    (cond
+      ((empty? desc) (list x))
+      ((= x (first desc)) desc)
+      ((> x (first desc)) (cons x desc))
+      (:else (cons (first desc) (fd-dom-insert x (rest desc)))))))
+
+(define
+  fd-dom-sort-dedupe
+  (fn
+    (xs acc)
+    (cond
+      ((empty? xs) (fd-dom-rev acc (list)))
+      (:else (fd-dom-sort-dedupe (rest xs) (fd-dom-insert (first xs) acc))))))
+
+(define fd-dom-from-list (fn (xs) (fd-dom-sort-dedupe xs (list))))
+
+(define fd-dom-empty? (fn (d) (empty? d)))
+(define
+  fd-dom-singleton?
+  (fn (d) (and (not (empty? d)) (empty? (rest d)))))
+(define fd-dom-min (fn (d) (first d)))
+
+(define
+  fd-dom-last
+  (fn
+    (d)
+    (cond ((empty? (rest d)) (first d)) (:else (fd-dom-last (rest d))))))
+
+(define fd-dom-max (fn (d) (fd-dom-last d)))
+(define fd-dom-member? (fn (x d) (some (fn (y) (= x y)) d)))
+
+(define
+  fd-dom-intersect
+  (fn
+    (a b)
+    (cond
+      ((empty? a) (list))
+      ((empty? b) (list))
+      ((= (first a) (first b))
+        (cons (first a) (fd-dom-intersect (rest a) (rest b))))
+      ((< (first a) (first b)) (fd-dom-intersect (rest a) b))
+      (:else (fd-dom-intersect a (rest b))))))
+
+(define
+  fd-dom-without
+  (fn
+    (x d)
+    (cond
+      ((empty? d) (list))
+      ((= (first d) x) (rest d))
+      ((> (first d) x) d)
+      (:else (cons (first d) (fd-dom-without x (rest d)))))))
+
+(define
+  fd-dom-range
+  (fn
+    (lo hi)
+    (cond
+      ((> lo hi) (list))
+      (:else (cons lo (fd-dom-range (+ lo 1) hi))))))
+
+;; --- constraint store accessors ---
+
+(define fd-store-empty (fn () {:domains {} :constraints (list)}))
+
+(define
+  fd-store-of
+  (fn
+    (s)
+    (cond ((has-key? s fd-key) (get s fd-key)) (:else (fd-store-empty)))))
+
+(define fd-domains-of (fn (s) (get (fd-store-of s) :domains)))
+(define fd-with-store (fn (s store) (assoc s fd-key store)))
+
+(define
+  fd-domain-of
+  (fn
+    (s var-name)
+    (let
+      ((doms (fd-domains-of s)))
+      (cond ((has-key? doms var-name) (get doms var-name)) (:else nil)))))
+
+(define
+  fd-set-domain
+  (fn
+    (s var-name d)
+    (cond
+      ((fd-dom-empty? d) nil)
+      (:else
+        (let
+          ((store (fd-store-of s)))
+          (let
+            ((doms-prime (assoc (get store :domains) var-name d)))
+            (let
+              ((store-prime (assoc store :domains doms-prime)))
+              (fd-with-store s store-prime))))))))
+
+(define
+  fd-add-constraint
+  (fn
+    (s c)
+    (let
+      ((store (fd-store-of s)))
+      (let
+        ((cs-prime (cons c (get store :constraints))))
+        (let
+          ((store-prime (assoc store :constraints cs-prime)))
+          (fd-with-store s store-prime))))))
+
+(define
+  fd-fire-list
+  (fn
+    (cs s)
+    (cond
+      ((empty? cs) s)
+      (:else
+        (let
+          ((s2 ((first cs) s)))
+          (cond ((= s2 nil) nil) (:else (fd-fire-list (rest cs) s2))))))))
+
+(define
+  fd-store-signature
+  (fn
+    (s)
+    (let
+      ((doms (fd-domains-of s)))
+      (let
+        ((dom-sizes (reduce (fn (acc k) (+ acc (len (get doms k)))) 0 (keys doms))))
+        (+ dom-sizes (len (keys s)))))))
+
+(define
+  fd-fire-store
+  (fn
+    (s)
+    (let
+      ((s2 (fd-fire-list (get (fd-store-of s) :constraints) s)))
+      (cond
+        ((= s2 nil) nil)
+        ((= (fd-store-signature s) (fd-store-signature s2)) s2)
+        (:else (fd-fire-store s2))))))
+
+;; --- user-facing goals ---
+
+(define
+  fd-in
+  (fn
+    (x dom-list)
+    (fn
+      (s)
+      (let
+        ((new-dom (fd-dom-from-list dom-list)))
+        (let
+          ((wx (mk-walk x s)))
+          (cond
+            ((number? wx)
+              (cond ((fd-dom-member? wx new-dom) (unit s)) (:else mzero)))
+            ((is-var? wx)
+              (let
+                ((existing (fd-domain-of s (var-name wx))))
+                (let
+                  ((narrowed (cond ((= existing nil) new-dom) (:else (fd-dom-intersect existing new-dom)))))
+                  (let
+                    ((s2 (fd-set-domain s (var-name wx) narrowed)))
+                    (cond ((= s2 nil) mzero) (:else (unit s2)))))))
+            (:else mzero)))))))
+
+;; --- fd-neq ---
+
+(define
+  fd-neq-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((= wx wy) nil) (:else s)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((y-dom (fd-domain-of s (var-name wy))))
+            (cond
+              ((= y-dom nil) s)
+              (:else
+                (fd-set-domain s (var-name wy) (fd-dom-without wx y-dom))))))
+        ((and (number? wy) (is-var? wx))
+          (let
+            ((x-dom (fd-domain-of s (var-name wx))))
+            (cond
+              ((= x-dom nil) s)
+              (:else
+                (fd-set-domain s (var-name wx) (fd-dom-without wy x-dom))))))
+        (:else s)))))
+
+(define
+  fd-neq
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (s-prime) (fd-neq-prop x y s-prime))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s3 (c s2)))
+            (cond ((= s3 nil) mzero) (:else (unit s3)))))))))
+
+;; --- fd-lt ---
+
+(define
+  fd-lt-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((< wx wy) s) (:else nil)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((= yd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wy)
+                  (filter (fn (v) (> v wx)) yd))))))
+        ((and (is-var? wx) (number? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx))))
+            (cond
+              ((= xd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wx)
+                  (filter (fn (v) (< v wy)) xd))))))
+        ((and (is-var? wx) (is-var? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx)))
+              (yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((or (= xd nil) (= yd nil)) s)
+              (:else
+                (let
+                  ((xd-prime (filter (fn (v) (< v (fd-dom-max yd))) xd)))
+                  (let
+                    ((s2 (fd-set-domain s (var-name wx) xd-prime)))
+                    (cond
+                      ((= s2 nil) nil)
+                      (:else
+                        (let
+                          ((yd-prime (filter (fn (v) (> v (fd-dom-min xd-prime))) yd)))
+                          (fd-set-domain s2 (var-name wy) yd-prime))))))))))
+        (:else s)))))
+
+(define
+  fd-lt
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-lt-prop x y sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s3 (c s2)))
+            (cond ((= s3 nil) mzero) (:else (unit s3)))))))))
+
+;; --- fd-lte ---
+
+(define
+  fd-lte-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((<= wx wy) s) (:else nil)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((= yd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wy)
+                  (filter (fn (v) (>= v wx)) yd))))))
+        ((and (is-var? wx) (number? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx))))
+            (cond
+              ((= xd nil) s)
+              (:else
+                (fd-set-domain
+                  s
+                  (var-name wx)
+                  (filter (fn (v) (<= v wy)) xd))))))
+        ((and (is-var? wx) (is-var? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx)))
+              (yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((or (= xd nil) (= yd nil)) s)
+              (:else
+                (let
+                  ((xd-prime (filter (fn (v) (<= v (fd-dom-max yd))) xd)))
+                  (let
+                    ((s2 (fd-set-domain s (var-name wx) xd-prime)))
+                    (cond
+                      ((= s2 nil) nil)
+                      (:else
+                        (let
+                          ((yd-prime (filter (fn (v) (>= v (fd-dom-min xd-prime))) yd)))
+                          (fd-set-domain s2 (var-name wy) yd-prime))))))))))
+        (:else s)))))
+
+(define
+  fd-lte
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-lte-prop x y sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s3 (c s2)))
+            (cond ((= s3 nil) mzero) (:else (unit s3)))))))))
+
+;; --- fd-eq ---
+
+(define
+  fd-eq-prop
+  (fn
+    (x y s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)))
+      (cond
+        ((and (number? wx) (number? wy))
+          (cond ((= wx wy) s) (:else nil)))
+        ((and (number? wx) (is-var? wy))
+          (let
+            ((yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((and (not (= yd nil)) (not (fd-dom-member? wx yd))) nil)
+              (:else
+                (let
+                  ((s2 (mk-unify wy wx s)))
+                  (cond ((= s2 nil) nil) (:else s2)))))))
+        ((and (is-var? wx) (number? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx))))
+            (cond
+              ((and (not (= xd nil)) (not (fd-dom-member? wy xd))) nil)
+              (:else
+                (let
+                  ((s2 (mk-unify wx wy s)))
+                  (cond ((= s2 nil) nil) (:else s2)))))))
+        ((and (is-var? wx) (is-var? wy))
+          (let
+            ((xd (fd-domain-of s (var-name wx)))
+              (yd (fd-domain-of s (var-name wy))))
+            (cond
+              ((and (= xd nil) (= yd nil))
+                (let
+                  ((s2 (mk-unify wx wy s)))
+                  (cond ((= s2 nil) nil) (:else s2))))
+              (:else
+                (let
+                  ((shared (cond ((= xd nil) yd) ((= yd nil) xd) (:else (fd-dom-intersect xd yd)))))
+                  (cond
+                    ((fd-dom-empty? shared) nil)
+                    (:else
+                      (let
+                        ((s2 (fd-set-domain s (var-name wx) shared)))
+                        (cond
+                          ((= s2 nil) nil)
+                          (:else
+                            (let
+                              ((s3 (fd-set-domain s2 (var-name wy) shared)))
+                              (cond
+                                ((= s3 nil) nil)
+                                (:else (mk-unify wx wy s3))))))))))))))
+        (:else s)))))
+
+(define
+  fd-eq
+  (fn
+    (x y)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-eq-prop x y sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s3 (c s2)))
+            (cond ((= s3 nil) mzero) (:else (unit s3)))))))))
+
+;; --- labelling ---
+
+(define
+  fd-try-each-value
+  (fn
+    (x dom s)
+    (cond
+      ((empty? dom) mzero)
+      (:else
+        (let
+          ((s2 (mk-unify x (first dom) s)))
+          (let
+            ((s3 (cond ((= s2 nil) nil) (:else (fd-fire-store s2)))))
+            (let
+              ((this-stream (cond ((= s3 nil) mzero) (:else (unit s3))))
+                (rest-stream (fd-try-each-value x (rest dom) s)))
+              (mk-mplus this-stream rest-stream))))))))
+
+(define
+  fd-label-one
+  (fn
+    (x)
+    (fn
+      (s)
+      (let
+        ((wx (mk-walk x s)))
+        (cond
+          ((number? wx) (unit s))
+          ((is-var? wx)
+            (let
+              ((dom (fd-domain-of s (var-name wx))))
+              (cond
+                ((= dom nil) mzero)
+                (:else (fd-try-each-value wx dom s)))))
+          (:else mzero))))))
+
+(define
+  fd-label
+  (fn
+    (vars)
+    (cond
+      ((empty? vars) succeed)
+      (:else (mk-conj (fd-label-one (first vars)) (fd-label (rest vars)))))))
+
+;; --- fd-distinct (pairwise distinct via fd-neq) ---
+
+(define
+  fd-distinct-from-head
+  (fn
+    (x others)
+    (cond
+      ((empty? others) succeed)
+      (:else
+        (mk-conj
+          (fd-neq x (first others))
+          (fd-distinct-from-head x (rest others)))))))
+
+(define
+  fd-distinct
+  (fn
+    (vars)
+    (cond
+      ((empty? vars) succeed)
+      ((empty? (rest vars)) succeed)
+      (:else
+        (mk-conj
+          (fd-distinct-from-head (first vars) (rest vars))
+          (fd-distinct (rest vars)))))))
+
+;; --- fd-plus (x + y = z, ground-cases propagator) ---
+
+(define
+  fd-bind-or-narrow
+  (fn
+    (w target s)
+    (cond
+      ((number? w) (cond ((= w target) s) (:else nil)))
+      ((is-var? w)
+        (let
+          ((wd (fd-domain-of s (var-name w))))
+          (cond
+            ((and (not (= wd nil)) (not (fd-dom-member? target wd))) nil)
+            (:else
+              (let
+                ((s2 (mk-unify w target s)))
+                (cond ((= s2 nil) nil) (:else s2)))))))
+      (:else nil))))
+
+(define
+  fd-plus-prop
+  (fn
+    (x y z s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
+      (cond
+        ((and (number? wx) (number? wy) (number? wz))
+          (cond ((= (+ wx wy) wz) s) (:else nil)))
+        ((and (number? wx) (number? wy))
+          (fd-bind-or-narrow wz (+ wx wy) s))
+        ((and (number? wx) (number? wz))
+          (fd-bind-or-narrow wy (- wz wx) s))
+        ((and (number? wy) (number? wz))
+          (fd-bind-or-narrow wx (- wz wy) s))
+        (:else s)))))
+
+(define
+  fd-plus
+  (fn
+    (x y z)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-plus-prop x y z sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s3 (c s2)))
+            (cond ((= s3 nil) mzero) (:else (unit s3)))))))))
+
+;; --- fd-times (x * y = z, ground-cases propagator) ---
+
+(define
+  fd-times-prop
+  (fn
+    (x y z s)
+    (let
+      ((wx (mk-walk x s)) (wy (mk-walk y s)) (wz (mk-walk z s)))
+      (cond
+        ((and (number? wx) (number? wy) (number? wz))
+          (cond ((= (* wx wy) wz) s) (:else nil)))
+        ((and (number? wx) (number? wy))
+          (fd-bind-or-narrow wz (* wx wy) s))
+        ((and (number? wx) (number? wz))
+          (cond
+            ((= wx 0) (cond ((= wz 0) s) (:else nil)))
+            ((not (= (mod wz wx) 0)) nil)
+            (:else (fd-bind-or-narrow wy (/ wz wx) s))))
+        ((and (number? wy) (number? wz))
+          (cond
+            ((= wy 0) (cond ((= wz 0) s) (:else nil)))
+            ((not (= (mod wz wy) 0)) nil)
+            (:else (fd-bind-or-narrow wx (/ wz wy) s))))
+        (:else s)))))
+
+(define
+  fd-times
+  (fn
+    (x y z)
+    (fn
+      (s)
+      (let
+        ((c (fn (sp) (fd-times-prop x y z sp))))
+        (let
+          ((s2 (fd-add-constraint s c)))
+          (let
+            ((s3 (c s2)))
+            (cond ((= s3 nil) mzero) (:else (unit s3)))))))))

lib/minikanren/conda.sx

@@ -0,0 +1,42 @@
+;; lib/minikanren/conda.sx — Phase 5 piece A: `conda`, the soft-cut.
+;;
+;;   (conda (g0 g ...) (h0 h ...) ...)
+;;     — first clause whose head g0 produces ANY answer wins; ALL of g0's
+;;       answers are then conj'd with the rest of that clause; later
+;;       clauses are NOT tried.
+;;     — differs from condu only in not wrapping g0 in onceo: condu
+;;       commits to the SINGLE first answer, conda lets the head's full
+;;       answer-set flow into the rest of the clause.
+;;       (Reasoned Schemer chapter 10; Byrd 5.3.)
+
+(define
+  conda-try
+  (fn
+    (clauses s)
+    (cond
+      ((empty? clauses) mzero)
+      (:else
+        (let
+          ((cl (first clauses)))
+          (let
+            ((head-goal (first cl)) (rest-goals (rest cl)))
+            (let
+              ((peek (stream-take 1 (head-goal s))))
+              (if
+                (empty? peek)
+                (conda-try (rest clauses) s)
+                (mk-bind (head-goal s) (mk-conj-list rest-goals))))))))))
+
+(defmacro
+  conda
+  (&rest clauses)
+  (quasiquote
+    (fn
+      (s)
+      (conda-try
+        (list
+          (splice-unquote
+            (map
+              (fn (cl) (quasiquote (list (splice-unquote cl))))
+              clauses)))
+        s))))

lib/minikanren/conde.sx

@@ -0,0 +1,39 @@
+;; lib/minikanren/conde.sx — Phase 2 piece C: `conde`, the canonical
+;; miniKanren and-or form, with implicit Zzz inverse-eta delay so recursive
+;; relations like appendo terminate.
+;;
+;;   (conde (g1a g1b ...) (g2a g2b ...) ...)
+;;     ≡ (mk-disj (Zzz (mk-conj g1a g1b ...))
+;;                (Zzz (mk-conj g2a g2b ...)) ...)
+;;
+;; `Zzz g` wraps a goal expression in (fn (S) (fn () (g S))) so that
+;; `g`'s body isn't constructed until the surrounding fn is applied to a
+;; substitution AND the returned thunk is forced. This is what gives
+;; miniKanren its laziness — recursive goal definitions can be `(conde
+;; ... (... (recur ...)))` without infinite descent at construction time.
+;;
+;; Hygiene: the substitution parameter is gensym'd so that user goal
+;; expressions which themselves bind `s` (e.g. `(appendo l s ls)`) keep
+;; their lexical `s` and don't accidentally reference the wrapper's
+;; substitution. Without gensym, miniKanren relations that follow the
+;; common (l s ls) parameter convention are silently miscompiled.
+
+(defmacro
+  Zzz
+  (g)
+  (let
+    ((s-sym (gensym "zzz-s-")))
+    (quasiquote
+      (fn ((unquote s-sym)) (fn () ((unquote g) (unquote s-sym)))))))
+
+(defmacro
+  conde
+  (&rest clauses)
+  (quasiquote
+    (mk-disj
+      (splice-unquote
+        (map
+          (fn
+            (clause)
+            (quasiquote (Zzz (mk-conj (splice-unquote clause)))))
+          clauses)))))