static void read_main_debug_info(struct debug_info *di)
{
CAMLparam0();
CAMLlocal3(events, evl, l);
char_os *exec_name;
int fd, num_events, orig, i;
struct channel *chan;
struct exec_trailer trail;
CAMLassert(di->already_read == 0);
di->already_read = 1;
if (caml_params->cds_file != NULL) {
exec_name = (char_os*) caml_params->cds_file;
} else {
exec_name = (char_os*) caml_params->exe_name;
}
fd = caml_attempt_open(&exec_name, &trail, 1);
if (fd < 0){
caml_fatal_error ("executable program file not found");
CAMLreturn0;
}
caml_read_section_descriptors(fd, &trail);
if (caml_seek_optional_section(fd, &trail, "DBUG") != -1) {
chan = caml_open_descriptor_in(fd);
num_events = caml_getword(chan);
events = caml_alloc(num_events, 0);
for (i = 0; i < num_events; i++) Op_val(events)[i] = Val_unit;
for (i = 0; i < num_events; i++) {
orig = caml_getword(chan);
evl = caml_input_val(chan);
caml_input_val(chan); /* Skip the list of absolute directory names */
/* Relocate events in event list */
for (l = evl; l != Val_int(0); l = Field_imm(l, 1)) {
value ev = Field_imm(l, 0);
Store_field (ev, EV_POS, Val_long(Long_val(Field(ev, EV_POS)) + orig));
}
/* Record event list */
Store_field(events, i, evl);
}
caml_close_channel(chan);
di->events = process_debug_events(caml_start_code, events, &di->num_events);
}
CAMLreturn0;
}
CAMLprim value caml_gr_wait_event(value eventlist) /* ML */
{
int mask, poll;
gr_check_open();
mask = 0;
poll = 0;
while (eventlist != Val_int(0)) {
switch (Int_field(eventlist, 0)) {
case 0: /* Button_down */
mask |= EVENT_BUTTON_DOWN; break;
case 1: /* Button_up */
mask |= EVENT_BUTTON_UP; break;
case 2: /* Key_pressed */
mask |= EVENT_KEY_PRESSED; break;
case 3: /* Mouse_motion */
mask |= EVENT_MOUSE_MOTION; break;
case 4: /* Poll */
poll = 1; break;
}
eventlist = Field_imm(eventlist, 1);
}
if (poll)
return caml_gr_wait_event_poll();
else
return caml_gr_wait_event_blocking(mask);
}
value caml_gr_wait_event(value eventlist) /* ML */
{
int mask;
Bool poll;
caml_gr_check_open();
mask = 0;
poll = False;
while (eventlist != Val_int(0)) {
switch (Int_field(eventlist, 0)) {
case 0: /* Button_down */
mask |= ButtonPressMask | OwnerGrabButtonMask; break;
case 1: /* Button_up */
mask |= ButtonReleaseMask | OwnerGrabButtonMask; break;
case 2: /* Key_pressed */
mask |= KeyPressMask; break;
case 3: /* Mouse_motion */
mask |= PointerMotionMask; break;
case 4: /* Poll */
poll = True; break;
}
eventlist = Field_imm(eventlist, 1);
}
if (poll)
return caml_gr_wait_event_poll();
else
return caml_gr_wait_event_blocking(mask);
}
static struct ev_info *process_debug_events(code_t code_start, value events_heap,
mlsize_t *num_events)
{
CAMLparam1(events_heap);
CAMLlocal3(l, ev, ev_start);
mlsize_t i, j;
struct ev_info *events;
/* Compute the size of the required event buffer. */
*num_events = 0;
for (i = 0; i < caml_array_length(events_heap); i++)
for (l = Field_imm(events_heap, i); l != Val_int(0); l = Field_imm(l, 1))
(*num_events)++;
if (*num_events == 0)
CAMLreturnT(struct ev_info *, NULL);
events = caml_stat_alloc_noexc(*num_events * sizeof(struct ev_info));
if(events == NULL)
caml_fatal_error ("caml_add_debug_info: out of memory");
j = 0;
for (i = 0; i < caml_array_length(events_heap); i++) {
for (l = Field_imm(events_heap, i); l != Val_int(0); l = Field_imm(l, 1)) {
ev = Field_imm(l, 0);
events[j].ev_pc = (code_t)((char*)code_start
+ Long_val(Field_imm(ev, EV_POS)));
ev_start = Field(Field(ev, EV_LOC), LOC_START);
{
uintnat fnsz = caml_string_length(Field_imm(ev_start, POS_FNAME)) + 1;
events[j].ev_filename = (char*)caml_stat_alloc_noexc(fnsz);
if(events[j].ev_filename == NULL)
caml_fatal_error ("caml_add_debug_info: out of memory");
memcpy(events[j].ev_filename,
String_val(Field(ev_start, POS_FNAME)),
fnsz);
}
events[j].ev_lnum = Int_val(Field(ev_start, POS_LNUM));
events[j].ev_startchr =
Int_val(Field(ev_start, POS_CNUM))
- Int_val(Field(ev_start, POS_BOL));
events[j].ev_endchr =
Int_val(Field(Field(Field(ev, EV_LOC), LOC_END), POS_CNUM))
- Int_val(Field(ev_start, POS_BOL));
j++;
}
}
CAMLassert(j == *num_events);
qsort(events, *num_events, sizeof(struct ev_info), cmp_ev_info);
CAMLreturnT(struct ev_info *, events);
}
CAMLexport char * caml_format_exception(value exn)
{
mlsize_t start, i;
struct stringbuf buf;
char intbuf[64];
char * res;
CAMLparam1(exn);
CAMLlocal4(bucket, v, exnclass, field1);
buf.ptr = buf.data;
buf.end = buf.data + sizeof(buf.data) - 1;
/* An exception class is a value with tag Object_tag, whose first
field is a string naming the exception.
Exceptions that take parameters (e.g. Invalid_argument) are blocks
with tag 0, where the first field is the exception class.
Exceptions without parameters (e.g. Not_found) are just the exception
class. */
if (Tag_val(exn) == 0) {
/* Field 0 of exn is the exception class, which is immutable */
exnclass = Field_imm(exn, 0);
add_string(&buf, String_val(Field_imm(exnclass, 0)));
/* Check for exceptions in the style of Match_failure and Assert_failure */
if (Wosize_val(exn) == 2) {
caml_read_field(exn, 1, &field1);
} else {
field1 = Val_unit;
}
if (Is_block(field1) &&
Tag_val(field1) == 0 &&
caml_is_special_exception(exnclass)) {
bucket = field1;
start = 0;
} else {
bucket = exn;
start = 1;
}
add_char(&buf, '(');
for (i = start; i < Wosize_val(bucket); i++) {
if (i > start) add_string(&buf, ", ");
caml_read_field(bucket, i, &v);
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 {
/* Exception without parameters */
exnclass = exn;
add_string(&buf, String_val(Field_imm(exnclass, 0)));
}
*buf.ptr = 0; /* Terminate string */
i = buf.ptr - buf.data + 1;
res = malloc(i);
if (res == NULL) CAMLreturnT (char*, NULL);
memmove(res, buf.data, i);
CAMLreturnT (char*, res);
}
