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";
    (* handler-bind and signal, spec-conditions.md §1 and §2: signal returns
       Unit and carries on, an unhandled one is a no-op, a nested frame does
       not displace the one outside it, and the stack is restored after. *)
    let conditions_out = "0\n3\n23\n3\n1103\n1103\n" in
    outputs "conditions" "programs/conditions.flan" conditions_out;
    outputs ~opt:"-O0" "conditions, -O0" "programs/conditions.flan" conditions_out;
    outputs ~dev:true "conditions, dev" "programs/conditions.flan" conditions_out;
    (* restart-case and invoke-restart, §3 to §6: the transfer itself. A
       fall-through with nothing handling it, a clause reached from two frames
       down, the defer in between running on the way out, an inner frame
       shadowing an outer one of the same name, and a handler that returns
       normally still transferring nothing. At -O0 as well, because the guard
       after every call is control flow the optimiser would otherwise launder;
       and as a dev build, where every one of those calls goes through a cell. *)
    let restarts_out = "101\n1\n-1\n2\n7\n1010\n101\n105\n-2\n" in
    outputs "restarts" "programs/restarts.flan" restarts_out;
    outputs ~opt:"-O0" "restarts, -O0" "programs/restarts.flan" restarts_out;
    outputs ~dev:true "restarts, dev" "programs/restarts.flan" restarts_out;
    (* §2's other half, which cannot be an [outputs] case because it does not
       exit 0: a handler runs, returns normally, and has still not answered the
       error, so the program stops and names the condition. *)
    let exe = compile "programs/error.flan" in
    let code, text = run exe None in
    if code <> 134 || not (contains text "handler ran")
       || not (contains text "unhandled AssetMissing")
    then begin
      incr failures;
      Printf.printf
        "FAIL  an unhandled error stops the program\n\
        \        got: %S (exit %d)\n     wanted: exit 134, naming the condition\n"
        text code
    end;

    (* The raylib FFI, headless. GetColor, rectangle intersection and the
       shapes texture need no window, so the whole boundary is exercised
       without a display: a struct out of C through an out-pointer, a struct
       into C through a pointer, a keyword resolved against an enum, and a
       Flan string crossing as ptr+len.

       Every case is asymmetric, which is the point. 0x11223344 comes back as
       four separate bytes, so a Color is not the little-endian reading of the
       packed integer. The intersection of (0,0,10,4) and (6,1,10,10) is
       (6,1,4,3), four numbers from four different pairs of fields, so no
       permutation of Rectangle survives it. And the shapes texture is stored
       or replaced by 1 1 1 1 7 depending on which field is zero, which pins
       Texture2D's id and format. Handing raylib a struct and reading it back
       would have passed with any of those permuted — storing and returning is
       symmetric. What the last case cannot pin, because nothing raylib
       computes without a GL context reads them, is width, height and mipmaps
       against each other. *)
    let raylib_out =
      "17\n34\n51\n68\n\
       6\n1\n4\n3\n\
       7\n13\n17\n2\n4\n3.5\n7.25\n11.5\n13.75\n\
       1\n1\n1\n1\n7\n\
       7\n0\n17\n2\n4\n"
    in
    if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
      outputs "raylib ffi, headless" "programs/raylib-ffi.flan" raylib_out;
      (* And at -O0, for the reason the rest of the table is: every struct
         here crosses as (addr v) on a local, which is the alloca mem2reg
         would launder before anyone noticed it was wrong. *)
      outputs ~opt:"-O0" "raylib ffi, headless, -O0" "programs/raylib-ffi.flan"
        raylib_out
    end
    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)"