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

Meilleure impression des exceptions 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2990 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 2000-03-25 18:55:45 +00:00
parent a6a5168723
commit 5c65f975b2
11 changed files with 149 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bytecomp/translmod.ml
View File

@ -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 ->

24
debugger/printval.ml
View File

@ -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

13
parsing/longident.ml
View File

@ -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

1
parsing/longident.mli
View File

@ -20,3 +20,4 @@ type t =
| Lapply of t * t
val flatten: t -> string list
val parse: string -> t

114
toplevel/genprintval.ml
View File

@ -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

15
toplevel/genprintval.mli
View File

@ -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)

20
toplevel/printval.ml
View File

@ -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

4
toplevel/printval.mli
View File

@ -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

7
toplevel/topdirs.ml
View File

@ -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

8
toplevel/toploop.ml
View File

@ -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 ->

8
toplevel/trace.ml
View File

@ -82,8 +82,8 @@ let rec instrument_result env name ppf clos_typ =
trace_res res
with exn ->
fprintf ppf "@[<2>%a raises@ %a@]@."
Printtyp.longident starred_name
print_exception (Obj.repr exn);
Printtyp.longident starred_name
(print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
raise exn))
| _ -> (fun v -> v)
@ -106,8 +106,8 @@ let instrument_closure env name ppf clos_typ =
trace_res res
with exn ->
fprintf ppf "@[<2>%a raises@ %a@]@."
Printtyp.longident name
print_exception (Obj.repr exn);
Printtyp.longident name
(print_value !toplevel_env (Obj.repr exn)) Predef.type_exn;
raise exn)
| _ -> assert false