Cherry-picking commit 14093 from trunk.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/exception_registration@14104 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

2 files changed, 64 insertions, 0 deletions

diff --git a/parsing/location.ml b/parsing/location.ml
index d3f89f4405..14d2f9513a 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -286,3 +286,41 @@ type 'a loc = {
 
 let mkloc txt loc = { txt ; loc }
 let mknoloc txt = mkloc txt none
+
+
+type error =
+  {
+    loc: t;
+    msg: string;
+    sub: error list;
+  }
+
+let error ?(loc = none) ?(sub = []) msg = {loc; msg; sub}
+
+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} =
+  print ppf loc;
+  Format.pp_print_string ppf msg;
+  List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub
+
+let error_of_printer loc print x =
+  let buf = Buffer.create 64 in
+  let ppf = Format.formatter_of_buffer buf in
+  Format.fprintf ppf "Error: ";
+  print ppf x;
+  pp_print_flush ppf ();
+  let msg = Buffer.contents buf in
+  error ~loc msg
diff --git a/parsing/location.mli b/parsing/location.mli
index bae9090207..a465b8a1fb 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -75,3 +75,29 @@ val show_filename: string -> string
 
 
 val absname: bool ref
+
+
+(* Support for located errors *)
+
+type error =
+  {
+    loc: t;
+    msg: string;
+    sub: error list;
+  }
+
+val error: ?loc:t -> ?sub:error list -> string -> error
+
+val error_of_printer: t -> (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