Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Integrate exception_registration banch. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14152 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-09-17 09:30:41 +00:00
parent d9a035fa65 b92a3ca792
commit 2691cf5042
43 changed files with 396 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
asmcomp/asmgen.ml
View File

@ -140,3 +140,10 @@ let report_error ppf = function
| Assembler_error file ->
fprintf ppf "Assembler error, input left in file %a"
Location.print_filename file
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

7
asmcomp/asmlibrarian.ml
View File

@ -69,3 +69,10 @@ let report_error ppf = function
fprintf ppf "Cannot find file %s" name
| Archiver_error name ->
fprintf ppf "Error while creating the library %s" name
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

7
asmcomp/asmlink.ml
View File

@ -390,3 +390,10 @@ let report_error ppf = function
Location.print_filename filename name
Location.print_filename filename
name
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

7
asmcomp/asmpackager.ml
View File

@ -204,3 +204,10 @@ let report_error ppf = function
fprintf ppf "Error while assembling %s" file
| Linking_error ->
fprintf ppf "Error during partial linking"
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

7
asmcomp/compilenv.ml
View File

@ -245,3 +245,10 @@ let report_error ppf = function
fprintf ppf "%a@ contains the description for unit\
@ %s when %s was expected"
Location.print_filename filename name modname
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

7
bytecomp/bytelibrarian.ml
View File

@ -117,3 +117,10 @@ let report_error ppf = function
| Not_an_object_file name ->
fprintf ppf "The file %a is not a bytecode object file"
Location.print_filename name
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

7
bytecomp/bytelink.ml
View File

@ -622,3 +622,10 @@ let report_error ppf = function
| Not_compatible_32 ->
fprintf ppf "Generated bytecode executable cannot be run\
\ on a 32-bit platform"
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

7
bytecomp/bytepackager.ml
View File

@ -276,3 +276,10 @@ let report_error ppf = function
Location.print_filename file name id
| File_not_found file ->
fprintf ppf "File %s not found" file
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

7
bytecomp/symtable.ml
View File

@ -372,3 +372,10 @@ let report_error ppf = function
fprintf ppf "Cannot find or execute the runtime system %s" s
| Uninitialized_global s ->
fprintf ppf "The value of the global `%s' is not yet computed" s
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

9
bytecomp/translclass.ml
View File

@ -826,3 +826,12 @@ let report_error ppf = function
| Tags (lab1, lab2) ->
fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
lab1 lab2 "Change one of them."
let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
| _ ->
None
)

9
bytecomp/translcore.ml
View File

@ -1120,3 +1120,12 @@ let report_error ppf = function
"Ancestor names can only be used to select inherited methods"
| Unknown_builtin_primitive prim_name ->
fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
| _ ->
None
)

9
bytecomp/translmod.ml
View File

@ -810,3 +810,12 @@ let report_error ppf = function
"@[Cannot safely evaluate the definition@ \
of the recursively-defined module %a@]"
Printtyp.ident id
let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
| _ ->
None
)

71
driver/errors.ml
View File

