Meilleure impression des exceptions
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2990 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
a6a5168723
commit
5c65f975b2
|
@ -373,7 +373,7 @@ let transl_toplevel_item = function
|
|||
Lprim(Psetglobal id, [transl_path path])
|
||||
| Tstr_module(id, modl) ->
|
||||
Ident.make_global id;
|
||||
Lprim(Psetglobal id, [transl_module Tcoerce_none None modl])
|
||||
Lprim(Psetglobal id, [transl_module Tcoerce_none (Some(Pident id)) modl])
|
||||
| Tstr_modtype(id, decl) ->
|
||||
lambda_unit
|
||||
| Tstr_open path ->
|
||||
|
|
|
@ -48,7 +48,27 @@ let check_depth ppf depth obj ty =
|
|||
false
|
||||
end else true
|
||||
|
||||
module Printer = Genprintval.Make(Debugcom.Remote_value)
|
||||
module EvalPath =
|
||||
struct
|
||||
type value = Debugcom.Remote_value.t
|
||||
exception Error
|
||||
let rec eval_path = function
|
||||
Pident id ->
|
||||
begin try
|
||||
Debugcom.Remote_value.global (Symtable.get_global_position id)
|
||||
with Symtable.Error _ ->
|
||||
raise Error
|
||||
end
|
||||
| Pdot(root, fieldname, pos) ->
|
||||
let v = eval_path root in
|
||||
if not (Debugcom.Remote_value.is_block v)
|
||||
then raise Error
|
||||
else Debugcom.Remote_value.field v pos
|
||||
| Papply(p1, p2) ->
|
||||
raise Error
|
||||
end
|
||||
|
||||
module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath)
|
||||
|
||||
let install_printer path ty ppf fn =
|
||||
Printer.install_printer path ty
|
||||
|
@ -64,7 +84,7 @@ let remove_printer = Printer.remove_printer
|
|||
let max_printer_depth = ref 20
|
||||
let max_printer_steps = ref 300
|
||||
|
||||
let print_exception = Printer.print_exception
|
||||
let print_exception = Printer.print_untyped_exception
|
||||
|
||||
let print_value max_depth env obj (ppf : Format.formatter) ty =
|
||||
Printer.print_value !max_printer_steps max_depth
|
||||
|
|
|
@ -23,3 +23,16 @@ let rec flat accu = function
|
|||
| Lapply(l1, l2) -> Misc.fatal_error "Longident.flat"
|
||||
|
||||
let flatten lid = flat [] lid
|
||||
|
||||
let rec split_at_dots s pos =
|
||||
try
|
||||
let dot = String.index_from s pos '.' in
|
||||
String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
|
||||
with Not_found ->
|
||||
[String.sub s pos (String.length s - pos)]
|
||||
|
||||
let parse s =
|
||||
match split_at_dots s 0 with
|
||||
[] -> Lident "" (* should not happen, but don't put assert false
|
||||
so as not to crash the toplevel (see Genprintval) *)
|
||||
| hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl
|
||||
|
|
|
@ -20,3 +20,4 @@ type t =
|
|||
| Lapply of t * t
|
||||
|
||||
val flatten: t -> string list
|
||||
val parse: string -> t
|
||||
|
|
|
@ -23,7 +23,6 @@ open Types
|
|||
module type OBJ =
|
||||
sig
|
||||
type t
|
||||
|
||||
val obj : t -> 'a
|
||||
val is_block : t -> bool
|
||||
val tag : t -> int
|
||||
|
@ -31,20 +30,25 @@ module type OBJ =
|
|||
val field : t -> int -> t
|
||||
end
|
||||
|
||||
module type EVALPATH =
|
||||
sig
|
||||
type value
|
||||
val eval_path: Path.t -> value
|
||||
exception Error
|
||||
end
|
||||
|
||||
module type S =
|
||||
sig
|
||||
type t
|
||||
|
||||
val install_printer : Path.t -> Types.type_expr -> (t -> unit) -> unit
|
||||
val remove_printer : Path.t -> unit
|
||||
|
||||
val print_exception : formatter -> t -> unit
|
||||
val print_untyped_exception : formatter -> t -> unit
|
||||
val print_value :
|
||||
int -> int -> (int -> t -> Types.type_expr -> bool) ->
|
||||
Env.t -> t -> formatter -> type_expr -> unit
|
||||
end
|
||||
|
||||
module Make(O : OBJ) = struct
|
||||
module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
|
||||
|
||||
type t = O.t
|
||||
|
||||
|
@ -53,14 +57,15 @@ module Make(O : OBJ) = struct
|
|||
Here, we do a feeble attempt to print
|
||||
integer, string and float arguments... *)
|
||||
|
||||
let print_exception_args obj ppf start_offset =
|
||||
let print_untyped_exception_args obj ppf start_offset =
|
||||
if O.size obj > start_offset then begin
|
||||
fprintf ppf "@[<1>(";
|
||||
for i = start_offset to O.size obj - 1 do
|
||||
if i > start_offset then fprintf ppf ",@ ";
|
||||
let arg = O.field obj i in
|
||||
if not (O.is_block arg) then
|
||||
fprintf ppf "%i" (O.obj arg : int) (* Note: this could be a char! *)
|
||||
fprintf ppf "%i" (O.obj arg : int)
|
||||
(* Note: this could be a char or a constant constructor... *)
|
||||
else if O.tag arg = Obj.string_tag then
|
||||
fprintf ppf "\"%s\"" (String.escaped (O.obj arg : string))
|
||||
else if O.tag arg = Obj.double_tag then
|
||||
|
@ -71,15 +76,15 @@ module Make(O : OBJ) = struct
|
|||
fprintf ppf ")@]"
|
||||
end
|
||||
|
||||
let print_path = Printtyp.path
|
||||
|
||||
let print_exception ppf bucket =
|
||||
let print_untyped_exception ppf bucket =
|
||||
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
|
||||
if (name = "Match_failure" || name = "Assert_failure")
|
||||
&& O.size bucket = 2
|
||||
&& O.tag(O.field bucket 1) = 0
|
||||
then fprintf ppf "%s%a" name (print_exception_args (O.field bucket 1)) 0
|
||||
else fprintf ppf "%s%a" name (print_exception_args bucket) 1
|
||||
then fprintf ppf "%s%a" name
|
||||
(print_untyped_exception_args (O.field bucket 1)) 0
|
||||
else fprintf ppf "%s%a" name
|
||||
(print_untyped_exception_args bucket) 1
|
||||
|
||||
(* The user-defined printers. Also used for some builtin types. *)
|
||||
|
||||
|
@ -185,15 +190,13 @@ module Make(O : OBJ) = struct
|
|||
if check_depth depth obj ty then begin
|
||||
if prio > 0
|
||||
then
|
||||
fprintf ppf "@[<1>(%a)@]" (print_val_list 1 depth obj) ty_list
|
||||
else fprintf ppf "@[%a@]" (print_val_list 1 depth obj) ty_list
|
||||
fprintf ppf "@[<1>(%a)@]"
|
||||
(print_val_list 1 0 depth obj) ty_list
|
||||
else fprintf ppf "@[%a@]"
|
||||
(print_val_list 1 0 depth obj) ty_list
|
||||
end
|
||||
| Tconstr(path, [], _) when Path.same path Predef.path_exn ->
|
||||
if check_depth depth obj ty then begin
|
||||
if prio > 1
|
||||
then fprintf ppf "@[<2>(%a)@]" print_exception obj
|
||||
else fprintf ppf "@[<1>%a@]" print_exception obj
|
||||
end
|
||||
print_exception prio depth ppf obj
|
||||
| Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
|
||||
if O.is_block obj then begin
|
||||
if check_depth depth obj ty then begin
|
||||
|
@ -243,26 +246,8 @@ module Make(O : OBJ) = struct
|
|||
try Ctype.apply env decl.type_params ty ty_list with
|
||||
Ctype.Cannot_apply -> abstract_type)
|
||||
constr_args in
|
||||
begin match ty_args with
|
||||
| [] ->
|
||||
print_constr env path ppf constr_name
|
||||
| [ty1] ->
|
||||
if check_depth depth obj ty then
|
||||
(if prio > 1
|
||||
then fprintf ppf "@[<2>(%a@ %a)@]"
|
||||
else fprintf ppf "@[<1>%a@ %a@]")
|
||||
(print_constr env path) constr_name
|
||||
(cautious
|
||||
(print_val 2 (depth - 1) (O.field obj 0) ppf))
|
||||
ty1;
|
||||
| tyl ->
|
||||
if check_depth depth obj ty then
|
||||
(if prio > 1
|
||||
then fprintf ppf "@[<2>(%a@ @[<1>(%a)@])@]"
|
||||
else fprintf ppf "@[<1>%a@ @[<1>(%a)@]@]")
|
||||
(print_constr env path) constr_name
|
||||
(print_val_list 1 depth obj) tyl;
|
||||
end
|
||||
print_constr_with_args (print_constr env path) constr_name
|
||||
prio 0 depth obj ppf ty_args
|
||||
| {type_kind = Type_record(lbl_list, rep)} ->
|
||||
if check_depth depth obj ty then begin
|
||||
let rec print_fields pos ppf = function
|
||||
|
@ -322,14 +307,59 @@ module Make(O : OBJ) = struct
|
|||
| Tfield(_, _, _, _) | Tnil | Tlink _ ->
|
||||
fatal_error "Printval.print_value"
|
||||
|
||||
and print_val_list prio depth obj ppf ty_list =
|
||||
and print_val_list prio start depth obj ppf ty_list =
|
||||
let rec print_list i = function
|
||||
| [] -> ()
|
||||
| ty :: ty_list ->
|
||||
if i > 0 then fprintf ppf ",@ ";
|
||||
if i > start then fprintf ppf ",@ ";
|
||||
print_val prio (depth - 1) (O.field obj i) ppf ty;
|
||||
print_list (i + 1) ty_list in
|
||||
cautious (print_list 0) ppf ty_list
|
||||
cautious (print_list start) ppf ty_list
|
||||
|
||||
and print_constr_with_args
|
||||
print_cstr cstr_name prio start depth obj ppf ty_args =
|
||||
match ty_args with
|
||||
[] ->
|
||||
print_cstr ppf cstr_name
|
||||
| [ty1] ->
|
||||
if check_depth depth obj ty then
|
||||
(if prio > 1
|
||||
then fprintf ppf "@[<2>(%a@ %a)@]"
|
||||
else fprintf ppf "@[<1>%a@ %a@]")
|
||||
print_cstr cstr_name
|
||||
(cautious
|
||||
(print_val 2 (depth - 1) (O.field obj start) ppf))
|
||||
ty1;
|
||||
| tyl ->
|
||||
if check_depth depth obj ty then
|
||||
(if prio > 1
|
||||
then fprintf ppf "@[<2>(%a@ @[<1>(%a)@])@]"
|
||||
else fprintf ppf "@[<1>%a@ @[<1>(%a)@]@]")
|
||||
print_cstr cstr_name
|
||||
(print_val_list 1 start depth obj) tyl;
|
||||
|
||||
and print_exception prio depth ppf bucket =
|
||||
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
|
||||
let lid = Longident.parse name in
|
||||
try
|
||||
(* Attempt to recover the constructor description for the exn
|
||||
from its name *)
|
||||
let cstr = Env.lookup_constructor lid env in
|
||||
let path =
|
||||
match cstr.cstr_tag with
|
||||
Cstr_exception p -> p | _ -> raise Not_found in
|
||||
(* Make sure this is the right exception and not an homonym,
|
||||
by evaluating the exception found and comparing with the identifier
|
||||
contained in the exception bucket *)
|
||||
if O.field bucket 0 != EVP.eval_path path then raise Not_found;
|
||||
print_constr_with_args
|
||||
pp_print_string name prio 1 depth bucket ppf cstr.cstr_args
|
||||
with Not_found | EVP.Error ->
|
||||
if check_depth depth obj ty then begin
|
||||
if prio > 1
|
||||
then fprintf ppf "@[<2>(%a)@]" print_untyped_exception obj
|
||||
else fprintf ppf "@[<1>%a@]" print_untyped_exception obj
|
||||
end
|
||||
|
||||
in cautious (print_val 0 max_depth obj ppf) ppf ty
|
||||
|
||||
|
|
|
@ -20,7 +20,6 @@ open Format
|
|||
module type OBJ =
|
||||
sig
|
||||
type t
|
||||
|
||||
val obj : t -> 'a
|
||||
val is_block : t -> bool
|
||||
val tag : t -> int
|
||||
|
@ -28,17 +27,23 @@ module type OBJ =
|
|||
val field : t -> int -> t
|
||||
end
|
||||
|
||||
module type EVALPATH =
|
||||
sig
|
||||
type value
|
||||
val eval_path: Path.t -> value
|
||||
exception Error
|
||||
end
|
||||
|
||||
module type S =
|
||||
sig
|
||||
type t
|
||||
|
||||
val install_printer : Path.t -> Types.type_expr -> (t -> unit) -> unit
|
||||
val remove_printer : Path.t -> unit
|
||||
|
||||
val print_exception : formatter -> t -> unit
|
||||
val print_untyped_exception : formatter -> t -> unit
|
||||
val print_value :
|
||||
int -> int -> (int -> t -> Types.type_expr -> bool) ->
|
||||
Env.t -> t -> formatter -> type_expr -> unit
|
||||
end
|
||||
|
||||
module Make(O : OBJ) : (S with type t = O.t)
|
||||
module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) :
|
||||
(S with type t = O.t)
|
||||
|
|
|
@ -12,14 +12,30 @@
|
|||
|
||||
(* $Id$ *)
|
||||
|
||||
open Misc
|
||||
open Path
|
||||
|
||||
(* Return the value referred to by a path *)
|
||||
|
||||
let rec eval_path = function
|
||||
| Pident id -> Symtable.get_global_value id
|
||||
| Pdot(p, s, pos) -> Obj.field (eval_path p) pos
|
||||
| Papply(p1, p2) -> fatal_error "Topdirs.eval_path"
|
||||
|
||||
(* To print values *)
|
||||
|
||||
module Printer = Genprintval.Make(Obj)
|
||||
module EvalPath = struct
|
||||
type value = Obj.t
|
||||
exception Error
|
||||
let eval_path p = try eval_path p with Symtable.Error _ -> raise Error
|
||||
end
|
||||
|
||||
module Printer = Genprintval.Make(Obj)(EvalPath)
|
||||
|
||||
let max_printer_depth = ref 100
|
||||
let max_printer_steps = ref 300
|
||||
|
||||
let print_exception = Printer.print_exception
|
||||
let print_untyped_exception = Printer.print_untyped_exception
|
||||
let print_value env obj ty =
|
||||
Printer.print_value !max_printer_steps !max_printer_depth
|
||||
(fun _ _ _ -> true) env obj ty
|
||||
|
|
|
@ -17,8 +17,10 @@
|
|||
open Types
|
||||
open Format
|
||||
|
||||
val print_exception: formatter -> Obj.t -> unit
|
||||
val eval_path: Path.t -> Obj.t
|
||||
|
||||
val print_value: Env.t -> Obj.t -> formatter -> type_expr -> unit
|
||||
val print_untyped_exception: formatter -> Obj.t -> unit
|
||||
|
||||
val install_printer : Path.t -> Types.type_expr -> (Obj.t -> unit) -> unit
|
||||
val remove_printer : Path.t -> unit
|
||||
|
|
|
@ -27,13 +27,6 @@ open Toploop
|
|||
(* The standard error formatter *)
|
||||
let std_err = err_formatter
|
||||
|
||||
(* Return the value referred to by a path *)
|
||||
|
||||
let rec eval_path = function
|
||||
| Pident id -> Symtable.get_global_value id
|
||||
| Pdot(p, s, pos) -> Obj.field (eval_path p) pos
|
||||
| Papply(p1, p2) -> fatal_error "Topdirs.eval_path"
|
||||
|
||||
(* To quit *)
|
||||
|
||||
let dir_quit () = exit 0
|
||||
|
|
|
@ -115,6 +115,10 @@ let rec pr_items space env ppf = function
|
|||
|
||||
let print_items = pr_items false
|
||||
|
||||
(* The current typing environment for the toplevel *)
|
||||
|
||||
let toplevel_env = ref Env.empty
|
||||
|
||||
(* Print an exception produced by an evaluation *)
|
||||
|
||||
let print_exception_outcome ppf = function
|
||||
|
@ -127,7 +131,7 @@ let print_exception_outcome ppf = function
|
|||
fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
|
||||
| exn ->
|
||||
fprintf ppf "@[Uncaught exception: %a.@."
|
||||
print_exception (Obj.repr exn)
|
||||
(print_value !toplevel_env (Obj.repr exn)) Predef.type_exn
|
||||
|
||||
(* The table of toplevel directives.
|
||||
Filled by functions from module topdirs. *)
|
||||
|
@ -136,8 +140,6 @@ let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
|
|||
|
||||
(* Execute a toplevel phrase *)
|
||||
|
||||
let toplevel_env = ref Env.empty
|
||||
|
||||
let execute_phrase print_outcome ppf phr =
|
||||
match phr with
|
||||
| Ptop_def sstr ->
|
||||
|
|
|
@ -83,7 +83,7 @@ let rec instrument_result env name ppf clos_typ =
|
|||
with exn ->
|
||||
fprintf ppf "@[<2>%a raises@ %a@]@."
|
||||
Printtyp.longident starred_name
|
||||
print_exception (Obj.repr exn);
|
||||
(print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
|
||||
raise exn))
|
||||
| _ -> (fun v -> v)
|
||||
|
||||
|
@ -107,7 +107,7 @@ let instrument_closure env name ppf clos_typ =
|
|||
with exn ->
|
||||
fprintf ppf "@[<2>%a raises@ %a@]@."
|
||||
Printtyp.longident name
|
||||
print_exception (Obj.repr exn);
|
||||
(print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
|
||||
raise exn)
|
||||
| _ -> assert false
|
||||
|
||||
|
|
Loading…
Reference in New Issue