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 decode_terminal_status(value v, int field)
{
long * pc;
int i;
for (pc = terminal_io_descr; *pc != End; field++) {
switch(*pc++) {
case Bool:
{ int * dst = (int *) (*pc++);
int msk = *pc++;
if (Bool_field(v, field))
*dst |= msk;
else
*dst &= ~msk;
break; }
case Enum:
{ int * dst = (int *) (*pc++);
int ofs = *pc++;
int num = *pc++;
int msk = *pc++;
i = Int_field(v, field) - ofs;
if (i >= 0 && i < num) {
*dst = (*dst & ~msk) | pc[i];
} else {
unix_error(EINVAL, "tcsetattr", Nothing);
}
pc += num;
break; }
case Speed:
{ int which = *pc++;
int baud = Int_field(v, field);
int res = 0;
for (i = 0; i < NSPEEDS; i++) {
if (baud == speedtable[i].baud) {
switch (which) {
case Output:
res = cfsetospeed(&terminal_status, speedtable[i].speed); break;
case Input:
res = cfsetispeed(&terminal_status, speedtable[i].speed); break;
}
if (res == -1) uerror("tcsetattr", Nothing);
goto ok;
}
}
unix_error(EINVAL, "tcsetattr", Nothing);
ok:
break; }
case Char:
{ int which = *pc++;
terminal_status.c_cc[which] = Int_field(v, field);
break; }
}
}
}
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);
}
void caml_cleanup_deleted_roots()
{
value r, prev;
int first = 1;
caml_plat_lock(&roots_mutex);
r = roots_all;
while (Is_block(r)) {
Assert(!Is_foreign(Op_val(r)[2]));
value next = Op_val(r)[2];
if (Int_field(r, 1) == 0) {
/* root was deleted, remove from list */
if (first) {
roots_all = next;
} else {
caml_modify_field(prev, 2, next);
}
}
prev = r;
first = 0;
r = next;
}
caml_plat_unlock(&roots_mutex);
}
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);
}
CAMLprim value unix_error_message(value err)
{
int errnum;
wchar_t buffer[512];
errnum = Is_block(err) ? Int_field(err, 0) : error_table[Int_val(err)];
if (errnum > 0)
return caml_copy_string(strerror(errnum));
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL,
-errnum,
0,
buffer,
sizeof(buffer)/sizeof(wchar_t),
NULL))
return caml_copy_string_of_utf16(buffer);
swprintf(buffer, sizeof(buffer)/sizeof(wchar_t), L"unknown error #%d", errnum);
return caml_copy_string_of_utf16(buffer);
}
CAMLprim value unix_error_message(value err)
{
int errnum;
errnum = Is_block(err) ? Int_field(err, 0) : error_table[Int_val(err)];
return caml_copy_string(strerror(errnum));
}
CAMLprim value caml_parse_engine(struct parser_tables *tables,
struct parser_env *env, value cmd, value arg)
{
int state;
mlsize_t sp, asp;
int errflag;
int n, n1, n2, m, state1;
switch(Int_val(cmd)) {
case START:
state = 0;
sp = Int_val(env->sp);
errflag = 0;
loop:
n = Short(tables->defred, state);
if (n != 0) goto reduce;
if (Int_val(env->curr_char) >= 0) goto testshift;
SAVE;
return READ_TOKEN;
/* The ML code calls the lexer and updates */
/* symb_start and symb_end */
case TOKEN_READ:
RESTORE;
if (Is_block(arg)) {
env->curr_char = Val_int(Int_field(tables->transl_block, Tag_val(arg)));
caml_modify_field((value)env,
offsetof(struct parser_env, lval) / sizeof(value),
Field(arg, 0));
} else {
env->curr_char = Val_int(Int_field(tables->transl_const, Int_val(arg)));
caml_modify_field((value)env,
offsetof(struct parser_env, lval) / sizeof(value),
Val_long(0));
}
if (trace()) print_token(tables, state, arg);
testshift:
n1 = Short(tables->sindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) goto shift;
n1 = Short(tables->rindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) {
n = Short(tables->table, n2);
goto reduce;
}
if (errflag > 0) goto recover;
SAVE;
return CALL_ERROR_FUNCTION;
/* The ML code calls the error function */
case ERROR_DETECTED:
RESTORE;
recover:
if (errflag < 3) {
errflag = 3;
while (1) {
state1 = Int_field(env->s_stack, sp);
n1 = Short(tables->sindex, state1);
n2 = n1 + ERRCODE;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == ERRCODE) {
if (trace())
fprintf(stderr, "Recovering in state %d\n", state1);
goto shift_recover;
} else {
if (trace()){
fprintf(stderr, "Discarding state %d\n", state1);
}
if (sp <= Int_val(env->stackbase)) {
if (trace()){
fprintf(stderr, "No more states to discard\n");
}
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
}
sp--;
}
}
} else {
if (Int_val(env->curr_char) == 0)
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
if (trace()) fprintf(stderr, "Discarding last token read\n");
env->curr_char = Val_int(-1);
goto loop;
}
shift:
env->curr_char = Val_int(-1);
if (errflag > 0) errflag--;
shift_recover:
if (trace())
fprintf(stderr, "State %d: shift to state %d\n",
state, Short(tables->table, n2));
state = Short(tables->table, n2);
sp++;
if (sp < Long_val(env->stacksize)) goto push;
SAVE;
return GROW_STACKS_1;
/* The ML code resizes the stacks */
case STACKS_GROWN_1:
RESTORE;
push:
Store_field (env->s_stack, sp, Val_int(state));
Store_field (env->v_stack, sp, env->lval);
Store_field (env->symb_start_stack, sp, env->symb_start);
Store_field (env->symb_end_stack, sp, env->symb_end);
goto loop;
reduce:
if (trace())
fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
m = Short(tables->len, n);
env->asp = Val_int(sp);
env->rule_number = Val_int(n);
env->rule_len = Val_int(m);
sp = sp - m + 1;
m = Short(tables->lhs, n);
state1 = Int_field(env->s_stack, sp - 1);
n1 = Short(tables->gindex, m);
n2 = n1 + state1;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == state1) {
state = Short(tables->table, n2);
} else {
state = Short(tables->dgoto, m);
}
if (sp < Long_val(env->stacksize)) goto semantic_action;
SAVE;
return GROW_STACKS_2;
/* The ML code resizes the stacks */
case STACKS_GROWN_2:
RESTORE;
semantic_action:
SAVE;
return COMPUTE_SEMANTIC_ACTION;
/* The ML code calls the semantic action */
case SEMANTIC_ACTION_COMPUTED:
RESTORE;
Store_field(env->s_stack, sp, Val_int(state));
caml_modify_field(env->v_stack, sp, arg);
asp = Int_val(env->asp);
Store_field (env->symb_end_stack, sp, Field(env->symb_end_stack, asp));
if (sp > asp) {
/* This is an epsilon production. Take symb_start equal to symb_end. */
Store_field (env->symb_start_stack, sp, Field(env->symb_end_stack, asp));
}
goto loop;
default: /* Should not happen */
CAMLassert(0);
return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */
}
