/usr/x86_64-w64-mingw32/lib/ocaml/printexc.ml is in ocaml-mingw-w64-x86-64 4.01.0~20140328-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | (***********************************************************************)
(* *)
(* 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. *)
(* *)
(***********************************************************************)
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 raw_backtrace
external get_raw_backtrace:
unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
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*)
(* to avoid warning *)
let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
type backtrace = loc_info array
external convert_raw_backtrace:
raw_backtrace -> backtrace option = "caml_convert_raw_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_exception_backtrace outchan backtrace =
match 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 print_raw_backtrace outchan raw_backtrace =
print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
(* confusingly named: prints the global current backtrace *)
let print_backtrace outchan =
print_raw_backtrace outchan (get_raw_backtrace ())
let backtrace_to_string backtrace =
match 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
let raw_backtrace_to_string raw_backtrace =
backtrace_to_string (convert_raw_backtrace raw_backtrace)
(* confusingly named:
returns the *string* corresponding to the global current backtrace *)
let get_backtrace () =
(* we could use the caml_get_exception_backtrace primitive here, but
we hope to deprecate it so it's better to just compose the
raw stuff *)
backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
external record_backtrace: bool -> unit = "caml_record_backtrace"
external backtrace_status: unit -> bool = "caml_backtrace_status"
let register_printer fn =
printers := fn :: !printers
external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
|