@ -10,72 +10,7 @@
(* *)
(***********************************************************************)
(* WARNING: if you change something in this file, you must look at
opterrors.ml and ocamldoc/odoc_analyse.ml
to see if you need to make the same changes there.
*)
(* This module should be removed. We keep it for now, to avoid
breaking external tools depending on it. *)
open Format
(* Report an error *)
let report_error ppf exn =
let report ppf = function
| Lexer.Error(err, loc) ->
Location.print_error ppf loc;
Lexer.report_error ppf err
| Syntaxerr.Error err ->
Syntaxerr.report_error ppf err
| Pparse.Error err ->
Pparse.report_error ppf err
| Env.Error err ->
Location.print_error_cur_file ppf;
Env.report_error ppf err
| Cmi_format.Error err ->
Location.print_error_cur_file ppf;
Cmi_format.report_error ppf err
| Ctype.Tags(l, l') ->
Location.print_error_cur_file ppf;
fprintf ppf
"In this program,@ variant constructors@ `%s and `%s@ \
have the same hash value.@ Change one of them." l l'
| Typecore.Error(loc, env, err) ->
Location.print_error ppf loc; Typecore.report_error env ppf err
| Typetexp.Error(loc, env, err) ->
Location.print_error ppf loc; Typetexp.report_error env ppf err
| Typedecl.Error(loc, err) ->
Location.print_error ppf loc; Typedecl.report_error ppf err
| Typeclass.Error(loc, env, err) ->
Location.print_error ppf loc; Typeclass.report_error env ppf err
| Includemod.Error err ->
Location.print_error_cur_file ppf;
Includemod.report_error ppf err
| Typemod.Error(loc, env, err) ->
Location.print_error ppf loc; Typemod.report_error env ppf err
| Translcore.Error(loc, err) ->
Location.print_error ppf loc; Translcore.report_error ppf err
| Translclass.Error(loc, err) ->
Location.print_error ppf loc; Translclass.report_error ppf err
| Translmod.Error(loc, err) ->
Location.print_error ppf loc; Translmod.report_error ppf err
| Symtable.Error code ->
Location.print_error_cur_file ppf;
Symtable.report_error ppf code
| Bytelink.Error code ->
Location.print_error_cur_file ppf;
Bytelink.report_error ppf code
| Bytelibrarian.Error code ->
Location.print_error_cur_file ppf;
Bytelibrarian.report_error ppf code
| Bytepackager.Error code ->
Location.print_error_cur_file ppf;
Bytepackager.report_error ppf code
| Sys_error msg ->
Location.print_error_cur_file ppf;
fprintf ppf "I/O error: %s" msg
| Warnings.Errors (n) ->
Location.print_error_cur_file ppf;
fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
| x -> fprintf ppf "@]"; raise x in
fprintf ppf "@[%a@]@." report exn
let report_error = Location.report_exception

2
driver/main.ml
View File

@ -184,7 +184,7 @@ let main () =
end;
exit 0
with x ->
Errors.report_error ppf x;
Location.report_exception ppf x;
exit 2
let _ = main ()

73
driver/opterrors.ml
View File

@ -10,74 +10,7 @@
(* *)
(***********************************************************************)
(* WARNING: if you change something in this file, you must look at
errors.ml to see if you need to make the same changes there.
*)
(* This module should be removed. We keep it for now, to avoid
breaking external tools depending on it. *)
open Format
(* Report an error *)
let report_error ppf exn =
let report ppf = function
| Lexer.Error(err, l) ->
Location.print_error ppf l;
Lexer.report_error ppf err
| Syntaxerr.Error err ->
Syntaxerr.report_error ppf err
| Pparse.Error err ->
Pparse.report_error ppf err
| Env.Error err ->
Location.print_error_cur_file ppf;
Env.report_error ppf err
| Cmi_format.Error err ->
Location.print_error_cur_file ppf;
Cmi_format.report_error ppf err
| Ctype.Tags(l, l') ->
Location.print_error_cur_file ppf;
fprintf ppf
"In this program,@ variant constructors@ `%s and `%s@ \
have the same hash value.@ Change one of them." l l'
| Typecore.Error(loc, env, err) ->
Location.print_error ppf loc; Typecore.report_error env ppf err
| Typetexp.Error(loc, env, err) ->
Location.print_error ppf loc; Typetexp.report_error env ppf err
| Typedecl.Error(loc, err) ->
Location.print_error ppf loc; Typedecl.report_error ppf err
| Typeclass.Error(loc, env, err) ->
Location.print_error ppf loc; Typeclass.report_error env ppf err
| Includemod.Error err ->
Location.print_error_cur_file ppf;
Includemod.report_error ppf err
| Typemod.Error(loc, env, err) ->
Location.print_error ppf loc; Typemod.report_error env ppf err
| Translcore.Error(loc, err) ->
Location.print_error ppf loc; Translcore.report_error ppf err
| Translclass.Error(loc, err) ->
Location.print_error ppf loc; Translclass.report_error ppf err
| Translmod.Error(loc, err) ->
Location.print_error ppf loc; Translmod.report_error ppf err
| Compilenv.Error code ->
Location.print_error_cur_file ppf;
Compilenv.report_error ppf code
| Asmgen.Error code ->
Location.print_error_cur_file ppf;
Asmgen.report_error ppf code
| Asmlink.Error code ->
Location.print_error_cur_file ppf;
Asmlink.report_error ppf code
| Asmlibrarian.Error code ->
Location.print_error_cur_file ppf;
Asmlibrarian.report_error ppf code
| Asmpackager.Error code ->
Location.print_error_cur_file ppf;
Asmpackager.report_error ppf code
| Sys_error msg ->
Location.print_error_cur_file ppf;
fprintf ppf "I/O error: %s" msg
| Warnings.Errors (n) ->
Location.print_error_cur_file ppf;
fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
| x -> fprintf ppf "@]"; raise x in
fprintf ppf "@[%a@]@." report exn
let report_error = Location.report_exception

4
driver/optmain.ml
View File

@ -201,7 +201,7 @@ let main () =
end;
exit 0
with x ->
Opterrors.report_error ppf x;
exit 2
Location.report_exception ppf x;
exit 2
let _ = main ()

9
driver/pparse.ml
View File

@ -59,7 +59,8 @@ let apply_rewriter magic fn_in ppx =
Misc.remove_file fn_out;
raise (Error (CannotRun comm));
end;
if not (Sys.file_exists fn_out) then raise (Error (WrongMagic comm));
if not (Sys.file_exists fn_out) then
raise (Error (WrongMagic comm));
(* check magic before passing to the next ppx *)
let ic = open_in_bin fn_out in
let buffer =
@ -143,6 +144,12 @@ let report_error ppf = function
fprintf ppf "External preprocessor does not produce a valid file@.\
Command line: %s@." cmd
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)
let parse_all parse_fun magic ppf sourcefile =
Location.input_name := sourcefile;

62
ocamldoc/odoc_analyse.ml
View File

@ -100,60 +100,16 @@ module Ast_analyser = Odoc_ast.Analyser (Odoc_comments.Basic_info_retriever)
(** The module used to analyse the parse tree and typed tree of an interface file.*)
module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever)
(** Handle an error. This is a partial copy of the compiler
driver/error.ml file. We do this because there are
some differences between the possibly raised exceptions
in the bytecode (error.ml) and opt (opterros.ml) compilers
and we don't want to take care of this. Besises, these
differences only concern code generation (i believe).*)
(** Handle an error. *)
let process_error exn =
let report ppf = function
| Lexer.Error(err, loc) ->
Location.print_error ppf loc;
Lexer.report_error ppf err
| Syntaxerr.Error err ->
Syntaxerr.report_error ppf err
| Env.Error err ->
Location.print_error_cur_file ppf;
Env.report_error ppf err
| Cmi_format.Error err ->
Location.print_error_cur_file ppf;
Cmi_format.report_error ppf err
| Ctype.Tags(l, l') ->
Location.print_error_cur_file ppf;
fprintf ppf
"In this program,@ variant constructors@ `%s and `%s@ \
have the same hash value." l l'
| Typecore.Error(loc, env, err) ->
Location.print_error ppf loc; Typecore.report_error env ppf err
| Typetexp.Error(loc, env, err) ->
Location.print_error ppf loc; Typetexp.report_error env ppf err
| Typedecl.Error(loc, err) ->
Location.print_error ppf loc; Typedecl.report_error ppf err
| Includemod.Error err ->
Location.print_error_cur_file ppf;
Includemod.report_error ppf err
| Typemod.Error(loc, env, err) ->
Location.print_error ppf loc; Typemod.report_error env ppf err
| Translcore.Error(loc, err) ->
Location.print_error ppf loc; Translcore.report_error ppf err
| Sys_error msg ->
Location.print_error_cur_file ppf;
fprintf ppf "I/O error: %s" msg
| Typeclass.Error(loc, env, err) ->
Location.print_error ppf loc; Typeclass.report_error env ppf err
| Translclass.Error(loc, err) ->
Location.print_error ppf loc; Translclass.report_error ppf err
| Warnings.Errors (n) ->
Location.print_error_cur_file ppf;
fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n
| x ->
fprintf ppf "@]";
fprintf ppf
"Compilation error(%s). Use the OCaml compiler to get more details."
(Printexc.to_string x)
in
Format.fprintf Format.err_formatter "@[%a@]@." report exn
match Location.error_of_exn exn with
| Some err ->
fprintf Format.err_formatter "@[%a@]@." Location.report_error err
| None ->
fprintf Format.err_formatter
"Compilation error(%s). Use the OCaml compiler to get more details.@."
(Printexc.to_string exn)
(** Process the given file, according to its extension. Return the Module.t created, if any.*)
let process_file ppf sourcefile =

1
parsing/lexer.mli
View File

@ -31,6 +31,7 @@ exception Error of error * Location.t
open Format
val report_error: formatter -> error -> unit
(* Deprecated. Use Location.{error_of_exn, report_error}. *)
val in_comment : unit -> bool;;
val in_string : unit -> bool;;

10
parsing/lexer.mll
View File

@ -242,7 +242,15 @@ let report_error ppf = function
| Literal_overflow ty ->
fprintf ppf "Integer literal exceeds the range of representable \
integers of type %s" ty
;;
let () =
Location.register_error_of_exn
(function
| Error (err, loc) ->
Some (Location.error_of_printer loc report_error err)
| _ ->
None
)
}

