1313(* *)
1414(* *************************************************************************)
1515[@@@ bs.config { flags = [|" -bs-no-cross-module-opt"
16- open Printf
16+
1717
1818let printers = ref []
1919
20- let locfmt = format_of_string " File \" %s\" , line %d, characters %d-%d: %s"
20+ let locfmt s (linum : int ) (start : int ) (finish : int ) msg =
21+ {j| File " $(s)" $ (linum), characters $ (start)-$ (finish): $ (msg)| j}
2122
2223
2324let fields : exn -> string = [% raw{| function(x){
@@ -51,11 +52,11 @@ let to_string x =
5152 | Out_of_memory -> " Out of memory"
5253 | Stack_overflow -> " Stack overflow"
5354 | Match_failure (file , line , char ) ->
54- sprintf locfmt file line char (char + 5 ) " Pattern matching failed"
55+ locfmt file line char (char + 5 ) " Pattern matching failed"
5556 | Assert_failure (file , line , char ) ->
56- sprintf locfmt file line char (char + 6 ) " Assertion failed"
57+ locfmt file line char (char + 6 ) " Assertion failed"
5758 | Undefined_recursive_module (file , line , char ) ->
58- sprintf locfmt file line char (char + 6 ) " Undefined recursive module"
59+ locfmt file line char (char + 6 ) " Undefined recursive module"
5960 | _ ->
6061 let constructor =
6162 exn_slot_name x in
@@ -66,251 +67,16 @@ let print fct arg =
6667 try
6768 fct arg
6869 with x ->
69- eprintf " Uncaught exception: %s\n "
70- flush stderr;
70+ Js. log (" Uncaught exception: " ^ to_string x);
7171 raise x
7272
7373let catch fct arg =
7474 try
7575 fct arg
7676 with x ->
7777 flush stdout;
78- eprintf " Uncaught exception: %s \n " ( to_string x);
78+ Js. log ( " Uncaught exception: " ^ to_string x);
7979 exit 2
8080
81- type raw_backtrace_slot
82- type raw_backtrace
83-
84- external get_raw_backtrace :
85- unit -> raw_backtrace = " caml_get_exception_raw_backtrace"
86-
87- external raise_with_backtrace : exn -> raw_backtrace -> 'a
88- = " %raise_with_backtrace"
89-
90- type backtrace_slot =
91- | Known_location of {
92- is_raise : bool ;
93- filename : string ;
94- line_number : int ;
95- start_char : int ;
96- end_char : int ;
97- is_inline : bool ;
98- }
99- | Unknown_location of {
100- is_raise : bool
101- }
102-
103- (* to avoid warning *)
104- let _ = [Known_location { is_raise = false ; filename = " "
105- line_number = 0 ; start_char = 0 ; end_char = 0 ;
106- is_inline = false };
107- Unknown_location { is_raise = false }]
108-
109- #if BS
110- let convert_raw_backtrace_slot:
111- raw_backtrace_slot -> backtrace_slot =
112- fun _ -> failwith " convert_raw_backtrace_slot not implemented"
113- #else
114- external convert_raw_backtrace_slot :
115- raw_backtrace_slot -> backtrace_slot = " caml_convert_raw_backtrace_slot"
116- #end
117- external convert_raw_backtrace :
118- raw_backtrace -> backtrace_slot array = " caml_convert_raw_backtrace"
119-
120- let convert_raw_backtrace bt =
121- try Some (convert_raw_backtrace bt)
122- with Failure _ -> None
123-
124- let format_backtrace_slot pos slot =
125- let info is_raise =
126- if is_raise then
127- if pos = 0 then " Raised at" else " Re-raised at"
128- else
129- if pos = 0 then " Raised by primitive operation at" else " Called from"
130- in
131- match slot with
132- | Unknown_location l ->
133- if l.is_raise then
134- (* compiler-inserted re-raise, skipped *) None
135- else
136- Some (sprintf " %s unknown location" false ))
137- | Known_location l ->
138- Some (sprintf " %s file \" %s\" %s, line %d, characters %d-%d"
139- (info l.is_raise) l.filename
140- (if l.is_inline then " (inlined)" else " "
141- l.line_number l.start_char l.end_char)
142-
143- let print_exception_backtrace outchan backtrace =
144- match backtrace with
145- | None ->
146- fprintf outchan
147- " (Program not linked with -g, cannot print stack backtrace)\n "
148- | Some a ->
149- for i = 0 to Array. length a - 1 do
150- match format_backtrace_slot i a.(i) with
151- | None -> ()
152- | Some str -> fprintf outchan " %s\n "
153- done
154-
155- let print_raw_backtrace outchan raw_backtrace =
156- print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
157-
158- (* confusingly named: prints the global current backtrace *)
159- let print_backtrace outchan =
160- print_raw_backtrace outchan (get_raw_backtrace () )
161-
162- let backtrace_to_string backtrace =
163- match backtrace with
164- | None ->
165- " (Program not linked with -g, cannot print stack backtrace)\n "
166- | Some a ->
167- let b = Buffer. create 1024 in
168- for i = 0 to Array. length a - 1 do
169- match format_backtrace_slot i a.(i) with
170- | None -> ()
171- | Some str -> bprintf b " %s\n "
172- done ;
173- Buffer. contents b
174-
175- let raw_backtrace_to_string raw_backtrace =
176- backtrace_to_string (convert_raw_backtrace raw_backtrace)
177-
178- let backtrace_slot_is_raise = function
179- | Known_location l -> l.is_raise
180- | Unknown_location l -> l.is_raise
181-
182- let backtrace_slot_is_inline = function
183- | Known_location l -> l.is_inline
184- | Unknown_location _ -> false
185-
186- type location = {
187- filename : string ;
188- line_number : int ;
189- start_char : int ;
190- end_char : int ;
191- }
192-
193- let backtrace_slot_location = function
194- | Unknown_location _ -> None
195- | Known_location l ->
196- Some {
197- filename = l.filename;
198- line_number = l.line_number;
199- start_char = l.start_char;
200- end_char = l.end_char;
201- }
202-
203- let backtrace_slots raw_backtrace =
204- (* The documentation of this function guarantees that Some is
205- returned only if a part of the trace is usable. This gives us
206- a bit more work than just convert_raw_backtrace, but it makes the
207- API more user-friendly -- otherwise most users would have to
208- reimplement the "Program not linked with -g, sorry" logic
209- themselves. *)
210- match convert_raw_backtrace raw_backtrace with
211- | None -> None
212- | Some backtrace ->
213- let usable_slot = function
214- | Unknown_location _ -> false
215- | Known_location _ -> true in
216- let rec exists_usable = function
217- | (-1 ) -> false
218- | i -> usable_slot backtrace.(i) || exists_usable (i - 1 ) in
219- if exists_usable (Array. length backtrace - 1 )
220- then Some backtrace
221- else None
222-
223- module Slot = struct
224- type t = backtrace_slot
225- let format = format_backtrace_slot
226- let is_raise = backtrace_slot_is_raise
227- let is_inline = backtrace_slot_is_inline
228- let location = backtrace_slot_location
229- end
230-
231- external raw_backtrace_length :
232- raw_backtrace -> int = " caml_raw_backtrace_length" @@ noalloc]
233-
234- external get_raw_backtrace_slot :
235- raw_backtrace -> int -> raw_backtrace_slot = " caml_raw_backtrace_slot"
236-
237- external get_raw_backtrace_next_slot :
238- raw_backtrace_slot -> raw_backtrace_slot option
239- = " caml_raw_backtrace_next_slot"
240-
241- (* confusingly named:
242- returns the *string* corresponding to the global current backtrace *)
243- let get_backtrace () = raw_backtrace_to_string (get_raw_backtrace () )
244-
245- external record_backtrace : bool -> unit = " caml_record_backtrace"
246- external backtrace_status : unit -> bool = " caml_backtrace_status"
247-
24881let register_printer fn =
24982 printers := fn :: ! printers
250-
251- external get_callstack : int -> raw_backtrace = " caml_get_current_callstack"
252-
253-
254- #if BS
255- let set_uncaught_exception_handler _ = ()
256- #else
257- let uncaught_exception_handler = ref None
258-
259- let set_uncaught_exception_handler fn = uncaught_exception_handler := Some fn
260-
261- let empty_backtrace : raw_backtrace = Obj. obj (Obj. new_block Obj. abstract_tag 0 )
262-
263- let try_get_raw_backtrace () =
264- try
265- get_raw_backtrace ()
266- with _ (* Out_of_memory? *)
267- empty_backtrace
268-
269- let handle_uncaught_exception' exn debugger_in_use =
270- try
271- (* Get the backtrace now, in case one of the [at_exit] function
272- destroys it. *)
273- let raw_backtrace =
274- if debugger_in_use (* Same test as in [byterun/printexc.c] *) then
275- empty_backtrace
276- else
277- try_get_raw_backtrace ()
278- in
279- (try Pervasives. do_at_exit () with _ -> () );
280- match ! uncaught_exception_handler with
281- | None ->
282- eprintf " Fatal error: exception %s\n " exn );
283- print_raw_backtrace stderr raw_backtrace;
284- flush stderr
285- | Some handler ->
286- try
287- handler exn raw_backtrace
288- with exn ' ->
289- let raw_backtrace' = try_get_raw_backtrace () in
290- eprintf " Fatal error: exception %s\n " exn );
291- print_raw_backtrace stderr raw_backtrace;
292- eprintf " Fatal error in uncaught exception handler: exception %s\n "
293- (to_string exn ');
294- print_raw_backtrace stderr raw_backtrace';
295- flush stderr
296- with
297- | Out_of_memory ->
298- prerr_endline
299- " Fatal error: out of memory in uncaught exception handler"
300-
301- (* This function is called by [caml_fatal_uncaught_exception] in
302- [byterun/printexc.c] which expects no exception is raised. *)
303- let handle_uncaught_exception exn debugger_in_use =
304- try
305- handle_uncaught_exception' exn debugger_in_use
306- with _ ->
307- (* There is not much we can do at this point *)
308- ()
309-
310- external register_named_value : string -> 'a -> unit
311- = " caml_register_named_value"
312-
313- let () =
314- register_named_value " Printexc.handle_uncaught_exception"
315- handle_uncaught_exception
316- #end
0 commit comments