Ajout de Printexc.to_string.

Suppression de Printexc.print_exn qui est redondant.


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

3 files changed, 40 insertions, 34 deletions

diff --git a/stdlib/.depend b/stdlib/.depend
index cd1aa0d94..424665e71 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -36,8 +36,8 @@ parsing.cmo: array.cmi lexing.cmi obj.cmi parsing.cmi
 parsing.cmx: array.cmx lexing.cmx obj.cmx parsing.cmi 
 pervasives.cmo: pervasives.cmi 
 pervasives.cmx: pervasives.cmi 
-printexc.cmo: obj.cmi printexc.cmi 
-printexc.cmx: obj.cmx printexc.cmi 
+printexc.cmo: obj.cmi printf.cmi sys.cmi printexc.cmi 
+printexc.cmx: obj.cmx printf.cmx sys.cmx printexc.cmi 
 printf.cmo: list.cmi obj.cmi string.cmi printf.cmi 
 printf.cmx: list.cmx obj.cmx string.cmx printf.cmi 
 queue.cmo: queue.cmi 
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 4bcd9ccb4..1d825d60b 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -15,46 +15,52 @@ open Printf;;
 
 let locfmt =
   match Sys.os_type with
-  | "MacOS" -> ("File \"%s\"; line %d; characters %d to %d ### %s\n"
+  | "MacOS" -> ("File \"%s\"; line %d; characters %d to %d ### %s"
                 : ('a, 'b, 'c) format)
-  | _ -> ("File \"%s\", line %d, characters %d-%d: %s\n" : ('a, 'b, 'c) format)
+  | _ -> ("File \"%s\", line %d, characters %d-%d: %s" : ('a, 'b, 'c) format)
 ;;
 
-let print_exn = function
-    Out_of_memory ->
-      prerr_string "Out of memory\n";
-  | Stack_overflow ->
-      prerr_string "Stack overflow\n";
+let field x i =
+  let f = Obj.field x i in
+  if not (Obj.is_block f) then
+    sprintf "%d" (Obj.magic f : int)           (* can also be a char *)
+  else if Obj.tag f = 252 then
+    sprintf "\"%s\"" (String.escaped (Obj.magic f : string))
+  else if Obj.tag f = 253 then
+    string_of_float (Obj.magic f : float)
+  else
+    "_"
+;;
+let rec other_fields x i =
+  if i >= Obj.size x then ""
+  else sprintf ", %s%s" (field x i) (other_fields x (i+1))
+;;
+let fields x =
+  match Obj.size x with
+  | 0 -> ""
+  | 1 -> ""
+  | 2 -> sprintf "(%s)" (field x 1)
+  | n -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
+;;
+
+let to_string = function
+  | Out_of_memory -> "Out of memory";
+  | Stack_overflow -> "Stack overflow";
   | Match_failure(file, first_char, last_char) ->
-      eprintf locfmt file 0 first_char last_char "Pattern matching failed";
+      sprintf locfmt file 0 first_char last_char "Pattern matching failed";
   | Assert_failure(file, first_char, last_char) ->
-      eprintf locfmt file 0 first_char last_char "Assertion failed";
+      sprintf locfmt file 0 first_char last_char "Assertion failed";
   | x ->
-      prerr_string "Uncaught exception: ";
-      prerr_string (Obj.magic(Obj.field (Obj.field (Obj.repr x) 0) 0));
-      if Obj.size (Obj.repr x) > 1 then begin
-        prerr_char '(';
-        for i = 1 to Obj.size (Obj.repr x) - 1 do
-          if i > 1 then prerr_string ", ";
-          let arg = Obj.field (Obj.repr x) i in
-          if not (Obj.is_block arg) then
-            prerr_int (Obj.magic arg : int)
-          else if Obj.tag arg = 252 then begin
-            prerr_char '"';
-            prerr_string (Obj.magic arg : string);
-            prerr_char '"'
-          end else
-            prerr_char '_'
-        done;
-        prerr_char ')'
-      end;
-      prerr_char '\n'
+      let x = Obj.repr x in
+      let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
+      constructor ^ (fields x)
+;;
 
 let print fct arg =
   try
     fct arg
   with x ->
-    print_exn x;
+    eprintf "Uncaught exception: %s\n" (to_string x);
     flush stderr;
     raise x
 
@@ -63,5 +69,5 @@ let catch fct arg =
     fct arg
   with x ->
     flush stdout;
-    print_exn x;
+    eprintf "Uncaught exception: %s\n" (to_string x);
     exit 2
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index 37737253d..d8af7dfb8 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -26,5 +26,5 @@ val print: ('a -> 'b) -> 'a -> 'b
         (* Same as [catch], but re-raise the stray exception after
            printing it, instead of aborting the program. *)
 
-val print_exn: exn -> unit
-        (* [print_exn e] prints [e] on standard error output. *)
+val to_string : exn -> string
+        (* [Printexc.to_string e] returns a string representation of [e]. *)