96
parsing/location.ml
View File

@ -74,7 +74,7 @@ let num_loc_lines = ref 0 (* number of lines already printed after input *)
(* Highlight the locations using standout mode. *)
let highlight_terminfo ppf num_lines lb loc1 loc2 =
let highlight_terminfo ppf num_lines lb locs =
Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *)
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
let pos0 = -lb.lex_abs_pos in
@ -94,9 +94,9 @@ let highlight_terminfo ppf num_lines lb loc1 loc2 =
print_string "# ";
for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
if !bol then (print_string " "; bol := false);
if pos = loc1.loc_start.pos_cnum || pos = loc2.loc_start.pos_cnum then
if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
Terminfo.standout true;
if pos = loc1.loc_end.pos_cnum || pos = loc2.loc_end.pos_cnum then
if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
Terminfo.standout false;
let c = lb.lex_buffer.[pos + pos0] in
print_char c;
@ -176,10 +176,10 @@ let highlight_dumb ppf lb loc =
(* Highlight the location using one of the supported modes. *)
let rec highlight_locations ppf loc1 loc2 =
let rec highlight_locations ppf locs =
match !status with
Terminfo.Uninitialised ->
status := Terminfo.setup stdout; highlight_locations ppf loc1 loc2
status := Terminfo.setup stdout; highlight_locations ppf locs
| Terminfo.Bad_term ->
begin match !input_lexbuf with
None -> false
@ -187,6 +187,7 @@ let rec highlight_locations ppf loc1 loc2 =
let norepeat =
try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
if norepeat then false else
let loc1 = List.hd locs in
try highlight_dumb ppf lb loc1; true
with Exit -> false
end
@ -194,7 +195,7 @@ let rec highlight_locations ppf loc1 loc2 =
begin match !input_lexbuf with
None -> false
| Some lb ->
try highlight_terminfo ppf num_lines lb loc1 loc2; true
try highlight_terminfo ppf num_lines lb locs; true
with Exit -> false
end
@ -237,7 +238,7 @@ let print_loc ppf loc =
let (file, line, startchar) = get_pos_info loc.loc_start in
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
if file = "//toplevel//" then begin
if highlight_locations ppf loc none then () else
if highlight_locations ppf [loc] then () else
fprintf ppf "Characters %i-%i"
loc.loc_start.pos_cnum loc.loc_end.pos_cnum
end else begin
@ -249,7 +250,7 @@ let print_loc ppf loc =
let print ppf loc =
if loc.loc_start.pos_fname = "//toplevel//"
&& highlight_locations ppf loc none then ()
&& highlight_locations ppf [loc] then ()
else fprintf ppf "%a%s@." print_loc loc msg_colon
;;
@ -286,3 +287,82 @@ type 'a loc = {
let mkloc txt loc = { txt ; loc }
let mknoloc txt = mkloc txt none
type error =
{
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
Printf.ksprintf (fun msg -> {loc; msg; sub; if_highlight})
let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg =
{loc; msg; sub; if_highlight}
let error_of_exn : (exn -> error option) list ref = ref []
let register_error_of_exn f = error_of_exn := f :: !error_of_exn
let error_of_exn exn =
let rec loop = function
| [] -> None
| f :: rest ->
match f exn with
| Some _ as r -> r
| None -> loop rest
in
loop !error_of_exn
let rec report_error ppf ({loc; msg; sub; if_highlight} as err) =
let highlighted =
if if_highlight <> "" then
let rec collect_locs locs {loc; sub; if_highlight; _} =
List.fold_left collect_locs (loc :: locs) sub
in
let locs = collect_locs [] err in
highlight_locations ppf locs
else
false
in
if highlighted then
Format.pp_print_string ppf if_highlight
else begin
print ppf loc;
Format.pp_print_string ppf msg;
List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub
end
let error_of_printer loc print x =
let buf = Buffer.create 64 in
let ppf = Format.formatter_of_buffer buf in
pp_print_string ppf "Error: ";
print ppf x;
pp_print_flush ppf ();
let msg = Buffer.contents buf in
errorf ~loc "%s" msg
let error_of_printer_file print x =
error_of_printer (in_file !input_name) print x
let () =
register_error_of_exn
(function
| Sys_error msg ->
Some (errorf ~loc:(in_file !input_name) "Error: I/O error: %s" msg)
| Warnings.Errors n ->
Some
(errorf ~loc:(in_file !input_name)
"Error: Some fatal warnings were triggered (%d occurrences)" n)
| _ ->
None
)
let report_exception ppf exn =
match error_of_exn exn with
| Some err -> fprintf ppf "@[%a@]@." report_error err
| None -> raise exn

36
parsing/location.mli
View File

@ -56,7 +56,7 @@ val prerr_warning: t -> Warnings.t -> unit
val echo_eof: unit -> unit
val reset: unit -> unit
val highlight_locations: formatter -> t -> t -> bool
val highlight_locations: formatter -> t list -> bool
type 'a loc = {
txt : 'a;
@ -75,3 +75,37 @@ val show_filename: string -> string
val absname: bool ref
(* Support for located errors *)
type error =
{
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string -> ('a, unit, string, error) format4 -> 'a
val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error
val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
val error_of_exn: exn -> error option
val register_error_of_exn: (exn -> error option) -> unit
(* Each compiler module which defines a custom type of exception
which can surface as a user-visible error should register
a "printer" for this exception using [register_error_of_exn].
The result of the printer is an [error] value containing
a location, a message, and optionally sub-messages (each of them
being located as well). *)
val report_error: formatter -> error -> unit
val report_exception: formatter -> exn -> unit
(* Reraise the exception if it is unknown. *)

72
parsing/syntaxerr.ml
View File

@ -12,8 +12,6 @@
(* Auxiliary type for reporting syntax errors *)
open Format
type error =
Unclosed of Location.t * string * Location.t * string
| Expecting of Location.t * string
@ -22,44 +20,48 @@ type error =
| Variable_in_scope of Location.t * string
| Other of Location.t
exception Error of error
exception Escape_error
let report_error ppf = function
let prepare_error = function
| Unclosed(opening_loc, opening, closing_loc, closing) ->
if !Location.input_name = "//toplevel//"
&& Location.highlight_locations ppf opening_loc closing_loc
then fprintf ppf "Syntax error: '%s' expected, \
the highlighted '%s' might be unmatched" closing opening
else begin
fprintf ppf "%aSyntax error: '%s' expected@."
Location.print_error closing_loc closing;
fprintf ppf "%aThis '%s' might be unmatched"
Location.print_error opening_loc opening
end
| Expecting (loc, nonterm) ->
fprintf ppf
"%a@[Syntax error: %s expected.@]"
Location.print_error loc nonterm
| Not_expecting (loc, nonterm) ->
fprintf ppf
"%a@[Syntax error: %s not expected.@]"
Location.print_error loc nonterm
| Applicative_path loc ->
fprintf ppf
"%aSyntax error: applicative paths of the form F(X).t \
are not supported when the option -no-app-func is set."
Location.print_error loc
| Variable_in_scope (loc, var) ->
fprintf ppf
"%a@[In this scoped type, variable '%s@ \
is reserved for the local type %s.@]"
Location.print_error loc var var
| Other loc ->
fprintf ppf "%aSyntax error" Location.print_error loc
Location.errorf ~loc:closing_loc
~sub:[
Location.error ~loc:opening_loc
(Printf.sprintf "Error: This '%s' might be unmatched" opening)
]
~if_highlight:
(Printf.sprintf "Syntax error: '%s' expected, \
the highlighted '%s' might be unmatched"
closing opening)
"Error: Syntax error: '%s' expected" closing
| Expecting (loc, nonterm) ->
Location.errorf ~loc "Error: Syntax error: %s expected." nonterm
| Not_expecting (loc, nonterm) ->
Location.errorf ~loc "Error: Syntax error: %s not expected." nonterm
| Applicative_path loc ->
Location.errorf ~loc
"Error: Syntax error: applicative paths of the form F(X).t \
are not supported when the option -no-app-func is set."
| Variable_in_scope (loc, var) ->
Location.errorf ~loc
"Error: In this scoped type, variable '%s@ \
is reserved for the local type %s."
var var
| Other loc ->
Location.error ~loc "Error: Syntax error"
let () =
Location.register_error_of_exn
(function
| Error err -> Some (prepare_error err)
| _ -> None
)
let report_error ppf err =
Location.report_error ppf (prepare_error err)
let location_of_error = function
| Unclosed(l,_,_,_)

1
parsing/syntaxerr.mli
View File

@ -26,5 +26,6 @@ exception Error of error
exception Escape_error
val report_error: formatter -> error -> unit
(* Deprecated. Use Location.{error_of_exn, report_error}. *)
val location_of_error: error -> Location.t

18
tools/ocamldep.ml
View File

@ -208,20 +208,14 @@ let print_raw_dependencies source_file deps =
let report_err source_file exn =
error_occurred := true;
match exn with
| Lexer.Error(err, range) ->
Format.fprintf Format.err_formatter "@[%a%a@]@."
Location.print_error range Lexer.report_error err
| Syntaxerr.Error err ->
Format.fprintf Format.err_formatter "@[%a@]@."
Syntaxerr.report_error err
| Sys_error msg ->
Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
| Pparse.Error err ->
Format.fprintf Format.err_formatter
"@[Preprocessing error on file %s@]@.@[%a@]@."
source_file
Pparse.report_error err
| x -> raise x
| x ->
match Location.error_of_exn x with
| Some err ->
Format.fprintf Format.err_formatter "@[%a@]@."
Location.report_error err
| None -> raise x
let read_parse_and_extract parse_function extract_function magic source_file =
Depend.free_structure_names := Depend.StringSet.empty;

21
tools/ocamlprof.ml
View File

@ -499,20 +499,11 @@ let main () =
" Print version number and exit";
] process_anon_file usage;
exit 0
with x ->
let report_error ppf = function
| Lexer.Error(err, range) ->
fprintf ppf "@[%a%a@]@."
Location.print_error range Lexer.report_error err
| Syntaxerr.Error err ->
fprintf ppf "@[%a@]@."
Syntaxerr.report_error err
| Profiler msg ->
fprintf ppf "@[%s@]@." msg
| Sys_error msg ->
fprintf ppf "@[I/O error:@ %s@]@." msg
| x -> raise x in
report_error Format.err_formatter x;
exit 2
with
| Profiler msg ->
fprintf Format.err_formatter "@[%s@]@." msg;
exit 2
| exn ->
Location.report_exception Format.err_formatter exn
let _ = main ()

4
toplevel/opttoploop.ml
View File

@ -325,7 +325,7 @@ let use_file ppf name =
with
| Exit -> false
| Sys.Break -> fprintf ppf "Interrupted.@."; false
| x -> Opterrors.report_error ppf x; false) in
| x -> Location.report_exception ppf x; false) in
if must_close then close_in ic;
success
with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
@ -439,7 +439,7 @@ let loop ppf =
| End_of_file -> exit 0
| Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
| PPerror -> ()
| x -> Opterrors.report_error ppf x; Btype.backtrack snap
| x -> Location.report_exception ppf x; Btype.backtrack snap
done
(* Execute a script *)

