Index: stdlib/printexc.mli
===================================================================
--- stdlib/printexc.mli	(revision 13257)
+++ stdlib/printexc.mli	(working copy)
@@ -82,3 +82,8 @@
     the backtrace if it has itself raised an exception before.
     @since 3.11.2
 *)
+
+val current_call_stack: unit -> (string * int * int * int) list
+(** [Printexc.current_call_stack ()] returns a suffix of the current
+    call stack (whose length is not specified).  Each item is a tuple
+    (file name, line number, first character, last character). *)
Index: stdlib/printexc.ml
===================================================================
--- stdlib/printexc.ml	(revision 13257)
+++ stdlib/printexc.ml	(working copy)
@@ -137,5 +137,28 @@
 external record_backtrace: bool -> unit = "caml_record_backtrace"
 external backtrace_status: unit -> bool = "caml_backtrace_status"
 
+external set_backtrace_extract: bool -> unit = "caml_set_backtrace_extract"
+
+let current_call_stack () =
+  let rb = backtrace_status () in
+  record_backtrace true;
+  set_backtrace_extract true;
+  (try raise Exit with _ -> ());
+  let bt = get_exception_backtrace () in
+  set_backtrace_extract false;
+  record_backtrace rb;
+  match bt with
+  | None -> []
+  | Some a ->
+      let res = ref [] in
+      for i = Array.length a - 1 downto 0 do
+        match a.(i) with
+        | Known_location (_, fn, lineno, ch1, ch2) when fn <> "printexc.ml" ->
+            res := (fn, lineno, ch1, ch2) :: !res
+        | _ -> ()
+      done;
+      !res
+
+
 let register_printer fn =
   printers := fn :: !printers
Index: boot/ocamldep
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: boot/ocamllex
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: boot/ocamlc
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: byterun/backtrace.c
===================================================================
--- byterun/backtrace.c	(revision 13257)
+++ byterun/backtrace.c	(working copy)
@@ -35,6 +35,7 @@
 
 CAMLexport int caml_backtrace_active = 0;
 CAMLexport int caml_backtrace_pos = 0;
+CAMLexport int caml_backtrace_extract = 0;
 CAMLexport code_t * caml_backtrace_buffer = NULL;
 CAMLexport value caml_backtrace_last_exn = Val_unit;
 CAMLexport char * caml_cds_file = NULL;
@@ -59,6 +60,10 @@
   POS_CNUM = 3
 };
 
+CAMLprim value caml_set_backtrace_extract(value vflag){
+  caml_backtrace_extract = Int_val(vflag);
+  return Val_unit;
+}
 /* Start or stop the backtrace machinery */
 
 CAMLprim value caml_record_backtrace(value vflag)
