1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License, with *)
(* the special exception on linking described in file ../LICENSE. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Printf;;
let printers = ref []
let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s";;
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 = Obj.string_tag then
sprintf "%S" (Obj.magic f : string)
else if Obj.tag f = Obj.double_tag 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 x =
let rec conv = function
| hd :: tl ->
(match try hd x with _ -> None with
| Some s -> s
| None -> conv tl)
| [] ->
match x with
| Out_of_memory -> "Out of memory"
| Stack_overflow -> "Stack overflow"
| Match_failure(file, line, char) ->
sprintf locfmt file line char (char+5) "Pattern matching failed"
| Assert_failure(file, line, char) ->
sprintf locfmt file line char (char+6) "Assertion failed"
| Undefined_recursive_module(file, line, char) ->
sprintf locfmt file line char (char+6) "Undefined recursive module"
| _ ->
let x = Obj.repr x in
let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
constructor ^ (fields x) in
conv !printers
let print fct arg =
try
fct arg
with x ->
eprintf "Uncaught exception: %s\n" (to_string x);
flush stderr;
raise x
let catch fct arg =
try
fct arg
with x ->
flush stdout;
eprintf "Uncaught exception: %s\n" (to_string x);
exit 2
type loc_info =
| Known_location of bool (* is_raise *)
* string (* filename *)
* int (* line number *)
* int (* start char *)
* int (* end char *)
| Unknown_location of bool (*is_raise*)
external get_exception_backtrace:
unit -> loc_info array option = "caml_get_exception_backtrace"
let format_loc_info pos li =
let is_raise =
match li with
| Known_location(is_raise, _, _, _, _) -> is_raise
| Unknown_location(is_raise) -> is_raise in
let info =
if is_raise then
if pos = 0 then "Raised at" else "Re-raised at"
else
if pos = 0 then "Raised by primitive operation at" else "Called from"
in
match li with
| Known_location(is_raise, filename, lineno, startchar, endchar) ->
sprintf "%s file \"%s\", line %d, characters %d-%d"
info filename lineno startchar endchar
| Unknown_location(is_raise) ->
sprintf "%s unknown location"
info
let print_backtrace outchan =
match get_exception_backtrace() with
| None ->
fprintf outchan
"(Program not linked with -g, cannot print stack backtrace)\n"
| Some a ->
for i = 0 to Array.length a - 1 do
if a.(i) <> Unknown_location true then
fprintf outchan "%s\n" (format_loc_info i a.(i))
done
let get_backtrace () =
match get_exception_backtrace() with
| None ->
"(Program not linked with -g, cannot print stack backtrace)\n"
| Some a ->
let b = Buffer.create 1024 in
for i = 0 to Array.length a - 1 do
if a.(i) <> Unknown_location true then
bprintf b "%s\n" (format_loc_info i a.(i))
done;
Buffer.contents b
external record_backtrace: bool -> unit = "caml_record_backtrace"
external backtrace_status: unit -> bool = "caml_backtrace_status"
let register_printer fn =
printers := fn :: !printers
|
