1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Print an uncaught exception and abort */
19
20 #include <stdio.h>
21 #include <stdlib.h>
22 #include <string.h>
23 #include "caml/backtrace.h"
24 #include "caml/callback.h"
25 #include "caml/debugger.h"
26 #include "caml/fail.h"
27 #include "caml/misc.h"
28 #include "caml/mlvalues.h"
29 #include "caml/printexc.h"
30
31 struct stringbuf {
32 char * ptr;
33 char * end;
34 char data[256];
35 };
36
add_char(struct stringbuf * buf,char c)37 static void add_char(struct stringbuf *buf, char c)
38 {
39 if (buf->ptr < buf->end) *(buf->ptr++) = c;
40 }
41
add_string(struct stringbuf * buf,char * s)42 static void add_string(struct stringbuf *buf, char *s)
43 {
44 int len = strlen(s);
45 if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
46 if (len > 0) memmove(buf->ptr, s, len);
47 buf->ptr += len;
48 }
49
caml_format_exception(value exn)50 CAMLexport char * caml_format_exception(value exn)
51 {
52 mlsize_t start, i;
53 value bucket, v;
54 struct stringbuf buf;
55 char intbuf[64];
56 char * res;
57
58 buf.ptr = buf.data;
59 buf.end = buf.data + sizeof(buf.data) - 1;
60 if (Tag_val(exn) == 0) {
61 add_string(&buf, String_val(Field(Field(exn, 0), 0)));
62 /* Check for exceptions in the style of Match_failure and Assert_failure */
63 if (Wosize_val(exn) == 2 &&
64 Is_block(Field(exn, 1)) &&
65 Tag_val(Field(exn, 1)) == 0 &&
66 caml_is_special_exception(Field(exn, 0))) {
67 bucket = Field(exn, 1);
68 start = 0;
69 } else {
70 bucket = exn;
71 start = 1;
72 }
73 add_char(&buf, '(');
74 for (i = start; i < Wosize_val(bucket); i++) {
75 if (i > start) add_string(&buf, ", ");
76 v = Field(bucket, i);
77 if (Is_long(v)) {
78 snprintf(intbuf, sizeof(intbuf),
79 "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
80 add_string(&buf, intbuf);
81 } else if (Tag_val(v) == String_tag) {
82 add_char(&buf, '"');
83 add_string(&buf, String_val(v));
84 add_char(&buf, '"');
85 } else {
86 add_char(&buf, '_');
87 }
88 }
89 add_char(&buf, ')');
90 } else
91 add_string(&buf, String_val(Field(exn, 0)));
92
93 *buf.ptr = 0; /* Terminate string */
94 i = buf.ptr - buf.data + 1;
95 res = malloc(i);
96 if (res == NULL) return NULL;
97 memmove(res, buf.data, i);
98 return res;
99 }
100
101
102 #ifdef NATIVE_CODE
103 # define DEBUGGER_IN_USE 0
104 #else
105 # define DEBUGGER_IN_USE caml_debugger_in_use
106 #endif
107
108 /* Default C implementation in case the OCaml one is not registered. */
default_fatal_uncaught_exception(value exn)109 static void default_fatal_uncaught_exception(value exn)
110 {
111 char * msg;
112 value * at_exit;
113 int saved_backtrace_active, saved_backtrace_pos;
114
115 /* Build a string representation of the exception */
116 msg = caml_format_exception(exn);
117 /* Perform "at_exit" processing, ignoring all exceptions that may
118 be triggered by this */
119 saved_backtrace_active = caml_backtrace_active;
120 saved_backtrace_pos = caml_backtrace_pos;
121 caml_backtrace_active = 0;
122 at_exit = caml_named_value("Pervasives.do_at_exit");
123 if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit);
124 caml_backtrace_active = saved_backtrace_active;
125 caml_backtrace_pos = saved_backtrace_pos;
126 /* Display the uncaught exception */
127 fprintf(stderr, "Fatal error: exception %s\n", msg);
128 free(msg);
129 /* Display the backtrace if available */
130 if (caml_backtrace_active && !DEBUGGER_IN_USE)
131 caml_print_exception_backtrace();
132 }
133
134 int caml_abort_on_uncaught_exn = 0; /* see afl.c */
135
caml_fatal_uncaught_exception(value exn)136 void caml_fatal_uncaught_exception(value exn)
137 {
138 value *handle_uncaught_exception;
139
140 handle_uncaught_exception =
141 caml_named_value("Printexc.handle_uncaught_exception");
142 if (handle_uncaught_exception != NULL)
143 /* [Printexc.handle_uncaught_exception] does not raise exception. */
144 caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));
145 else
146 default_fatal_uncaught_exception(exn);
147 /* Terminate the process */
148 if (caml_abort_on_uncaught_exn) {
149 abort();
150 } else {
151 CAML_SYS_EXIT(2);
152 exit(2); /* Second exit needed for the Noreturn flag */
153 }
154 }
155