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
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* 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 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 = function
| 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"
| x ->
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 ->
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"
|
