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
|
/**************************************************************************/
/* */
/* 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 Lesser General Public License version 2.1, with the */
/* special exception on linking described in the file LICENSE. */
/* */
/**************************************************************************/
#define CAML_INTERNALS
/* Print an uncaught exception and abort */
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "caml/backtrace.h"
#include "caml/callback.h"
#include "caml/debugger.h"
#include "caml/fail.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/printexc.h"
#include "caml/memory.h"
#include "caml/memprof.h"
struct stringbuf {
char * ptr;
char * end;
char data[256];
};
static void add_char(struct stringbuf *buf, char c)
{
if (buf->ptr < buf->end) *(buf->ptr++) = c;
}
static void add_string(struct stringbuf *buf, const char *s)
{
size_t len = strlen(s);
if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
if (len > 0) memmove(buf->ptr, s, len);
buf->ptr += len;
}
CAMLexport char * caml_format_exception(value exn)
{
Caml_check_caml_state();
mlsize_t start, len;
value bucket, v;
struct stringbuf buf;
char intbuf[64];
char * res;
buf.ptr = buf.data;
buf.end = buf.data + sizeof(buf.data) - 1;
if (Tag_val(exn) == 0) {
add_string(&buf, String_val(Field(Field(exn, 0), 0)));
/* Check for exceptions in the style of Match_failure and Assert_failure */
if (Wosize_val(exn) == 2 &&
Is_block(Field(exn, 1)) &&
Tag_val(Field(exn, 1)) == 0 &&
caml_is_special_exception(Field(exn, 0))) {
bucket = Field(exn, 1);
start = 0;
} else {
bucket = exn;
start = 1;
}
add_char(&buf, '(');
for (mlsize_t i = start; i < Wosize_val(bucket); i++) {
if (i > start) add_string(&buf, ", ");
v = Field(bucket, i);
if (Is_long(v)) {
snprintf(intbuf, sizeof(intbuf),
"%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
add_string(&buf, intbuf);
} else if (Tag_val(v) == String_tag) {
add_char(&buf, '"');
add_string(&buf, String_val(v));
add_char(&buf, '"');
} else {
add_char(&buf, '_');
}
}
add_char(&buf, ')');
} else
add_string(&buf, String_val(Field(exn, 0)));
*buf.ptr = 0; /* Terminate string */
len = buf.ptr - buf.data + 1;
res = caml_stat_alloc_noexc(len);
if (res == NULL) return NULL;
memmove(res, buf.data, len);
return res;
}
#ifdef NATIVE_CODE
# define DEBUGGER_IN_USE 0
#else
# define DEBUGGER_IN_USE caml_debugger_in_use
#endif
/* Default C implementation in case the OCaml one is not registered. */
static void default_fatal_uncaught_exception(value exn)
{
char * msg;
const value * at_exit;
int saved_backtrace_active, saved_backtrace_pos;
/* Build a string representation of the exception */
msg = caml_format_exception(exn);
/* Perform "at_exit" processing, ignoring all exceptions that may
be triggered by this */
saved_backtrace_active = Caml_state->backtrace_active;
saved_backtrace_pos = Caml_state->backtrace_pos;
Caml_state->backtrace_active = 0;
at_exit = caml_named_value("Pervasives.do_at_exit");
if (at_exit != NULL) caml_callback_res(*at_exit, Val_unit);
Caml_state->backtrace_active = saved_backtrace_active;
Caml_state->backtrace_pos = saved_backtrace_pos;
/* Display the uncaught exception */
fprintf(stderr, "Fatal error: exception %s\n", msg);
caml_stat_free(msg);
/* Display the backtrace if available */
if (!DEBUGGER_IN_USE && Caml_state->backtrace_active)
caml_print_exception_backtrace();
}
int caml_abort_on_uncaught_exn = 0; /* see afl.c */
void caml_fatal_uncaught_exception(value exn)
{
const value *handle_uncaught_exception;
handle_uncaught_exception =
caml_named_value("Printexc.handle_uncaught_exception");
/* If the callback allocates, memprof could be called, in which case
a memprof callback could raise an exception while
[handle_uncaught_exception] is running, and the printing of
the exception could fail. */
caml_memprof_update_suspended(true);
if (handle_uncaught_exception != NULL)
/* [Printexc.handle_uncaught_exception] does not raise exception. */
caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));
else
default_fatal_uncaught_exception(exn);
/* Terminate the process */
if (caml_abort_on_uncaught_exn) {
abort();
} else {
exit(2);
}
}
|