CAMLprim value caml_array_get_addr(value array, value index)
{
CAMLparam2(array, index);
CAMLlocal1(x);
intnat idx = Long_val(index);
if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
caml_read_field(array, idx, &x);
CAMLreturn (x);
}
CAMLexport value caml_read_root(caml_root root)
{
value v = (value)root;
value x;
Assert(root);
Assert(Hd_val(root));
Assert(Int_field(v,1) == 0 || Int_field(v,1) == 1);
caml_read_field(v, 0, &x);
return x;
}
static void print_token(struct parser_tables *tables, int state, value tok)
{
CAMLparam1 (tok);
CAMLlocal1 (v);
if (Is_long(tok)) {
fprintf(stderr, "State %d: read token %s\n",
state, token_name(tables->names_const, Int_val(tok)));
} else {
fprintf(stderr, "State %d: read token %s(",
state, token_name(tables->names_block, Tag_val(tok)));
caml_read_field(tok, 0, &v);
if (Is_long(v))
fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
else if (Tag_val(v) == String_tag)
fprintf(stderr, "%s", String_val(v));
else if (Tag_val(v) == Double_tag)
fprintf(stderr, "%g", Double_val(v));
else
fprintf(stderr, "_");
fprintf(stderr, ")\n");
}
CAMLreturn0;
}
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);
}
