diff --git a/src/compiler/compiler.ml b/src/compiler/compiler.ml index a5376693b1f..e052416285a 100644 --- a/src/compiler/compiler.ml +++ b/src/compiler/compiler.ml @@ -447,7 +447,7 @@ with error com ("Error: No completion point was found") null_pos | DisplayException.DisplayException dex -> DisplayOutput.handle_display_exception com dex - | CompilerMessage.Abort | Out_of_memory | EvalTypes.Sys_exit _ | Hlinterp.Sys_exit _ | DisplayJson.JsonCompleted as exc -> + | CompilerMessage.Abort | Out_of_memory | EvalTypes.Sys_exit _ | Hlinterp.Sys_exit _ | DisplayJson.JsonCompleted | Globals.Cancelled as exc -> (* We don't want these to be caught by the catchall below *) raise exc | e when (try Sys.getenv "OCAMLRUNPARAM" <> "b" with _ -> true) && not Helper.is_debug_run -> diff --git a/src/compiler/displayProcessing.ml b/src/compiler/displayProcessing.ml index 14ac98308e1..3db6fbe1368 100644 --- a/src/compiler/displayProcessing.ml +++ b/src/compiler/displayProcessing.ml @@ -135,9 +135,8 @@ let load_display_module_in_macro tctx display_file_dot_path clear = match displa let _ = MacroContext.load_macro_module (MacroContext.get_macro_context tctx) tctx.com cpath true p in Finalization.finalize mctx; Some mctx - with DisplayException.DisplayException _ | Parser.TypePath _ | DisplayJson.JsonCompleted as exc -> - raise exc - | _ -> + with Error.Fatal_error _ | Error.Error _ | Failure _ | Not_found + | Lexer.Error _ | Parser.Error _ | Typecore.Forbid_package _ | Typecore.WithTypeError _ -> None end | None -> diff --git a/src/context/commonCache.ml b/src/context/commonCache.ml index bd758bb28f3..daaeaa7261f 100644 --- a/src/context/commonCache.ml +++ b/src/context/commonCache.ml @@ -15,7 +15,7 @@ class lib_build_task cs file ftime lib = object(self) try begin match lib#build path p with | Some r -> Hashtbl.add h path r | None -> () - end with _ -> + end with Error.Fatal_error _ | Error.Error _ | Failure _ | Not_found | Invalid_argument _ -> () end ) lib#list_modules; diff --git a/src/context/display/display.ml b/src/context/display/display.ml index 06a758e3c7d..1db9c9116ec 100644 --- a/src/context/display/display.ml +++ b/src/context/display/display.ml @@ -90,5 +90,5 @@ let get_import_status ctx path = try let mt' = ctx.g.do_load_type_def ctx null_pos (mk_type_path ([],snd path)) in if path <> (t_infos mt').mt_path then Shadowed else Imported - with _ -> + with Not_found | Error.Fatal_error _ | Error.Error _ | Failure _ -> Unimported diff --git a/src/context/display/displayFields.ml b/src/context/display/displayFields.ml index 36239494d02..4dd6d245fc0 100644 --- a/src/context/display/displayFields.ml +++ b/src/context/display/displayFields.ml @@ -381,7 +381,7 @@ let handle_missing_field_raise ctx tthis i mode with_type pfield = begin try let e = type_expr ctx e WithType.value in e.etype - with _ -> + with Error.Fatal_error _ | Error.Error _ | Typecore.Forbid_package _ | Typecore.WithTypeError _ | Failure _ -> mk_mono() end | _ -> mk_mono() @@ -393,7 +393,7 @@ let handle_missing_field_raise ctx tthis i mode with_type pfield = begin try let e = type_expr ctx e WithType.value in e.etype - with _ -> + with Error.Fatal_error _ | Error.Error _ | Typecore.Forbid_package _ | Typecore.WithTypeError _ | Failure _ -> raise Exit end | _ -> raise Exit @@ -410,7 +410,7 @@ let handle_missing_field_raise ctx tthis i mode with_type pfield = (name,false,e.etype) ) el in (TFun(tl,tret),Method MethNormal) - with _ -> + with Error.Fatal_error _ | Error.Error _ | Typecore.Forbid_package _ | Typecore.WithTypeError _ | Failure _ -> raise Exit end | MGet -> diff --git a/src/context/display/displayPath.ml b/src/context/display/displayPath.ml index 4026d17b393..7f4383c7f2e 100644 --- a/src/context/display/displayPath.ml +++ b/src/context/display/displayPath.ml @@ -155,7 +155,8 @@ module TypePathHandler = struct ) en.e_constrs fields in Some fields - with _ -> + with Error.Fatal_error _ | Error.Error _ | Failure _ | Not_found + | Lexer.Error _ | Parser.Error _ | Typecore.Forbid_package _ -> Error.abort ("Could not load module " ^ (s_type_path (p,c))) null_pos end diff --git a/src/context/display/displayToplevel.ml b/src/context/display/displayToplevel.ml index e87eaadaa60..baf53bfa105 100644 --- a/src/context/display/displayToplevel.ml +++ b/src/context/display/displayToplevel.ml @@ -49,7 +49,7 @@ let maybe_resolve_macro_field ctx t c cf = let (tl,tr,c,cf) = ctx.g.do_load_macro ctx false c.cl_path cf.cf_name null_pos in let t = perform_type_voodoo t tl tr in t,{cf with cf_type = t} - with _ -> + with Exit | Not_found | Error.Fatal_error _ | Error.Error _ | Failure _ -> t,cf let exclude : string list ref = ref [] @@ -157,7 +157,7 @@ let init_or_update_server cs com timer_name = try ignore(cc#find_file file_key); with Not_found -> - try ignore(TypeloadParse.parse_module_file com file_path null_pos) with _ -> () + try ignore(TypeloadParse.parse_module_file com file_path null_pos) with Lexer.Error _ | Parser.Error _ | Failure _ | Error.Error _ | Error.Fatal_error _ -> () ) removed_files; DynArray.iter (Hashtbl.remove removed_files) removed_removed_files diff --git a/src/context/display/syntaxExplorer.ml b/src/context/display/syntaxExplorer.ml index e490c2d7e17..fe38abadb1f 100644 --- a/src/context/display/syntaxExplorer.ml +++ b/src/context/display/syntaxExplorer.ml @@ -179,7 +179,8 @@ let explore_uncached_modules tctx cs symbols = (* We have to flush immediately so we catch exceptions from weird modules *) Typecore.flush_pass tctx.g PFinal ("final",cfile.c_package @ [module_name]); m :: acc - with _ -> + with Error.Fatal_error _ | Error.Error _ | Failure _ | Not_found + | Lexer.Error _ | Parser.Error _ | Typecore.Forbid_package _ | Typecore.WithTypeError _ -> acc end ) files [] diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 189654b8409..58cef0e0af9 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -102,7 +102,7 @@ let make_macro_com_api com mcom p = match ParserEntry.parse_string (ParserConfig.default_config com.defines) Grammar.parse_meta s null_pos raise_typing_error false with | ParseSuccess(meta,_) -> meta | ParseError(_,_,_) -> raise_typing_error "Malformed metadata string" p - with _ -> + with Lexer.Error _ | Failure _ -> raise_typing_error "Malformed metadata string" p in let bad_stage () = @@ -311,7 +311,7 @@ let make_macro_api ctx mctx p = match ParserEntry.parse_string (ParserConfig.default_config mctx.com.defines) Grammar.parse_meta s null_pos raise_typing_error false with | ParseSuccess(meta,_) -> meta | ParseError(_,_,_) -> raise_typing_error "Malformed metadata string" p - with _ -> + with Lexer.Error _ | Failure _ -> raise_typing_error "Malformed metadata string" p in let com_api = make_macro_com_api ctx.com mctx.com p in diff --git a/src/typing/typerDisplay.ml b/src/typing/typerDisplay.ml index 275985d0d52..557c61f600b 100644 --- a/src/typing/typerDisplay.ml +++ b/src/typing/typerDisplay.ml @@ -29,7 +29,7 @@ let completion_item_of_expr ctx e = try let e' = type_expr ctx (EConst(Ident s),null_pos) (WithType.with_type t) in Texpr.equal e e' - with _ -> + with Error.Fatal_error _ | Error.Error _ | Typecore.Forbid_package _ | Failure _ -> false in let tpair ?(values=PMap.empty) t = @@ -581,7 +581,7 @@ let filter_ctors ctx r = | _ -> false) | _ -> false end - with _ -> + with Not_found | Error.Fatal_error _ | Error.Error _ | Failure _ -> false end end