2
toplevel/opttopmain.ml
View File

@ -26,7 +26,7 @@ let prepare ppf =
!Opttoploop.toplevel_startup_hook ();
res
with x ->
try Opterrors.report_error ppf x; false
try Location.report_exception ppf x; false
with x ->
Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
false

4
toplevel/toploop.ml
View File

@ -349,7 +349,7 @@ let use_file ppf wrap_mod name =
with
| Exit -> false
| Sys.Break -> fprintf ppf "Interrupted.@."; false
| x -> Errors.report_error ppf x; false) in
| x -> Location.report_exception ppf x; false) in
if must_close then close_in ic;
success
with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
@ -468,7 +468,7 @@ let loop ppf =
| End_of_file -> exit 0
| Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap
| PPerror -> ()
| x -> Errors.report_error ppf x; Btype.backtrack snap
| x -> Location.report_exception ppf x; Btype.backtrack snap
done
(* Execute a script. If [name] is "", read the script from stdin. *)

2
toplevel/topmain.ml
View File

@ -26,7 +26,7 @@ let prepare ppf =
!Toploop.toplevel_startup_hook ();
res
with x ->
try Errors.report_error ppf x; false
try Location.report_exception ppf x; false
with x ->
Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
false

7
typing/cmi_format.ml
View File

@ -91,3 +91,10 @@ let report_error ppf = function
| Corrupted_interface filename ->
fprintf ppf "Corrupted compiled interface@ %a"
Location.print_filename filename
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