@@ -92,6 +97,7 @@
 
 void caml_stash_backtrace(value exn, code_t pc, value * sp)
 {
+  value * limit;
   code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
   if (pc != NULL) pc = pc - 1;
   if (exn != caml_backtrace_last_exn) {
@@ -106,7 +112,8 @@
   if (pc >= caml_start_code && pc < end_code){
     caml_backtrace_buffer[caml_backtrace_pos++] = pc;
   }
-  for (/*nothing*/; sp < caml_trapsp; sp++) {
+  limit = (caml_backtrace_extract ? caml_stack_high : caml_trapsp);
+  for (/*nothing*/; sp < limit; sp++) {
     code_t p = (code_t) *sp;
     if (p >= caml_start_code && p < end_code) {
       if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
Index: asmrun/backtrace.c
===================================================================
--- asmrun/backtrace.c	(revision 13257)
+++ asmrun/backtrace.c	(working copy)
@@ -23,10 +23,16 @@
 
 int caml_backtrace_active = 0;
 int caml_backtrace_pos = 0;
+int caml_backtrace_extract = 0;
 code_t * caml_backtrace_buffer = NULL;
 value caml_backtrace_last_exn = Val_unit;
 #define BACKTRACE_BUFFER_SIZE 1024
 
+CAMLprim value caml_set_backtrace_extract(value vflag){
+  caml_backtrace_extract = Int_val(vflag);
+  return Val_unit;
+}
+
 /* Start or stop the backtrace machinery */
 
 CAMLprim value caml_record_backtrace(value vflag)
@@ -104,9 +110,9 @@
     }
     /* Stop when we reach the current exception handler */
 #ifndef Stack_grows_upwards
-    if (sp > trapsp) return;
+    if (sp > trapsp && !caml_backtrace_extract) return;
 #else
-    if (sp < trapsp) return;
+    if (sp < trapsp && !caml_backtrace_extract) return;
 #endif
   }
 }

From a2d2342e4e85758be2361017ba2853cc367ce781 Mon Sep 17 00:00:00 2001
From: Jacques-Henri Jourdan <jacques-henri.jourdan@inria.fr>
Date: Sun, 21 Apr 2013 16:49:03 +0200
Subject: [PATCH] * PR#0005899 : exposing a way to inspect current call stack *
 list_of_raw_backtrace

---
 asmrun/backtrace.c  |  62 +++++++++++++++++++++++++++++++++++++++++----------
 byterun/backtrace.c |  63 ++++++++++++++++++++++++++++++++++++++++++++--------
 stdlib/printexc.ml  |  17 ++++++++++++++
 stdlib/printexc.mli |   8 +++++++
 4 files changed, 129 insertions(+), 21 deletions(-)

diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
index 3ca1824..84cdc26 100644
--- a/asmrun/backtrace.c
+++ b/asmrun/backtrace.c
@@ -58,22 +58,15 @@ CAMLprim value caml_backtrace_status(value vunit)
 /* Store the return addresses contained in the given stack fragment
    into the backtrace array */
 
-void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
+void caml_stash_backtrace_custom(uintnat pc, char * sp, char * trapsp, int maxframes,
+				 code_t ** buffer, int buffer_size, int * buffer_pos)
 {
   frame_descr * d;
   uintnat h;
 
-  if (exn != caml_backtrace_last_exn) {
-    caml_backtrace_pos = 0;
-    caml_backtrace_last_exn = exn;
-  }
-  if (caml_backtrace_buffer == NULL) {
-    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
-    if (caml_backtrace_buffer == NULL) return;
-  }
   if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
 
-  while (1) {
+  while (*buffer_pos < maxframes) {
     /* Find the descriptor corresponding to the return address */
     h = Hash_retaddr(pc);
     while(1) {
@@ -85,8 +78,18 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
     /* Skip to next frame */
     if (d->frame_size != 0xFFFF) {
       /* Regular frame, store its descriptor in the backtrace buffer */
-      if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
-      caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d;
+      if (*buffer_pos >= buffer_size) {
+	int new_buffer_size = buffer_size * 2 + 1;
+	if(new_buffer_size > maxframes)
+	  new_buffer_size = maxframes;
+	code_t *new_buffer = (code_t*)realloc(*buffer, new_buffer_size * sizeof(code_t));
+	if(new_buffer == NULL)
+	  return;
+	buffer_size = new_buffer_size;
+	*buffer = new_buffer;
+      }
+      (*buffer)[(*buffer_pos)++] = (code_t) d;
+
 #ifndef Stack_grows_upwards
       sp += (d->frame_size & 0xFFFC);
 #else
@@ -114,6 +117,41 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
   }
 }
 
+void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) {
+  if (exn != caml_backtrace_last_exn) {
+    caml_backtrace_pos = 0;
+    caml_backtrace_last_exn = exn;
+  }
+  if (caml_backtrace_buffer == NULL) {
+    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+    if (caml_backtrace_buffer == NULL) return;
+  }
+  caml_stash_backtrace_custom(pc, sp, trapsp, BACKTRACE_BUFFER_SIZE,
+			      &caml_backtrace_buffer, BACKTRACE_BUFFER_SIZE, &caml_backtrace_pos);
+}
+
+CAMLprim value caml_stash_current_backtrace(value maxframes) {
+  CAMLparam1(maxframes);
+  CAMLlocal1(res);
+
+  int initial_size = 16;
+  if(initial_size > maxframes)
+    initial_size = maxframes;
+  code_t * buffer = (code_t*)malloc(initial_size * sizeof(code_t));
+  int buffer_pos = 0;
+  int imaxframes = Int_val(maxframes);
+
+  caml_stash_backtrace_custom(caml_last_return_address, caml_bottom_of_stack, caml_top_of_stack,
+			      imaxframes, &buffer, initial_size, &buffer_pos);
+
+  res = caml_alloc(buffer_pos, Abstract_tag);
+  memcpy(&Field(res, 0), buffer, buffer_pos * sizeof(code_t));
+
+  free(buffer);
+
+  CAMLreturn(res);
+}
+
 /* Extract location information for the given frame descriptor */
 
 struct loc_info {
diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index 9e894f2..07433a7 100644
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -93,10 +93,36 @@ CAMLprim value caml_backtrace_status(value vunit)
 /* Store the return addresses contained in the given stack fragment
    into the backtrace array */
 
-void caml_stash_backtrace(value exn, code_t pc, value * sp)
+void caml_stash_backtrace_custom(value * sp, value * limitsp, int maxframes,
+				 code_t ** buffer, int buffer_size, int * buffer_pos)
 {
   code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
-  if (pc != NULL) pc = pc - 1;
+  value* trapsp = caml_trapsp;
+  for (/*nothing*/; sp < limitsp && *buffer_pos < maxframes; sp++) {
+    if(&Trap_pc(trapsp) == (code_t*)sp) {
+      trapsp = Trap_link(trapsp);
+      continue;
+    }
+
+    code_t p = (code_t) *sp;
+    if (p >= caml_start_code && p < end_code) {
+      if (*buffer_pos >= buffer_size) {
+	int new_buffer_size = buffer_size * 2 + 1;
+	if(new_buffer_size > maxframes)
+	  new_buffer_size = maxframes;
+	code_t *new_buffer =
+	  (code_t*)realloc(*buffer, new_buffer_size * sizeof(code_t));
+	if(new_buffer == NULL)
+	  break;
+	buffer_size = new_buffer_size;
+	*buffer = new_buffer;
+      }
+      (*buffer)[(*buffer_pos)++] = p;
+    }
+  }
+}
+
+void caml_stash_backtrace(value exn, code_t pc, value * sp) {
   if (exn != caml_backtrace_last_exn) {
     caml_backtrace_pos = 0;
     caml_backtrace_last_exn = exn;
@@ -105,17 +131,36 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
     caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
     if (caml_backtrace_buffer == NULL) return;
   }
+  code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
+  if (pc != NULL) pc = pc - 1;
   if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
   if (pc >= caml_start_code && pc < end_code){
     caml_backtrace_buffer[caml_backtrace_pos++] = pc;
   }
-  for (/*nothing*/; sp < caml_trapsp; sp++) {
-    code_t p = (code_t) *sp;
-    if (p >= caml_start_code && p < end_code) {
-      if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
-      caml_backtrace_buffer[caml_backtrace_pos++] = p;
-    }
-  }
+  caml_stash_backtrace_custom(sp, caml_trapsp, BACKTRACE_BUFFER_SIZE,
+			      &caml_backtrace_buffer, BACKTRACE_BUFFER_SIZE, &caml_backtrace_pos);
+}
+
+CAMLprim value caml_stash_current_backtrace(value maxframes) {
+  CAMLparam1(maxframes);
+  CAMLlocal1(res);
+
+  int initial_size = 16;
+  if(initial_size > maxframes)
+    initial_size = maxframes;
+  code_t * buffer = (code_t*)malloc(initial_size * sizeof(code_t));
+  int buffer_pos = 0;
+  int imaxframes = Int_val(maxframes);
+
+  caml_stash_backtrace_custom(caml_extern_sp, caml_stack_high,
+			      imaxframes, &buffer, initial_size, &buffer_pos);
+
+  res = caml_alloc(buffer_pos, Abstract_tag);
+  memcpy(&Field(res, 0), buffer, buffer_pos * sizeof(code_t));
+
+  free(buffer);
+
+  CAMLreturn(res);
 }
 
 /* Read the debugging info contained in the current bytecode executable.
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index a36e2d4..9acbebd 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -163,5 +163,22 @@ let get_backtrace () =
 external record_backtrace: bool -> unit = "caml_record_backtrace"
 external backtrace_status: unit -> bool = "caml_backtrace_status"
 
+let list_of_raw_backtrace bt =
+  let bt = convert_raw_backtrace bt in
+  match bt with
+  | None -> []
+  | Some a ->
+      let res = ref [] in
+      for i = Array.length a - 1 downto 0 do
+        match a.(i) with
+        | Known_location (_, fn, lineno, ch1, ch2) ->
+            res := (fn, lineno, ch1, ch2) :: !res
+        | _ -> ()
+      done;
+      !res
+
 let register_printer fn =
   printers := fn :: !printers
+
+external current_backtrace:
+  int -> raw_backtrace = "caml_stash_current_backtrace"
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index ad48f66..6a2d134 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -100,3 +100,11 @@ val get_raw_backtrace: unit -> raw_backtrace
 val print_raw_backtrace: out_channel -> raw_backtrace -> unit
 val raw_backtrace_to_string: raw_backtrace -> string
 
+val list_of_raw_backtrace: raw_backtrace -> (string * int * int * int) list
+(** [Printexc.list_of_raw_backtrace bt] converts a raw backtrace to a
+    list of locations. Each item is a tuple (file name, line number,
+    first character, last character). *)
+
+val current_backtrace: int -> raw_backtrace
+(** [Printexc.current_backtrace n] returns the backtrace of the current
+    stack. The backtrace is truncated to the highest [n] frames. *)
-- 
1.8.1.4