diff --git a/bin/main.ml b/bin/main.ml index 52ac753..5801d72 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -31,6 +31,31 @@ let with_errors path f = prerr_endline ("flan: " ^ m); ignore path; exit 1 + (* A file that is not there, or that cannot be read. The exception already + carries the path and the reason the operating system gave, which is the + whole of what anybody can act on, so it is passed through as it is — + [lib/dev.ml]'s [message_of_exn] does the same for the same reason, and + the daemon has had this arm since before the CLI did. Without it + [flan check nosuch.flan] ends in [Fatal error: exception Sys_error(...)], + which is the compiler telling the user it did not expect to be asked. *) + | Sys_error m -> + prerr_endline ("flan: " ^ m); + ignore path; + exit 1 + (* The backstop. Nothing in this binary reaches it today: every [Hashtbl.find] + on a path a command can take is guarded by a [find_opt]. It is here so + that the day one is not, the failure is a sentence naming the file being + worked on rather than a bare [Fatal error: exception Not_found] — which + says nothing at all, not even which file. Its own exit status, because a + compiler bug is not a refusal of the program and a script should be able + to tell the two apart. *) + | Not_found -> + prerr_endline + ("flan: internal error — a lookup failed with no name to report, while \ + working on " ^ path + ^ ". This is a bug in the compiler and not a fault in the program; \ + please report the file that provoked it."); + exit 4 let summarise (d : Flan.Ast.decl) = let open Flan.Ast in @@ -143,8 +168,43 @@ let flags = usage error. *) let target_prefix = "--target=" +(* The optimisation level, which until now had no spelling at all: [Build.default] + pinned -O2 and [--debug] was the only route to anything else. Four levels and + not five — -Os is clang's and llc rejects it outright ("invalid optimization + level"), and the same string reaches both ([Build] at the clang compile and + again at the llc step of the live loop), so offering a level one of the two + tools does not know would be a flag that works for [flan build] and breaks + [C-c C-c]. + + Last one wins, which is what every compiler does with a repeated -O and the + only rule that does not need explaining. *) +let opt_levels = [ "-O0"; "-O1"; "-O2"; "-O3" ] + +let opt_of args = + List.fold_left + (fun acc a -> if List.mem a opt_levels then Some a else acc) + None args + let is_flag a = - List.mem a flags || String.starts_with ~prefix:target_prefix a + List.mem a flags || List.mem a opt_levels + || String.starts_with ~prefix:target_prefix a + +(* [--debug] forces -O0 in [Build] and says why there: [llvm.dbg.declare] + describes an alloca and mem2reg deletes the alloca, so a debug build at -O2 + has a line table over code whose locals are gone. That is a good rule, and + it makes [--debug -O2] a request that cannot be honoured — so it is refused + here by name instead of being quietly overruled two modules away. *) +let check_opt_against_debug ~debug ~opt = + match (debug, opt) with + | true, Some o when o <> "-O0" -> + prerr_endline + ("flan: --debug and " ^ o + ^ " ask for opposite things — a debug build is -O0 because \ + llvm.dbg.declare describes an alloca and mem2reg at any higher level \ + deletes it, leaving a line table over locals that are not there. \ + Drop one of the two."); + exit 2 + | _ -> () let target_of args = List.find_map @@ -507,6 +567,8 @@ let () = let debug = List.mem debug_flag rest in let sanitize = List.mem sanitize_flag rest in let x86 = List.mem x86_flag rest in + let opt = opt_of rest in + check_opt_against_debug ~debug ~opt; let target = target_of rest in let out = match List.filter (fun a -> not (is_flag a)) rest with @@ -524,7 +586,8 @@ let () = | _ -> base) | _ -> prerr_endline - "usage: flan build [-o out] [--no-bounds-checks] \ + "usage: flan build [-o out] [-O0|-O1|-O2|-O3] \ + [--no-bounds-checks] \ [--dev] [--debug] [--sanitize] [--target=wasm32-wasi|web]"; exit 2 in @@ -538,7 +601,9 @@ let () = let p, csrcs, lflags = Flan.Reach.link ~dev l p in ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks; dev; debug; sanitize; - target; x86 } + target; x86; + opt = Option.value opt + ~default:Flan.Build.default.Flan.Build.opt } ~csrcs ~lflags ~pnames:(if debug then param_names l else []) p ~out)) (* The daemon an editor talks to: one session, the program it belongs to @@ -626,6 +691,48 @@ let () = this host can exec. Use flan build --target=... and a wasm runtime."; exit 2 | _ :: "run" :: path :: args -> + (* One command, two argument lists, and until now no rule saying which was + which: [flan run game.flan --debug] built at -O2 and handed the game a + [--debug] it had never heard of. Nothing reported that, because neither + side thought it had been given anything wrong. + + The rule, in one line: a build flag is the build's, [--] ends the build + flags, and everything after [--] is the program's whatever it looks + like. Before [--], an argument that starts with a dash and is not a + build flag this command offers is refused by name — not guessed at, + because guessing is the failure this exists to stop, and a program of + one's own that wants [-v] has [--] to ask for it. Plain arguments need + no ceremony: they were never ambiguous and they still go straight + through, so [flan run calc-me.flan "1+2"] is unchanged. *) + let run_flags = [ no_checks_flag; dev_flag; debug_flag; sanitize_flag; + x86_flag ] @ opt_levels in + let build_args, prog_args = + let rec split acc = function + | "--" :: rest -> (List.rev acc, rest) + | a :: rest when String.length a > 1 && a.[0] = '-' -> + if List.mem a run_flags then split (a :: acc) rest + else begin + prerr_endline + ("flan run: " ^ a + ^ " is not a flag this command offers, and it will not be \ + guessed at — a build flag belongs to the build and \ + anything else belongs to the program. Write it after -- to \ + send it to the program: flan run " + ^ Filename.basename path ^ " -- " ^ a); + exit 2 + end + | a :: rest -> let l, r = split acc rest in (l, a :: r) + | [] -> (List.rev acc, []) + in + split [] args + in + let checks = not (List.mem no_checks_flag build_args) in + let dev = List.mem dev_flag build_args in + let debug = List.mem debug_flag build_args in + let sanitize = List.mem sanitize_flag build_args in + let x86 = List.mem x86_flag build_args in + let opt = opt_of build_args in + check_opt_against_debug ~debug ~opt; with_errors path (fun () -> let exe = Filename.concat (Filename.get_temp_dir_name ()) @@ -633,10 +740,17 @@ let () = in let l = load path in let p = Flan.Check.program_all l.decls in - let p, csrcs, lflags = Flan.Reach.link l p in - ignore (Flan.Build.executable ~csrcs ~lflags p ~out:exe); + let p, csrcs, lflags = Flan.Reach.link ~dev l p in + ignore (Flan.Build.executable + ~opts:{ Flan.Build.default with checks; dev; debug; sanitize; + x86; + opt = Option.value opt + ~default:Flan.Build.default.Flan.Build.opt } + ~csrcs ~lflags ~pnames:(if debug then param_names l else []) + p ~out:exe); let code = - Sys.command (String.concat " " (List.map Filename.quote (exe :: args))) + Sys.command + (String.concat " " (List.map Filename.quote (exe :: prog_args))) in (try Sys.remove exe with Sys_error _ -> ()); exit code) @@ -645,9 +759,10 @@ let () = "usage: flan (read|parse|check|emit|shim) ...\n flan emit [--x86] [--dev] [--debug] [--no-bounds-checks]\n\ \ flan import-c [package.flan...] [clang flags...]\n\ \ flan generate-c \n\ - \ flan build [-o out] [--no-bounds-checks] [--dev] \ + \ flan build [-o out] [-O0|-O1|-O2|-O3] \ + [--no-bounds-checks] [--dev] \ [--debug] [--sanitize] [--x86] [--target=wasm32-wasi|web]\n\ - \ flan run [args...]\n\ + \ flan run [build flags...] [--] [program args...]\n\ \ flan reload [-o out.so] [--x86]\n\ \ flan dev [-s socket] [--x86]"; exit 2 diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index a99ab31..120c833 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3670,6 +3670,71 @@ ERR@7 unexpected token: not the kind the caller was reading outputs ~opt:"-O0" "utf-8, splitting and ascii case, -O0" "programs/utf8.flan" utf8_out; + (* ── The driver's own refusals ───────────────────────────────────── + + Not about compiled code at all: about what the CLI does when it is + handed something it cannot do. Each of these was an escape before — + an OCaml exception printed by the default handler, or a build flag + silently forwarded to the program — and each is pinned here because + "it prints a sentence" is exactly the kind of claim that rots without + a test to hold it. *) + let cli args = + let out = Filename.concat scratch "flan-cli.out" in + let code = + Sys.command + (Printf.sprintf "../bin/main.exe %s > %s 2>&1" args (Filename.quote out)) + in + let text = In_channel.with_open_bin out In_channel.input_all in + (try Sys.remove out with Sys_error _ -> ()); + (code, text) + in + let cli_case name args ~code:want_code ~says = + let code, text = cli args in + let bad = + code <> want_code + || List.exists (fun n -> not (contains text n)) says + (* The point of half of these: no arm here may end in OCaml's default + handler, whatever else it does. *) + || contains text "Fatal error" + in + if bad then begin + incr failures; + Printf.printf "FAIL %s\n got: %S (exit %d)\n wanted exit %d with %s\n" + name text code want_code (String.concat ", " says) + end + in + (* A path that is not there. This used to be + [Fatal error: exception Sys_error("...")] — the compiler reporting that + it had not expected to be asked. *) + cli_case "check on a file that is not there" + "check no-such-file.flan" ~code:1 + ~says:[ "no-such-file.flan"; "No such file or directory" ]; + (* And every other front end takes the same route, since the arm is on the + one wrapper they all go through. *) + cli_case "build on a file that is not there" + "build no-such-file.flan -o /dev/null" ~code:1 + ~says:[ "no-such-file.flan" ]; + (* [flan run] and its two argument lists. -O0 is the build's, so calc-me + never sees it and answers the expression that follows; before the split + it was handed "-O0" as the expression and said it could not parse it. *) + cli_case "run keeps a build flag out of the program's argv" + "run ../calc-me.flan -O0 '1+2'" ~code:0 ~says:[ "3" ]; + (* -- hands the rest over whatever it looks like, which is what makes the + refusal below affordable. *) + cli_case "run passes everything after -- to the program" + "run ../calc-me.flan -O0 -- '3*4'" ~code:0 ~says:[ "12" ]; + (* And an unknown dash argument is refused by name rather than guessed at + in either direction. *) + cli_case "run refuses a flag it does not offer" + "run ../calc-me.flan --lint" ~code:2 + ~says:[ "--lint"; "will not be guessed at"; "--" ]; + (* The one pair of flags that cannot both be honoured: --debug is -O0 in + [Build] and says why, so asking for it alongside a higher level is a + request with two answers. *) + cli_case "--debug and an explicit -O are refused together" + "build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2 + ~says:[ "--debug"; "-O2"; "Drop one of the two" ]; + if !failures = 0 then print_endline "acceptance: all tests passed" else begin Printf.printf "\n%d failure(s)\n" !failures;