13
typing/ctype.ml
View File

@ -84,6 +84,19 @@ exception Unify of (type_expr * type_expr) list
exception Tags of label * label
let () =
Location.register_error_of_exn
(function
| Tags (l, l') ->
Some
Location.
(errorf ~loc:(in_file !input_name)
"In this program,@ variant constructors@ `%s and `%s@ \
have the same hash value.@ Change one of them." l l'
)
| _ -> None
)
exception Subtype of
(type_expr * type_expr) list * (type_expr * type_expr) list

16
typing/env.ml
View File

@ -60,6 +60,8 @@ type error =
exception Error of error
let error err = raise (Error err)
module EnvLazy : sig
type ('a,'b) t
@ -289,7 +291,7 @@ let check_consistency filename crcs =
(fun (name, crc) -> Consistbl.check crc_units name crc filename)
crcs
with Consistbl.Inconsistency(name, source, auth) ->
raise(Error(Inconsistent_import(name, auth, source)))
error (Inconsistent_import(name, auth, source))
(* Reading persistent structures from .cmi files *)
@ -310,12 +312,12 @@ let read_pers_struct modname filename = (
ps_filename = filename;
ps_flags = flags } in
if ps.ps_name <> modname then
raise(Error(Illegal_renaming(modname, ps.ps_name, filename)));
error (Illegal_renaming(modname, ps.ps_name, filename));
check_consistency filename ps.ps_crcs;
List.iter
(function Rectypes ->
if not !Clflags.recursive_types then
raise(Error(Need_recursive_types(ps.ps_name, !current_unit))))
error (Need_recursive_types(ps.ps_name, !current_unit)))
ps.ps_flags;
Hashtbl.add persistent_structures modname (Some ps);
ps
@ -1603,3 +1605,11 @@ let report_error ppf = function
fprintf ppf
"@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"
export import "The compilation flag -rectypes is required"
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

