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); }