flan/test/test_acceptance.ml

(* The milestone-2 acceptance test: a table of expression/result pairs run
   through a compiled calc-me (plan.org, Build sequence).

   It is a table rather than a golden file because milestone 3 runs the *same*
   table on wasm32 — headless is what makes one test cover both targets. *)

open Flan

let failures = ref 0

let scratch = Filename.get_temp_dir_name ()

let run exe arg =
  let out = Filename.concat scratch "flan-acceptance.out" in
  let cmd =
    Printf.sprintf "%s %s > %s 2>&1"
      (Filename.quote exe)
      (match arg with None -> "" | Some a -> Filename.quote a)
      (Filename.quote out)
  in
  let code = Sys.command cmd in
  let text = In_channel.with_open_bin out In_channel.input_all in
  Sys.remove out;
  (code, text)

let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) path =
  let exe =
    Filename.concat scratch
      ("flan-t-" ^ Filename.remove_extension (Filename.basename path))
  in
  (* Through [Load], so a program with an (import ...) is buildable here: it
     brings back the package's C shim and linker arguments as well. *)
  let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
  let p = Check.program l.Load.decls in
  ignore (Build.executable ~opts:{ Build.default with opt; checks; dev }
            ~csrcs:l.Load.csrcs ~lflags:l.Load.lflags p ~out:exe);
  exe

(* No Str, and the reader is hand-written for the same reason. *)
let contains hay needle =
  let n = String.length needle and h = String.length hay in
  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
  go 0

let () =
  match Sys.command "command -v clang > /dev/null 2>&1" with
  | 0 ->
    let exe = compile "../calc-me.flan" in

    let case name arg expected_out expected_code =
      let code, text = run exe arg in
      if text <> expected_out || code <> expected_code then begin
        incr failures;
        Printf.printf
          "FAIL  %s\n        got: %S (exit %d)\n     wanted: %S (exit %d)\n"
          name text code expected_out expected_code
      end
    in
    let evaluates src expected = case src (Some src) (expected ^ "\n") 0 in
    let rejects src = case src (Some src) "calc-me: cannot parse\n" 1 in

    (* Arithmetic and precedence *)
    evaluates "1 + 2 * (3 - 0.5) / 2" "3.5";
    evaluates "1+2*3"                 "7";
    evaluates "2*3+4"                 "10";
    evaluates "(1+2)*3"               "9";
    evaluates "10/4"                  "2.5";
    evaluates "7"                     "7";
    evaluates "  7  "                 "7";
    evaluates "1.5+2.25"              "3.75";

    (* Left-associative: 1-2-3 is (1-2)-3, not 1-(2-3) *)
    evaluates "1-2-3"                 "-4";
    evaluates "8/4/2"                 "1";

    (* Unary minus, including nested *)
    evaluates "-5"                    "-5";
    evaluates "-(1+2)"                "-3";
    evaluates "3 * -2"                "-6";

    (* Whole input or nothing: trailing junk is an error, not ignored *)
    rejects "1 +";
    rejects "(1+2";
    rejects "1 2";
    rejects "";
    rejects "+";
    rejects "1+2)";

    case "no argument" None "usage: calc-me \"1 + 2 * 3\"\n" 1;
    (try Sys.remove exe with Sys_error _ -> ());

    (* Programs whose whole output is fixed. These cover the milestone-2
       surface calc-me does not reach — globals, 2-D arrays, places through a
       pointer, casts, match with either arm taken, and the value semantics of
       spec-memory.md. *)
    let outputs ?opt ?dev name path expected =
      let exe = compile ?opt ?dev path in
      let code, text = run exe None in
      if text <> expected || code <> 0 then begin
        incr failures;
        Printf.printf
          "FAIL  %s\n        got: %S (exit %d)\n     wanted: %S (exit 0)\n"
          name text code expected
      end;
      (try Sys.remove exe with Sys_error _ -> ())
    in
    let values_out = "1\n5\nel\n" in
    let machine_out = "12\n30\n2\n2\n3\n3.5\n42\n99\n12\n123\n" in
    outputs "value semantics" "programs/values.flan" values_out;
    outputs "machine surface" "programs/machine.flan" machine_out;
    outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";

    (* The raylib FFI, headless. GetColor and the enums need no window, so the
       whole boundary is exercised without a display: a struct returned through
       an out-pointer, a keyword resolved against an enum, and a Flan string
       crossing as ptr+len. 0x11223344 comes back as four separate bytes, which
       is the check that matters — a Color is not the little-endian reading of
       the packed integer, so an identity would pass a weaker test. *)
    if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then
      outputs "raylib ffi, headless" "programs/raylib-ffi.flan" "17\n34\n51\n68\n"
    else
      print_endline "acceptance: skipping the raylib FFI case (no libraylib)";

    (* Again at -O0. Everything above runs through mem2reg, which launders a
       sloppy alloca; -O0 tests the IR actually emitted, so a disagreement
       between the two points at undefined behaviour rather than a typo. *)
    (* sand.flan's simulation, headless. This is the milestone-4 acceptance
       case: N frames from a seeded PRNG, one hash. It imports the sim package
       and not raylib, deliberately — a program that imports raylib links
       libraylib on every target, and this one is the version meant to run on
       wasm32 too. The hash is reproducible only because rand-f32 is ours. *)
    let sand_out = "2256461126764447066\n" in
    outputs "sand, headless" "programs/sand-headless.flan" sand_out;
    outputs ~opt:"-O0" "sand, headless, -O0" "programs/sand-headless.flan" sand_out;

    outputs ~opt:"-O0" "value semantics, -O0" "programs/values.flan" values_out;
    outputs ~opt:"-O0" "machine surface, -O0" "programs/machine.flan" machine_out;

    (* And once more as a dev build. Every call in one goes through a cell, so
       this is the same table asserting the indirection changes nothing before
       anything has been redefined — the sand hash especially, since it is the
       one result that would notice a call reaching the wrong function. *)
    outputs ~dev:true "sand, headless, dev" "programs/sand-headless.flan" sand_out;
    outputs ~dev:true "value semantics, dev" "programs/values.flan" values_out;
    outputs ~dev:true "machine surface, dev" "programs/machine.flan" machine_out;

    (* Bounds checks, NEXT.md item 2. A trap has no result — it has a nonzero
       exit and a message on stderr — so it needs a case shape the table above
       does not have. What is asserted is the *reason*: the location, and which
       index against which length. The line and column are not pinned, because
       editing the program should not break the test that reads it. *)
    let bounds ?opt () =
      let exe = compile ?opt "programs/bounds.flan" in
      let traps name arg reason =
        let code, text = run exe (Some arg) in
        if code <> 134
           || not (contains text "programs/bounds.flan:")
           || not (contains text reason)
        then begin
          incr failures;
          Printf.printf
            "FAIL  %s\n        got: %S (exit %d)\n     wanted: %S (exit 134)\n"
            name text code reason
        end
      in
      (* Both edges are in bounds and must not trap: the last index of a fixed
         array, a slice ending exactly at len, and an empty slice at len. *)
      let code, text = run exe (Some "0") in
      if text <> "0ello\n" || code <> 0 then begin
        incr failures;
        Printf.printf "FAIL  in-bounds edges\n        got: %S (exit %d)\n" text code
      end;
      traps "at past a fixed array" "3"
        "index 3 is out of bounds for length 3";
      (* Negative indices sext to a huge unsigned, so the one unsigned
         comparison catches them; the message still reports the signed value. *)
      traps "at with a negative index" "-1"
        "index -1 is out of bounds for length 3";
      traps "at past a slice" "9"
        "index 9 is out of bounds for length 5";
      (* A different lowering — place/Pindex, not At — so it is its own case. *)
      traps "set past a fixed array" "7"
        "index 7 is out of bounds for length 3";
      traps "slice with hi past len" "4"
        "slice [4 9) is out of bounds for length 5";
      (* Without the lo <= hi test this one would not trap: it would build a
         slice of length hi - lo as a huge unsigned, which is worse. *)
      traps "slice with a reversed range" "2"
        "slice [2 1) is out of bounds for length 5";
      (try Sys.remove exe with Sys_error _ -> ())
    in
    bounds ();
    bounds ~opt:"-O0" ();

    (* The release build drops them — the calls, that is; the two declarations
       stay in the header and LLVM discards the unused ones. Asserted on the IR
       rather than by running an unchecked out-of-bounds program, which has no
       defined behaviour to assert on. *)
    let p =
      Reader.read_file "programs/bounds.flan" |> Parse.program |> Check.program
    in
    if not (contains (Emit.program p) "call void @flan_bounds_fail(") then begin
      incr failures;
      print_endline "FAIL  checks on: no bounds call emitted"
    end;
    let off = Emit.program ~checks:false p in
    if contains off "call void @flan_bounds_fail(" || contains off "call void @flan_slice_fail(" then begin
      incr failures;
      print_endline "FAIL  --no-bounds-checks: a check survived"
    end;

    if !failures = 0 then print_endline "acceptance: all tests passed"
    else begin
      Printf.printf "\n%d failure(s)\n" !failures;
      exit 1
    end
  | _ -> print_endline "acceptance: skipped (no clang on PATH)"