11
typing/includemod.ml
View File

@ -486,3 +486,14 @@ let report_error ppf errs =
in
let print_errs ppf = List.iter (include_err' ppf) in
fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
(* We could do a better job to split the individual error items
as sub-messages of the main interface mismatch on the whole unit. *)
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

9
typing/typeclass.ml
View File

@ -1784,3 +1784,12 @@ let report_error env ppf = function
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
| _ ->
None
)

9
typing/typecore.ml
View File

@ -3777,5 +3777,14 @@ let report_error env ppf = function
let report_error env ppf err =
wrap_printing_env env (fun () -> report_error env ppf err)
let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
| _ ->
None
)
let () =
Env.add_delayed_check_forward := add_delayed_check

1
typing/typecore.mli
View File

@ -111,6 +111,7 @@ type error =
exception Error of Location.t * Env.t * error
val report_error: Env.t -> formatter -> error -> unit
(* Deprecated. Use Location.{error_of_exn, report_error}. *)
(* Forward declaration, to be filled in by Typemod.type_module *)
val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref

9
typing/typedecl.ml
View File

@ -1344,3 +1344,12 @@ let report_error ppf = function
"cannot be checked"
| Exception_constructor_with_result ->
fprintf ppf "Exception constructors cannot specify a result type"
let () =
Location.register_error_of_exn
(function
| Error (loc, err) ->
Some (Location.error_of_printer loc report_error err)
| _ ->
None
)

9
typing/typemod.ml
View File

@ -1569,3 +1569,12 @@ let report_error ppf = function
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
| _ ->
None
)

10
typing/typetexp.ml
View File

@ -824,3 +824,13 @@ let report_error env ppf = function
fprintf ppf "Illegal recursive module reference"
| Extension s ->
fprintf ppf "Uninterpreted extension '%s'." s
let () =
Location.register_error_of_exn
(function
| Error (loc, env, err) ->
Some (Location.error_of_printer loc (report_error env) err)
| _ ->
None
)