From 6cc9ecc55b615c3d6ad1ab97614fbaea5cd0ecc1 Mon Sep 17 00:00:00 2001
From: Stephane Glondu <steph@glondu.net>
Date: Wed, 28 Apr 2010 22:05:14 +0200
Subject: [PATCH] Use Printexc.to_string if possible in default exception handler

Signed-off-by: Stephane Glondu <steph@glondu.net>
---
 byterun/printexc.c |   19 ++++++++++++++++---
 stdlib/printexc.ml |    5 +++++
 2 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/byterun/printexc.c b/byterun/printexc.c
index f72157f..977675f 100644
--- a/byterun/printexc.c
+++ b/byterun/printexc.c
@@ -96,11 +96,24 @@ CAMLexport char * caml_format_exception(value exn)
 void caml_fatal_uncaught_exception(value exn)
 {
   char * msg;
-  value * at_exit;
+  value * at_exit, * printexc_to_string, ml_msg;
   int saved_backtrace_active, saved_backtrace_pos;
+  int msg_from_caml = 0;
 
   /* Build a string representation of the exception */
-  msg = caml_format_exception(exn);
+  printexc_to_string = caml_named_value("Printexc.to_string");
+  if (printexc_to_string == NULL) {
+    msg = caml_format_exception(exn);
+  } else {
+    ml_msg = caml_callback_exn(*printexc_to_string, exn);
+    if (Is_exception_result(ml_msg)) {
+      msg = caml_format_exception(exn);
+    } else {
+      msg = String_val(ml_msg);
+      msg_from_caml = 1;
+    }
+  }
+
   /* Perform "at_exit" processing, ignoring all exceptions that may
      be triggered by this */
   saved_backtrace_active = caml_backtrace_active;
@@ -112,7 +125,7 @@ void caml_fatal_uncaught_exception(value exn)
   caml_backtrace_pos = saved_backtrace_pos;
   /* Display the uncaught exception */
   fprintf(stderr, "Fatal error: exception %s\n", msg);
-  free(msg);
+  if (!msg_from_caml) free(msg);
   /* Display the backtrace if available */
   if (caml_backtrace_active
 #ifndef NATIVE_CODE
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 9e435c5..9387914 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -62,6 +62,11 @@ let to_string x =
             constructor ^ (fields x) in
   conv !printers
 
+external register_named_value : string -> 'a -> unit
+                              = "caml_register_named_value"
+
+let _ = register_named_value "Printexc.to_string" to_string
+
 let print fct arg =
   try
     fct arg
-- 
1.7.0