CAMLprim value caml_clone_cont (value cont)
{
CAMLparam1(cont);
CAMLlocal3(new_cont, prev_target, source);
value target;
if (Field (cont, 0) == Val_unit)
caml_invalid_argument ("continuation already taken");
prev_target = Val_unit;
source = Field (cont, 0);
new_cont = caml_alloc (1, 0);
do {
Assert (Is_block (source) && Tag_val(source) == Stack_tag);
target = caml_alloc (Wosize_val(source), Stack_tag);
memcpy ((void*)target, (void*)source, Wosize_val(source) * sizeof(value));
if (prev_target == Val_unit) {
caml_modify (&Field(new_cont, 0), target);
} else {
caml_modify (&Stack_parent(prev_target), target);
}
prev_target = target;
source = Stack_parent(source);
} while (source != Val_unit);
CAMLreturn(new_cont);
}
CAMLprim value caml_get_exception_backtrace(value unit)
{
CAMLparam0();
CAMLlocal5(events, res, arr, p, fname);
int i;
struct loc_info li;
events = read_debug_info();
if (events == Val_false) {
res = Val_int(0); /* None */
} else {
arr = caml_alloc(caml_backtrace_pos, 0);
for (i = 0; i < caml_backtrace_pos; i++) {
extract_location_info(events, caml_backtrace_buffer[i], &li);
if (li.loc_valid) {
fname = caml_copy_string(li.loc_filename);
p = caml_alloc_small(5, 0);
Field(p, 0) = Val_bool(li.loc_is_raise);
Field(p, 1) = fname;
Field(p, 2) = Val_int(li.loc_lnum);
Field(p, 3) = Val_int(li.loc_startchr);
Field(p, 4) = Val_int(li.loc_endchr);
} else {
p = caml_alloc_small(1, 1);
Field(p, 0) = Val_bool(li.loc_is_raise);
}
caml_modify(&Field(arr, i), p);
}
res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
}
CAMLreturn(res);
}
CAMLprim value caml_get_exception_backtrace(value unit)
{
CAMLparam0();
CAMLlocal4(arr, raw_slot, slot, res);
if (caml_debug_info == Val_emptylist) {
res = Val_int(0); /* None */
} else {
arr = caml_alloc(caml_backtrace_pos, 0);
if(caml_backtrace_buffer == NULL) {
Assert(caml_backtrace_pos == 0);
} else {
intnat i;
for(i = 0; i < caml_backtrace_pos; i++) {
raw_slot = Val_Codet(caml_backtrace_buffer[i]);
/* caml_convert_raw_backtrace_slot will not fail with
caml_failwith as we checked (events != NULL) already */
slot = caml_convert_raw_backtrace_slot(raw_slot);
caml_modify(&Field(arr, i), slot);
}
}
res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
}
CAMLreturn(res);
}
static value
copy_statfs (struct statfs *buf)
{
CAMLparam0 ();
CAMLlocal2 (bufv, v);
bufv = caml_alloc (11, 0);
v = copy_int64 (buf->f_type); caml_modify (&Field (bufv, 0), v);
v = copy_int64 (buf->f_bsize); caml_modify (&Field (bufv, 1), v);
v = copy_int64 (buf->f_blocks); caml_modify (&Field (bufv, 2), v);
v = copy_int64 (buf->f_bfree); caml_modify (&Field (bufv, 3), v);
v = copy_int64 (buf->f_bavail); caml_modify (&Field (bufv, 4), v);
v = copy_int64 (buf->f_files); caml_modify (&Field (bufv, 5), v);
v = copy_int64 (buf->f_ffree); caml_modify (&Field (bufv, 6), v);
v = copy_int64 (buf->f_namelen); caml_modify (&Field (bufv, 8), v);
v = copy_string ("-1"); caml_modify (&Field (bufv, 9), v);
v = copy_int64 (-1); caml_modify (&Field (bufv, 10), v);
CAMLreturn (bufv);
}
CAMLprim value netsys_s_read_string_array(value sv, value pv, value lv,
value mv, value av)
{
char *s;
long p, l, n, k;
unsigned int e, j, m;
value uv;
int av_in_heap;
int err;
value r;
value **old_reftbl;
CAMLparam2(sv,av);
/* fprintf(stderr, "netsys_s_read_string_array\n"); fflush(stderr); */
s = String_val(sv); /* will have to redo after each allocation */
p = Long_val(pv);
l = Long_val(lv) + p;
m = (unsigned int) Int32_val(mv);
n = Wosize_val(av);
av_in_heap = (n > 5000) || (Long_val(lv) > 20000);
/* If av is already in the major heap, it is an extra burden to allocate
the new string in the minor heap. The new string would be a local
root until the next minor collection. We avoid this by allocating the
new string in the major heap directly if av is already there.
we don't have access to the Is_in_heap macro, so we just guess
it here
*/
err = 0;
k = 0;
while (k < n) {
if (p+4 > l) break;
e = ntohl(*((unsigned int *) (s+p)));
/* fprintf(stderr, "e=%u\n", e); fflush(stderr); */
p += 4;
j = l-p;
if (e > j) { err=-1; break; }
if (e > m) { err=-2; break; }
uv = av_in_heap ? netsys_alloc_string_shr(e) : caml_alloc_string(e);
s = String_val(sv); /* see above */
memcpy(String_val(uv), s+p, e);
caml_modify(&Field(av,k), uv);
p += e;
if ((e&3) != 0) p += 4-(e&3);
k++;
}
r = Val_long(err);
if (k >= n) r = Val_long(p);
CAMLreturn(r);
}
CAMLprim value caml_install_signal_handler(value signal_number, value action)
{
CAMLparam2 (signal_number, action);
CAMLlocal1 (res);
int sig, act, oldact;
sig = caml_convert_signal_number(Int_val(signal_number));
if (sig < 0 || sig >= NSIG)
caml_invalid_argument("Sys.signal: unavailable signal");
switch(action) {
case Val_int(0): /* Signal_default */
act = 0;
break;
case Val_int(1): /* Signal_ignore */
act = 1;
break;
default: /* Signal_handle */
act = 2;
break;
}
oldact = caml_set_signal_action(sig, act);
switch (oldact) {
case 0: /* was Signal_default */
res = Val_int(0);
break;
case 1: /* was Signal_ignore */
res = Val_int(1);
break;
case 2: /* was Signal_handle */
res = caml_alloc_small (1, 0);
Field(res, 0) = Field(caml_signal_handlers, sig);
break;
default: /* error in caml_set_signal_action */
caml_sys_error(NO_ARG);
}
if (Is_block(action)) {
if (caml_signal_handlers == 0) {
caml_signal_handlers = caml_alloc(NSIG, 0);
caml_register_global_root(&caml_signal_handlers);
}
caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0));
}
caml_process_pending_signals();
CAMLreturn (res);
}
CAMLprim value caml_update_dummy(value dummy, value newval)
{
mlsize_t size, i;
tag_t tag;
size = Wosize_val(newval);
tag = Tag_val (newval);
Assert (size == Wosize_val(dummy));
Assert (tag < No_scan_tag || tag == Double_array_tag);
Tag_val(dummy) = tag;
if (tag == Double_array_tag){
size = Wosize_val (newval) / Double_wosize;
for (i = 0; i < size; i++){
Store_double_field (dummy, i, Double_field (newval, i));
}
}else{
for (i = 0; i < size; i++){
caml_modify (&Field(dummy, i), Field(newval, i));
}
}
return Val_unit;
}
CAMLexport value caml_alloc_array(value (*funct)(char const *),
char const ** arr)
{
CAMLparam0 ();
mlsize_t nbr, n;
CAMLlocal2 (v, result);
nbr = 0;
while (arr[nbr] != 0) nbr++;
if (nbr == 0) {
CAMLreturn (Atom(0));
} else {
result = caml_alloc (nbr, 0);
for (n = 0; n < nbr; n++) {
/* The two statements below must be separate because of evaluation
order (don't take the address &Field(result, n) before
calling funct, which may cause a GC and move result). */
v = funct(arr[n]);
caml_modify(&Field(result, n), v);
}
CAMLreturn (result);
}
}
CAMLprim value PQconndefaults_stub(value __unused v_unit)
{
CAMLparam0();
CAMLlocal2(v_res, v_el);
PQconninfoOption *cios = PQconndefaults(), *p = cios;
int i, j, n;
while (p->keyword != NULL) p++;
n = p - cios;
p = cios;
v_res = caml_alloc_tuple(n);
for (i = 0; i < n; i++, p++) {
value v_field;
v_el = caml_alloc_small(7, 0);
for (j = 0; j < 7; j++) Field(v_el, j) = v_None;
Store_field(v_res, i, v_el);
v_field = caml_copy_string(p->keyword);
Field(v_el, 0) = v_field;
if (p->envvar) {
v_field = make_some(caml_copy_string(p->envvar));
caml_modify(&Field(v_el, 1), v_field);
}
if (p->compiled) {
v_field = make_some(caml_copy_string(p->compiled));
caml_modify(&Field(v_el, 2), v_field);
};
if (p->val) {
v_field = make_some(caml_copy_string(p->val));
caml_modify(&Field(v_el, 3), v_field);
};
v_field = caml_copy_string(p->label);
caml_modify(&Field(v_el, 4), v_field);
v_field = caml_copy_string(p->dispchar);
caml_modify(&Field(v_el, 5), v_field);
caml_modify(&Field(v_el, 6), Val_int(p->dispsize));
};
PQconninfoFree(cios);
CAMLreturn(v_res);
}
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 = Field(tables->transl_block, Tag_val(arg));
caml_modify(&env->lval, Field(arg, 0));
} else {
env->curr_char = Field(tables->transl_const, Int_val(arg));
caml_modify(&env->lval, Val_long(0));
}
if (caml_parser_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_val(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 (caml_parser_trace)
#ifdef _KERNEL
printf("Recovering in state %d\n", state1);
#else
fprintf(stderr, "Recovering in state %d\n", state1);
#endif
goto shift_recover;
} else {
if (caml_parser_trace){
#ifdef _KERNEL
printf("Discarding state %d\n", state1);
#else
fprintf(stderr, "Discarding state %d\n", state1);
#endif
}
if (sp <= Int_val(env->stackbase)) {
if (caml_parser_trace){
#ifdef _KERNEL
printf("No more states to discard\n");
#else
fprintf(stderr, "No more states to discard\n");
#endif
}
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 */
#ifdef _KERNEL
if (caml_parser_trace) printf("Discarding last token read\n");
#else
if (caml_parser_trace) fprintf(stderr, "Discarding last token read\n");
#endif
env->curr_char = Val_int(-1);
goto loop;
}
shift:
env->curr_char = Val_int(-1);
if (errflag > 0) errflag--;
shift_recover:
if (caml_parser_trace)
#ifdef _KERNEL
printf("State %d: shift to state %d\n",
state, Short(tables->table, n2));
#else
fprintf(stderr, "State %d: shift to state %d\n",
state, Short(tables->table, n2));
#endif
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:
Field(env->s_stack, sp) = Val_int(state);
caml_modify(&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 (caml_parser_trace)
#ifdef _KERNEL
printf("State %d: reduce by rule %d\n", state, n);
#else
fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
#endif
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_val(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;
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 */
Assert(0);
return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */
}
}
copy_statfs (struct statfs *buf)
#endif /* ((defined (sun) || defined (__sun__))) || (defined(__NetBSD__) && (__NetBSD_Version__ > 299000000)) || defined (__hpux__) */
{
CAMLparam0 ();
CAMLlocal2 (bufv, v);
bufv = caml_alloc (11, 0);
#if ((defined (sun) || defined (__sun__))) || (defined(__FreeBSD__) && __FreeBSD_version >= 503001) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__alpha__)
v = copy_int64 (-1); caml_modify (&Field (bufv, 0), v);
#else
v = copy_int64 (buf->f_type); caml_modify (&Field (bufv, 0), v);
#endif /* ((defined (sun) || defined (__sun__))) || (defined(__FreeBSD__) && __FreeBSD_version >= 503001) || defined(__OpenBSD__) || defined(__NetBSD__) */
v = copy_int64 (buf->f_bsize); caml_modify (&Field (bufv, 1), v);
v = copy_int64 (buf->f_blocks); caml_modify (&Field (bufv, 2), v);
v = copy_int64 (buf->f_bfree); caml_modify (&Field (bufv, 3), v);
v = copy_int64 (buf->f_bavail); caml_modify (&Field (bufv, 4), v);
v = copy_int64 (buf->f_files); caml_modify (&Field (bufv, 5), v);
v = copy_int64 (buf->f_ffree); caml_modify (&Field (bufv, 6), v);
#if ((defined (sun) || defined (__sun__))) || defined (__hpux__) || defined(__alpha__)
v = copy_int64 (-1); caml_modify (&Field (bufv, 7), v);
v = copy_int64 (buf->f_namemax); caml_modify (&Field (bufv, 8), v);
# if ! defined(__alpha__)
v = copy_string (buf->f_basetype); caml_modify (&Field (bufv, 9), v);
# else
v = copy_string ("-1"); caml_modify (&Field (bufv, 9), v);
# endif
v = copy_int64 (buf->f_frsize); caml_modify (&Field (bufv, 10), v);
#else
#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__APPLE__) || defined(__DragonFly__) || defined(__FreeBSD_kernel__)
# if defined(__OpenBSD__) || defined(__NetBSD__) || (defined(__FreeBSD__) && __FreeBSD_version < 502000) || defined(__DragonFly__) || defined(__APPLE__)
# include <sys/syslimits.h>
v = copy_int64 (NAME_MAX); caml_modify (&Field (bufv, 8), v);
# else
v = copy_int64 (buf->f_namemax); caml_modify (&Field (bufv, 8), v);
# endif /* (__OpenBSD__) || defined(__NetBSD__) || (defined(__FreeBSD__) && __FreeBSD_version < 502000) */
v = copy_string (buf->f_fstypename); caml_modify (&Field (bufv, 9), v);
#else
v = copy_int64 (buf->f_namelen); caml_modify (&Field (bufv, 8), v);
v = copy_string ("-1"); caml_modify (&Field (bufv, 9), v);
#endif /* defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__APPLE__) */
caml_modify (&Field (bufv, 7), Val_unit);
v = copy_int64 (-1); caml_modify (&Field (bufv, 10), v);
#endif /* ((defined (sun) || defined (__sun__))) || defined (__hpux__) */
CAMLreturn (bufv);
}
