2016-02-18 07:11:59 -08:00
|
|
|
/**************************************************************************/
|
|
|
|
/* */
|
|
|
|
/* 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. */
|
|
|
|
/* */
|
|
|
|
/**************************************************************************/
|
1996-11-07 05:12:33 -08:00
|
|
|
|
2016-07-04 10:00:57 -07:00
|
|
|
#define CAML_INTERNALS
|
|
|
|
|
1996-11-07 05:12:33 -08:00
|
|
|
/* Print an uncaught exception and abort */
|
|
|
|
|
|
|
|
#include <stdio.h>
|
|
|
|
#include <stdlib.h>
|
1997-05-15 06:26:08 -07:00
|
|
|
#include <string.h>
|
2014-12-27 06:41:49 -08:00
|
|
|
#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"
|
2014-05-28 16:11:47 -07:00
|
|
|
#include "caml/memory.h"
|
1996-11-07 05:12:33 -08:00
|
|
|
|
1997-05-15 06:26:08 -07:00
|
|
|
struct stringbuf {
|
|
|
|
char * ptr;
|
|
|
|
char * end;
|
|
|
|
char data[256];
|
|
|
|
};
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void add_char(struct stringbuf *buf, char c)
|
1997-05-15 06:26:08 -07:00
|
|
|
{
|
|
|
|
if (buf->ptr < buf->end) *(buf->ptr++) = c;
|
|
|
|
}
|
|
|
|
|
2017-08-03 06:19:13 -07:00
|
|
|
static void add_string(struct stringbuf *buf, const char *s)
|
1997-05-15 06:26:08 -07:00
|
|
|
{
|
Cleaning up the C code (#1812)
Running Clang 6.0 and GCC 8 with full warnings on suggests a few simple improvements and clean-ups to the C code of OCaml. This commit implements them.
* Remove old-style, unprototyped function declarations
It's `int f(void)`, not `int f()`. [-Wstrict-prototypes]
* Be more explicit about conversions involving `float` and `double`
byterun/bigarray.c, byterun/ints.c:
add explicit casts to clarify the intent
renamed float field of conversion union from `d` to `f`.
byterun/compact.c, byterun/gc_ctrl.c:
some local variables were of type `float` while all FP computations
here are done in double precision;
turned these variables into `double`.
[-Wdouble-promotion -Wfloat-conversion]
*Add explicit initialization of struct field `compare_ext`
[-Wmissing-field-initializers]
* Declare more functions "noreturn"
[-Wmissing-noreturn]
* Make CAMLassert compliant with ISO C
In `e1 ? e2 : e3`, expressions `e2` and `e3` must have the same type.
`e2` of type `void` and `e3` of type `int`, as in the original code,
is a GNU extension.
* Remove or conditionalize unused macros
Some macros were defined and never used.
Some other macros were always defined but conditionally used.
[-Wunused-macros]
* Replace some uses of `int` by more appropriate types like `intnat`
On a 64-bit platform, `int` is only 32 bits and may not represent correctly
the length of a string or the size of an OCaml heap block.
This commit replaces a number of uses of `int` by other types that
are 64-bit wide on 64-bit architectures, such as `intnat` or `uintnat`
or `size_t` or `mlsize_t`.
Sometimes an `intnat` was used as an `int` and is intended as a Boolean
(0 or 1); then it was replaced by an `int`.
There are many remaining cases where we assign a 64-bit quantity to a
32-bit `int` variable. Either I believe these cases are safe
(e.g. the 64-bit quantity is the difference between two pointers
within an I/O buffer, something that always fits in 32 bits), or
the code change was not obvious and too risky.
[-Wshorten-64-to-32]
* Put `inline` before return type
`static inline void f(void)` is cleaner than `static void inline f(void)`.
[-Wold-style-declaration]
* Unused assignment to unused parameter
Looks very useless. [-Wunused-but-set-parameter]
2018-06-07 03:55:09 -07:00
|
|
|
size_t len = strlen(s);
|
1997-05-15 06:26:08 -07:00
|
|
|
if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
|
2000-10-12 11:05:42 -07:00
|
|
|
if (len > 0) memmove(buf->ptr, s, len);
|
1997-05-15 06:26:08 -07:00
|
|
|
buf->ptr += len;
|
|
|
|
}
|
2010-01-22 04:48:24 -08:00
|
|
|
|
2004-01-01 08:42:43 -08:00
|
|
|
CAMLexport char * caml_format_exception(value exn)
|
1996-11-07 05:12:33 -08:00
|
|
|
{
|
1997-05-15 06:26:08 -07:00
|
|
|
mlsize_t start, i;
|
|
|
|
value bucket, v;
|
|
|
|
struct stringbuf buf;
|
|
|
|
char intbuf[64];
|
1999-02-18 08:26:16 -08:00
|
|
|
char * res;
|
1996-11-07 05:12:33 -08:00
|
|
|
|
1997-05-15 06:26:08 -07:00
|
|
|
buf.ptr = buf.data;
|
|
|
|
buf.end = buf.data + sizeof(buf.data) - 1;
|
2013-10-23 07:28:31 -07:00
|
|
|
if (Tag_val(exn) == 0) {
|
2013-10-18 06:00:58 -07:00
|
|
|
add_string(&buf, String_val(Field(Field(exn, 0), 0)));
|
1997-05-15 06:26:08 -07:00
|
|
|
/* Check for exceptions in the style of Match_failure and Assert_failure */
|
|
|
|
if (Wosize_val(exn) == 2 &&
|
|
|
|
Is_block(Field(exn, 1)) &&
|
2011-09-08 01:34:43 -07:00
|
|
|
Tag_val(Field(exn, 1)) == 0 &&
|
|
|
|
caml_is_special_exception(Field(exn, 0))) {
|
1997-05-15 06:26:08 -07:00
|
|
|
bucket = Field(exn, 1);
|
|
|
|
start = 0;
|
|
|
|
} else {
|
|
|
|
bucket = exn;
|
|
|
|
start = 1;
|
1996-11-07 05:12:33 -08:00
|
|
|
}
|
1997-05-15 06:26:08 -07:00
|
|
|
add_char(&buf, '(');
|
|
|
|
for (i = start; i < Wosize_val(bucket); i++) {
|
|
|
|
if (i > start) add_string(&buf, ", ");
|
|
|
|
v = Field(bucket, i);
|
|
|
|
if (Is_long(v)) {
|
2014-04-15 10:09:13 -07:00
|
|
|
snprintf(intbuf, sizeof(intbuf),
|
|
|
|
"%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
|
1997-05-15 06:26:08 -07:00
|
|
|
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, ')');
|
2013-10-18 06:00:58 -07:00
|
|
|
} else
|
|
|
|
add_string(&buf, String_val(Field(exn, 0)));
|
|
|
|
|
1997-05-15 06:26:08 -07:00
|
|
|
*buf.ptr = 0; /* Terminate string */
|
1999-02-18 08:26:16 -08:00
|
|
|
i = buf.ptr - buf.data + 1;
|
2014-05-28 16:11:47 -07:00
|
|
|
res = caml_stat_alloc_noexc(i);
|
1999-02-18 08:26:16 -08:00
|
|
|
if (res == NULL) return NULL;
|
2000-10-12 11:05:42 -07:00
|
|
|
memmove(res, buf.data, i);
|
1999-02-18 08:26:16 -08:00
|
|
|
return res;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2014-04-18 08:36:08 -07:00
|
|
|
#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)
|
1999-02-18 08:26:16 -08:00
|
|
|
{
|
2001-10-30 01:22:49 -08:00
|
|
|
char * msg;
|
2019-03-06 01:00:38 -08:00
|
|
|
const value * at_exit;
|
2001-10-30 01:22:49 -08:00
|
|
|
int saved_backtrace_active, saved_backtrace_pos;
|
2007-01-29 04:11:18 -08:00
|
|
|
|
2001-10-30 01:22:49 -08:00
|
|
|
/* Build a string representation of the exception */
|
2004-01-01 08:42:43 -08:00
|
|
|
msg = caml_format_exception(exn);
|
2001-10-30 01:22:49 -08:00
|
|
|
/* Perform "at_exit" processing, ignoring all exceptions that may
|
|
|
|
be triggered by this */
|
2003-12-31 06:20:40 -08:00
|
|
|
saved_backtrace_active = caml_backtrace_active;
|
|
|
|
saved_backtrace_pos = caml_backtrace_pos;
|
|
|
|
caml_backtrace_active = 0;
|
2001-10-30 01:22:49 -08:00
|
|
|
at_exit = caml_named_value("Pervasives.do_at_exit");
|
2003-12-31 06:20:40 -08:00
|
|
|
if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit);
|
|
|
|
caml_backtrace_active = saved_backtrace_active;
|
|
|
|
caml_backtrace_pos = saved_backtrace_pos;
|
2001-10-30 01:22:49 -08:00
|
|
|
/* Display the uncaught exception */
|
2001-12-03 02:14:09 -08:00
|
|
|
fprintf(stderr, "Fatal error: exception %s\n", msg);
|
2014-05-28 16:11:47 -07:00
|
|
|
caml_stat_free(msg);
|
2001-10-30 01:22:49 -08:00
|
|
|
/* Display the backtrace if available */
|
2014-04-18 08:36:08 -07:00
|
|
|
if (caml_backtrace_active && !DEBUGGER_IN_USE)
|
2003-12-31 06:20:40 -08:00
|
|
|
caml_print_exception_backtrace();
|
2014-04-18 08:36:08 -07:00
|
|
|
}
|
|
|
|
|
2016-12-06 08:18:04 -08:00
|
|
|
int caml_abort_on_uncaught_exn = 0; /* see afl.c */
|
|
|
|
|
2014-04-18 08:36:08 -07:00
|
|
|
void caml_fatal_uncaught_exception(value exn)
|
|
|
|
{
|
2019-03-06 01:00:38 -08:00
|
|
|
const value *handle_uncaught_exception;
|
2014-04-18 08:36:08 -07:00
|
|
|
|
2014-08-22 06:45:02 -07:00
|
|
|
handle_uncaught_exception =
|
|
|
|
caml_named_value("Printexc.handle_uncaught_exception");
|
2014-04-18 08:36:08 -07:00
|
|
|
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);
|
2001-10-30 01:22:49 -08:00
|
|
|
/* Terminate the process */
|
2016-12-06 08:18:04 -08:00
|
|
|
if (caml_abort_on_uncaught_exn) {
|
|
|
|
abort();
|
|
|
|
} else {
|
2018-07-03 10:22:51 -07:00
|
|
|
exit(2);
|
2016-12-06 08:18:04 -08:00
|
|
|
}
|
1996-11-07 05:12:33 -08:00
|
|
|
}
|