From df19b7aeabdb60990b98c3ebb04e5d0afbe0e10c Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Fri, 15 Aug 2014 20:00:40 +0200 Subject: [PATCH] PR#3959 (exit on bad #use in ocaml scripts): a preliminary patch With this change, the failure of a directive will abort a script if it is not run in interactive mode. Consider for example the file test.ml: #use "!!";; print_endline "hello";; then `ocaml test.ml` will stop after the erroneous #use directive, while using `#use "test.ml";;` from a running toplevel, or `ocaml -init test.ml`, will continue the script and print "hello". The implementation is preliminary: it is minimally invasive, but it probably makes sense to take this as an opportunity to factorize error-handling and error-reporting amongst toplevel directives. --- toplevel/topdirs.ml | 56 +++++++++++++++++++++++++++++++------------- toplevel/toploop.ml | 32 +++++++++++++++++-------- toplevel/toploop.mli | 4 ++++ 3 files changed, 66 insertions(+), 26 deletions(-) diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index d3387a3f1946..2f9b1145e796 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -163,11 +163,15 @@ and really_load_file recursive ppf name filename ic = end with Load_failed -> false -let dir_load ppf name = ignore (load_file false ppf name) +let dir_load ppf name = + if not (load_file false ppf name) + then raise Directive_failure let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) -let dir_load_rec ppf name = ignore (load_file true ppf name) +let dir_load_rec ppf name = + if not (load_file true ppf name) + then raise Directive_failure let _ = Hashtbl.add directive_table "load_rec" (Directive_string (dir_load_rec std_out)) @@ -176,8 +180,13 @@ let load_file = load_file false (* Load commands from a file *) -let dir_use ppf name = ignore(Toploop.use_file ppf name) -let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name) +let dir_use ppf name = + if not (Toploop.use_file ppf name) + then raise Directive_failure + +let dir_mod_use ppf name = + if not (Toploop.mod_use_file ppf name) + then raise Directive_failure let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) let _ = Hashtbl.add directive_table "mod_use" @@ -233,7 +242,7 @@ let dir_install_printer ppf lid = else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in install_printer path ty_arg print_function - with Exit -> () + with Exit -> raise Directive_failure let dir_remove_printer ppf lid = try @@ -241,9 +250,10 @@ let dir_remove_printer ppf lid = begin try remove_printer path with Not_found -> - fprintf ppf "No printer named %a.@." Printtyp.longident lid + fprintf ppf "No printer named %a.@." Printtyp.longident lid; + raise Exit end - with Exit -> () + with Exit -> raise Directive_failure let _ = Hashtbl.add directive_table "install_printer" (Directive_ident (dir_install_printer std_out)) @@ -265,7 +275,8 @@ let dir_trace ppf lid = match desc.val_kind with | Val_prim p -> fprintf ppf "%a is an external function and cannot be traced.@." - Printtyp.longident lid + Printtyp.longident lid; + raise Directive_failure | _ -> let clos = eval_path !toplevel_env path in (* Nothing to do if it's not a closure *) @@ -275,8 +286,9 @@ let dir_trace ppf lid = match is_traced clos with | Some opath -> fprintf ppf "%a is already traced (under the name %a).@." - Printtyp.path path - Printtyp.path opath + Printtyp.path path + Printtyp.path opath + (* we consider that this is not a failure of the directive *) | None -> (* Instrument the old closure *) traced_functions := @@ -290,9 +302,14 @@ let dir_trace ppf lid = to the instrumentation function *) set_code_pointer clos tracing_function_ptr; fprintf ppf "%a is now traced.@." Printtyp.longident lid - end else fprintf ppf "%a is not a function.@." Printtyp.longident lid + end else begin + fprintf ppf "%a is not a function.@." Printtyp.longident lid; + raise Directive_failure + end with - | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid + | Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + raise Directive_failure let dir_untrace ppf lid = try @@ -301,6 +318,7 @@ let dir_untrace ppf lid = | [] -> fprintf ppf "%a was not traced.@." Printtyp.longident lid; [] + (* we consider that this is not an error of the directive *) | f :: rem -> if Path.same f.path path then begin set_code_pointer f.closure f.actual_code; @@ -309,7 +327,9 @@ let dir_untrace ppf lid = end else f :: remove rem in traced_functions := remove !traced_functions with - | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid + | Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + raise Directive_failure let dir_untrace_all ppf () = List.iter @@ -321,7 +341,9 @@ let dir_untrace_all ppf () = let parse_warnings ppf iserr s = try Warnings.parse_options iserr s - with Arg.Bad err -> fprintf ppf "%s.@." err + with Arg.Bad err -> + fprintf ppf "%s.@." err; + raise Directive_failure (* Typing information *) @@ -362,8 +384,10 @@ let show_prim to_sig ppf lid = fprintf ppf "@[%a@]@." Printtyp.signature sg with | Not_found -> - fprintf ppf "@[Unknown element.@]@." - | Exit -> () + fprintf ppf "@[Unknown element.@]@."; + raise Directive_failure + | Exit -> + raise Directive_failure let all_show_funs = ref [] diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 482150a10aaa..1a0ae4537e9c 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -22,6 +22,10 @@ open Typedtree open Outcometree open Ast_helper +(* Toplevel directives may signal failure + by raising this exception *) +exception Directive_failure + type directive_fun = | Directive_none of (unit -> unit) | Directive_string of (string -> unit) @@ -293,16 +297,24 @@ let execute_phrase print_outcome ppf phr = fprintf ppf "Unknown directive `%s'.@." dir_name; false | Some d -> - match d, dir_arg with - | Directive_none f, Pdir_none -> f (); true - | Directive_string f, Pdir_string s -> f s; true - | Directive_int f, Pdir_int n -> f n; true - | Directive_ident f, Pdir_ident lid -> f lid; true - | Directive_bool f, Pdir_bool b -> f b; true - | _ -> - fprintf ppf "Wrong type of argument for directive `%s'.@." - dir_name; - false + try + begin match d, dir_arg with + | Directive_none f, Pdir_none -> f (); true + | Directive_string f, Pdir_string s -> f s; true + | Directive_int f, Pdir_int n -> f n; true + | Directive_ident f, Pdir_ident lid -> f lid; true + | Directive_bool f, Pdir_bool b -> f b; true + | _ -> + fprintf ppf "Wrong type of argument for directive `%s'.@." + dir_name; + false + end + with Directive_failure -> + (* PR#3959: if we are in interactive mode, we should + return `true` and let the user recover from the + failure; in non-interactive mode the script execution + should stop after this error *) + !Sys.interactive end diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index 5f0b86e26159..01ee534a77ee 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -33,6 +33,10 @@ val run_script : formatter -> string -> string array -> bool (* Interface with toplevel directives *) +(* Toplevel directives may signal failure + by raising this exception *) +exception Directive_failure + type directive_fun = | Directive_none of (unit -> unit) | Directive_string of (string -> unit)