/* Check that [v]'s header looks good. [v] must be a block in the heap. */
static void check_head (value v)
{
Assert (Is_block (v));
Assert (Is_in_heap (v));
Assert (Wosize_val (v) != 0);
Assert (Color_hd (Hd_val (v)) != Caml_blue);
Assert (Is_in_heap (v));
if (Tag_val (v) == Infix_tag){
int offset = Wsize_bsize (Infix_offset_val (v));
value trueval = Val_op (&Field (v, -offset));
Assert (Tag_val (trueval) == Closure_tag);
Assert (Wosize_val (trueval) > offset);
Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1)));
}else{
Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1)));
}
if (Tag_val (v) == Double_tag){
Assert (Wosize_val (v) == Double_wosize);
}else if (Tag_val (v) == Double_array_tag){
Assert (Wosize_val (v) % Double_wosize == 0);
}
}
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;
}
// ML type: surface -> point -> color -> unit
// Draws a pixel on the surface.
EXTERNML value draw_draw_pixel(value wScreen, value wPos, value wColor) {
SDL_Surface *screen = (SDL_Surface *)Addr_val(wScreen);
int x = Long_val(Field(wPos, 0)),
y = Long_val(Field(wPos, 1)),
colorr = Long_val(Field(wColor, 0)),
colorg = Long_val(Field(wColor, 1)),
colorb = Long_val(Field(wColor, 2)),
colora = Tag_val(wColor) == RGBA ? Long_val(Field(wColor, 3)) : 255;
pixelRGBA(screen, x, y, colorr, colorg, colorb, colora);
return Val_unit;
}
CAMLprim value ml_gsl_ran_sample(value rng, value src, value dest)
{
if(Tag_val(src) == Double_array_tag)
gsl_ran_sample(Rng_val(rng),
Double_array_val(dest), Double_array_length(dest),
Double_array_val(src), Double_array_length(src),
sizeof(double));
else
gsl_ran_sample(Rng_val(rng),
(value *)dest, Array_length(dest),
(value *)src, Array_length(src),
sizeof(value));
return Val_unit;
}
void caml_maybe_expand_stack (value* gc_regs)
{
CAMLparamN(gc_regs, 5);
uintnat stack_available;
Assert(Tag_val(caml_current_stack) == Stack_tag);
stack_available = Bosize_val(caml_current_stack)
- (Stack_sp(caml_current_stack) + Stack_ctx_words * sizeof(value));
if (stack_available < 2 * Stack_threshold)
caml_realloc_stack ();
CAMLreturn0;
}
CAMLprim value ml_stable_copy (value v)
{
if (Is_block(v) && (char*)(v) < young_end && (char*)(v) > young_start)
{
CAMLparam1(v);
mlsize_t i, wosize = Wosize_val(v);
int tag = Tag_val(v);
value ret;
if (tag < No_scan_tag) invalid_argument("ml_stable_copy");
ret = alloc_shr (wosize, tag);
for (i=0; i < wosize; i++) Field(ret,i) = Field(v,i);
CAMLreturn(ret);
}
return v;
}
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;
}
//onMouseClicked: string->unit
void Controller::onMouseClicked(QString x0) {
CAMLparam0();
CAMLlocal3(_ans,_meth,_x0);
CAMLlocalN(_args,2);
CAMLlocal1(_cca0);
value _camlobj = this->_camlobjHolder;
Q_ASSERT(Is_block(_camlobj));
Q_ASSERT(Tag_val(_camlobj) == Object_tag);
_meth = caml_get_public_method(_camlobj, caml_hash_variant("onMouseClicked"));
_args[0] = _camlobj;
_cca0 = caml_copy_string(x0.toLocal8Bit().data() );
_args[1] = _cca0;
caml_callbackN(_meth, 2, _args);
CAMLreturn0;
}
value unix_util_write(value fd,value buf)
{
value vres=alloc(1,1); /* Ok result */
int res;
enter_blocking_section();
res = write(Int_val(fd), /* TODO: unsafe coercion */
Bigarray_val(buf)->data,Bigarray_val(buf)->dim[0]);
leave_blocking_section();
if (res >=0) Field(vres,0)=Val_int(res);
else
{
Tag_val(vres)=0; /* Bad result */
Field(vres,0)=Val_int(c2ml_unix_error(res)); /* TODO: EUNKNOWN x is a block */
}
return vres;
}
void get_sockaddr(value mladr,
union sock_addr_union * adr /*out*/,
socklen_param_type * adr_len /*out*/)
{
switch(Tag_val(mladr)) {
#ifndef _WIN32
case 0: /* ADDR_UNIX */
{ value path;
mlsize_t len;
path = Field(mladr, 0);
len = string_length(path);
adr->s_unix.sun_family = AF_UNIX;
if (len >= sizeof(adr->s_unix.sun_path)) {
unix_error(ENAMETOOLONG, "", path);
}
memmove (adr->s_unix.sun_path, String_val(path), len + 1);
*adr_len =
((char *)&(adr->s_unix.sun_path) - (char *)&(adr->s_unix))
+ len;
break;
}
#endif
case 1: /* ADDR_INET */
#ifdef HAS_IPV6
if (string_length(Field(mladr, 0)) == 16) {
memset(&adr->s_inet6, 0, sizeof(struct sockaddr_in6));
adr->s_inet6.sin6_family = AF_INET6;
adr->s_inet6.sin6_addr = GET_INET6_ADDR(Field(mladr, 0));
adr->s_inet6.sin6_port = htons(Int_val(Field(mladr, 1)));
#ifdef SIN6_LEN
adr->s_inet6.sin6_len = sizeof(struct sockaddr_in6);
#endif
*adr_len = sizeof(struct sockaddr_in6);
break;
}
#endif
memset(&adr->s_inet, 0, sizeof(struct sockaddr_in));
adr->s_inet.sin_family = AF_INET;
adr->s_inet.sin_addr = GET_INET_ADDR(Field(mladr, 0));
adr->s_inet.sin_port = htons(Int_val(Field(mladr, 1)));
#ifdef SIN6_LEN
adr->s_inet.sin_len = sizeof(struct sockaddr_in);
#endif
*adr_len = sizeof(struct sockaddr_in);
break;
}
}
void QWidget_twin::keyPressEvent(QKeyEvent *ev) {
CAMLparam0();
CAMLlocal3(meth,camlobj,_ev);
GET_CAML_OBJECT(this,camlobj); // get ocaml object from QObject's property
printf ("inside QWidget_twin::keyPressedEvent, camlobj = %p, this=%p\n", (void*)camlobj, this);
meth = caml_get_public_method( camlobj, caml_hash_variant("keyPressEvent"));
if (meth==0)
printf ("total fail\n");
printf ("tag of meth is %d\n", Tag_val(meth) );
printf("calling callback of meth = %p\n",(void*)meth);
setAbstrClass(_ev,QKeyEvent,ev);
value *caller = caml_named_value("make_qKeyEvent");
_ev = caml_callback(*caller, _ev);
caml_callback2(meth, camlobj,_ev);
printf ("exit from QWidget_twin::keyPressedEvent\n");
CAMLreturn0;
}
/*
* Compute the size of the argument (of type TkArgs).
* TkTokenList must be expanded,
* TkQuote count for one.
*/
int argv_size(value v)
{
switch (Tag_val(v)) {
case 0: /* TkToken */
return 1;
case 1: /* TkTokenList */
{ int n = 0;
value l;
for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1))
n+=argv_size(Field(l,0));
return n;
}
case 2: /* TkQuote */
return 1;
default:
tk_error("argv_size: illegal tag");
}
}
static value next_minor_block(caml_domain_state* domain_state, value curr_hp)
{
mlsize_t wsz;
header_t hd;
value curr_val;
CAMLassert ((value)domain_state->young_ptr <= curr_hp);
CAMLassert (curr_hp < (value)domain_state->young_end);
hd = Hd_hp(curr_hp);
curr_val = Val_hp(curr_hp);
if (hd == 0) {
/* Forwarded object, find the promoted version */
curr_val = Op_val(curr_val)[0];
}
CAMLassert (Is_block(curr_val) && Hd_val(curr_val) != 0 && Tag_val(curr_val) != Infix_tag);
wsz = Wosize_val(curr_val);
CAMLassert (wsz <= Max_young_wosize);
return curr_hp + Bsize_wsize(Whsize_wosize(wsz));
}
CAMLprim value caml_make_vect(value len, value init)
{
CAMLparam2 (len, init);
CAMLlocal1 (res);
mlsize_t size, wsize, i;
double d;
size = Long_val(len);
if (size == 0) {
res = Atom(0);
}
else if (Is_block(init)
&& Is_in_value_area(init)
&& Tag_val(init) == Double_tag) {
d = Double_val(init);
wsize = size * Double_wosize;
if (wsize > Max_wosize) caml_invalid_argument("Array.make");
res = caml_alloc(wsize, Double_array_tag);
for (i = 0; i < size; i++) {
Store_double_field(res, i, d);
}
} else {
if (size > Max_wosize) caml_invalid_argument("Array.make");
if (size < Max_young_wosize) {
res = caml_alloc_small(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
}
else if (Is_block(init) && Is_young(init)) {
caml_minor_collection();
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
res = caml_check_urgent_gc (res);
}
else {
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init);
res = caml_check_urgent_gc (res);
}
}
CAMLreturn (res);
}
CAMLprim value netsys_mknod (value name, value perm, value nt)
{
#ifdef _WIN32
invalid_argument("Netsys_posix.mknod not available");
#else
mode_t m;
dev_t d;
int e;
m = Long_val(perm) & 07777;
d = 0;
if (Is_block(nt)) {
switch (Tag_val(nt)) {
case 0: /* = S_IFCHR */
m |= S_IFCHR;
d = Long_val(Field(nt,0));
break;
case 1: /* = S_IFBLK */
m |= S_IFBLK;
d = Long_val(Field(nt,0));
break;
}
}
else {
switch (Long_val(nt)) {
case 0: /* = S_IFREG */
m |= S_IFREG; break;
case 1: /* = S_IFIFO */
m |= S_IFIFO; break;
case 2: /* = S_IFSOCK */
m |= S_IFSOCK; break;
}
}
e = mknod(String_val(name), m, d);
if (e < 0) uerror("mknod", Nothing);
return Val_unit;
#endif
}
CAMLprim value c_restore_material( value _face_mode, value v /* material_mode */,
value material_state ) {
GLenum pname;
GLenum face_mode;
#include "enums/face_mode.inc.c"
switch (Tag_val(v))
{
case 0: pname = GL_AMBIENT; break;
case 1: pname = GL_DIFFUSE; break;
case 2: pname = GL_SPECULAR; break;
case 3: pname = GL_EMISSION; break;
case 4: pname = GL_SHININESS; break;
case 5: pname = GL_AMBIENT_AND_DIFFUSE; break;
case 6: pname = GL_COLOR_INDEXES; break;
default: caml_failwith("variant handling bug");
}
glMaterialfv( face_mode, pname, (GLfloat *)material_state );
free((void *)material_state);
return Val_unit;
}
value
ffmpeg_stream_new(value ctx, value media_kind_)
{
CAMLparam2(ctx, media_kind_);
CAMLlocal1(ret);
if (Context_val(ctx)->fmtCtx) {
switch (Tag_val(media_kind_)) {
case 0: {
ret = ffmpeg_stream_new_video(ctx, Field(media_kind_, 0));
} break;
case 1: {
ret = ffmpeg_stream_new_audio(ctx, Field(media_kind_, 0));
} break;
}
} else {
raise(ExnClosed, 0);
}
CAMLreturn(ret);
}
static value promote_stack(struct domain* domain, value stack)
{
caml_gc_log("Promoting stack");
Assert(Tag_val(stack) == Stack_tag);
if (Is_minor(stack)) {
/* First, promote the actual stack object */
Assert(caml_owner_of_young_block(stack) == domain);
/* Stacks are only referenced via fibers, so we don't bother
using the promotion_table */
void* new_stack = caml_shared_try_alloc(domain->shared_heap, Wosize_val(stack), Stack_tag, 0);
if (!new_stack) caml_fatal_error("allocation failure during stack promotion");
memcpy(Op_hp(new_stack), (void*)stack, Wosize_val(stack) * sizeof(value));
stack = Val_hp(new_stack);
}
/* Promote each object on the stack. */
promote_domain = domain;
caml_scan_stack(&promote_stack_elem, stack);
/* Since we've promoted the objects on the stack, the stack is now clean. */
caml_clean_stack_domain(stack, domain);
return stack;
}
CAMLprim value
uwt_udp_recv_own(value o_udp,value o_offset,value o_len,value o_buf_cb)
{
HANDLE_INIT2_NO_UNINIT(u, o_udp, o_buf_cb);
const int ba = Tag_val(Field(o_buf_cb,0)) != String_tag;
size_t len = Long_val(o_len);
value ret;
if ( u->cb_read != CB_INVALID ){
ret = VAL_UWT_INT_RESULT_EBUSY;
}
else if ( len > ULONG_MAX ){
ret = VAL_UWT_INT_RESULT_EINVAL;
}
else {
int erg = 0;
uv_udp_t* ux = (uv_udp_t*)u->handle;
if ( u->can_reuse_cb_read == 0 ){
erg = uv_udp_recv_start(ux,uwt__alloc_own_cb,uwt_udp_recv_own_cb);
}
if ( erg >= 0 ){
size_t offset = Long_val(o_offset);
uwt__gr_register(&u->cb_read,o_buf_cb);
++u->in_use_cnt;
u->c_read_size = len;
u->use_read_ba = ba;
u->read_waiting = 1;
u->can_reuse_cb_read = 0;
if ( ba == 0 ){
u->x.obuf_offset = offset;
}
else {
u->x.ba_read = Ba_buf_val(Field(o_buf_cb,0)) + offset;
}
}
ret = VAL_UWT_UNIT_RESULT(erg);
}
CAMLreturn(ret);
}
static int bbbdcomm(sundials_ml_index nlocal, realtype t, N_Vector y,
N_Vector yb, void *user_data)
{
CAMLparam0();
CAMLlocal3(args, session, cb);
args = caml_alloc_tuple (RECORD_CVODES_ADJ_BRHSFN_ARGS_SIZE);
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_T, caml_copy_double (t));
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_Y, NVEC_BACKLINK (y));
Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_YB, NVEC_BACKLINK (yb));
WEAK_DEREF (session, *(value*)user_data);
cb = CVODE_LS_PRECFNS_FROM_ML (session);
cb = Field (cb, 0);
cb = Field (cb, RECORD_CVODES_BBBD_PRECFNS_COMM_FN);
cb = Some_val (cb);
assert (Tag_val (cb) == Closure_tag);
/* NB: Don't trigger GC while processing this return value! */
value r = caml_callback_exn (cb, args);
CAMLreturnT(int, CHECK_EXCEPTION (session, r, RECOVERABLE));
}
CAMLprim value c_set_get_lightModel( value light_model ) {
GLfloat *lightModel_state;
GLenum pname = 0;
lightModel_state = malloc(4 * sizeof(GLfloat));
switch (Tag_val(light_model))
{
case 0:
{ GLfloat param[4];
pname = GL_LIGHT_MODEL_AMBIENT;
param[0] = Double_val(Field(light_model,0));
param[1] = Double_val(Field(light_model,1));
param[2] = Double_val(Field(light_model,2));
param[3] = Double_val(Field(light_model,3));
glGetFloatv( pname, lightModel_state );
glLightModelfv( pname, param );
} break;
case 1:
pname = GL_LIGHT_MODEL_COLOR_CONTROL;
glGetFloatv( pname, lightModel_state );
glLightModeli(
pname,
(Int_val(Field(light_model,0)) ?
GL_SINGLE_COLOR :
GL_SEPARATE_SPECULAR_COLOR) );
break;
case 2: pname = GL_LIGHT_MODEL_LOCAL_VIEWER;
case 3: if (pname == 0) pname = GL_LIGHT_MODEL_TWO_SIDE;
glGetFloatv( pname, lightModel_state );
glLightModeli(
pname,
Int_val(Field(light_model,0)) );
break;
}
return (value) lightModel_state;
}
/* will need to test every variant cases */
CAMLprim value c_set_get_material( value _face_mode, value v /* material_mode */ ) {
GLenum face_mode;
GLfloat * material_state;
#include "enums/face_mode.inc.c"
material_state = malloc(4 * sizeof(GLfloat));
switch (Tag_val(v))
{
#define set_get_glMaterial_with_4_floats(pname) \
{ GLfloat params[4]; \
params[0] = Double_val(Field(v,0)); \
params[1] = Double_val(Field(v,1)); \
params[2] = Double_val(Field(v,2)); \
params[3] = Double_val(Field(v,3)); \
glGetMaterialfv( \
face_mode, \
(pname == GL_AMBIENT_AND_DIFFUSE ? GL_AMBIENT : pname), \
material_state ); \
glMaterialfv( \
face_mode, \
pname, \
params ); \
}
case 0:
set_get_glMaterial_with_4_floats(GL_AMBIENT); break;
case 1:
set_get_glMaterial_with_4_floats(GL_DIFFUSE); break;
case 2:
set_get_glMaterial_with_4_floats(GL_SPECULAR); break;
case 3:
set_get_glMaterial_with_4_floats(GL_EMISSION); break;
case 5:
set_get_glMaterial_with_4_floats(GL_AMBIENT_AND_DIFFUSE); break;
#undef set_get_glMaterial_with_4_floats
case 4:
glGetMaterialfv(
face_mode,
GL_SHININESS,
material_state );
glMaterialf(
face_mode,
GL_SHININESS,
Double_val(Field(v,0)) );
break;
case 6:
{ GLint params[3];
params[0] = Int_val(Field(v,0));
params[1] = Int_val(Field(v,1));
params[2] = Int_val(Field(v,2));
glGetMaterialfv(
face_mode,
GL_COLOR_INDEXES,
material_state );
glMaterialiv(
face_mode,
GL_COLOR_INDEXES,
params );
}
break;
default: caml_failwith("variant handling bug");
}
return (value) material_state;
}
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 */
}
}
CAMLprim value
magick_loader(value input)
{
CAMLparam1(input);
CAMLlocal2(pixel_matrix, res);
Image *image_bloc;
int image_type_code;
int components;
GLenum format;
ExceptionInfo exception;
GetExceptionInfo(&exception);
{
if (IsMagickInstantiated() == MagickFalse) {
InitializeMagick(getenv("PWD"));
}
{
ImageInfo *image_info;
image_info = CloneImageInfo((ImageInfo *) NULL);
switch (Tag_val(input))
{
/* given a filename of an image */
case 0:
(void) strcpy(image_info->filename, String_val(Field(input,0)));
image_bloc = ReadImage(image_info, &exception);
break;
/* given the image data in a buffer */
case 1:
image_bloc = BlobToImage(
image_info,
(void *)String_val(Field(input,0)),
caml_string_length(Field(input,0)),
&exception);
break;
}
DestroyImageInfo(image_info);
}
if (exception.severity != UndefinedException) {
if (image_bloc != (Image *) NULL) {
DestroyImage(image_bloc);
}
DestroyExceptionInfo(&exception);
caml_failwith( exception.reason );
/* @TODO exception.description */
}
if (image_bloc == (Image *) NULL) {
DestroyExceptionInfo(&exception);
caml_failwith("read image failed");
}
}
{
ImageType image_type;
image_type = GetImageType( image_bloc, &exception );
if (exception.severity != UndefinedException)
caml_failwith( exception.reason );
image_type_code = Val_ImageType(image_type, &components);
if ( image_type_code == 11 )
caml_failwith("getting image type failed");
}
{
unsigned long x, y;
unsigned long columns, rows;
PixelPacket pixel;
columns = image_bloc->columns;
rows = image_bloc->rows;
const PixelPacket * pixel_packet_array;
pixel_packet_array =
AcquireImagePixels(
image_bloc,
0, 0, columns, rows,
&exception );
if (exception.severity != UndefinedException) {
caml_failwith(exception.reason);
}
{
unsigned char *image;
long ndx;
long dims[3];
dims[0] = columns;
dims[1] = rows;
dims[2] = components;
pixel_matrix = alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT, 3, NULL, dims);
image = Data_bigarray_val(pixel_matrix);
for (x=0; x < columns; ++x) {
for (y=0; y < rows; ++y) {
pixel = pixel_packet_array[(columns * y) + x];
ndx = (columns * y * components) + (x * components);
switch (components) {
case 1:
image[ndx + 0] = pixel.red / SCALE;
break;
case 2:
image[ndx + 0] = pixel.red / SCALE;
image[ndx + 1] = ( MaxMap - pixel.opacity ) / SCALE;
break;
case 3:
image[ndx + 0] = pixel.red / SCALE;
image[ndx + 1] = pixel.green / SCALE;
image[ndx + 2] = pixel.blue / SCALE;
break;
case 4:
image[ndx + 0] = pixel.red / SCALE;
image[ndx + 1] = pixel.green / SCALE;
image[ndx + 2] = pixel.blue / SCALE;
image[ndx + 3] = ( MaxMap - pixel.opacity ) / SCALE;
break;
}
}
}
}
switch (components) {
case 1: format = GL_LUMINANCE; break;
case 2: format = GL_LUMINANCE_ALPHA; break;
case 3: format = GL_RGB; break;
case 4: format = GL_RGBA; break;
}
res = alloc_tuple(5);
Store_field(res, 0, pixel_matrix );
Store_field(res, 1, Val_long(columns) );
Store_field(res, 2, Val_long(rows) );
Store_field(res, 3, Val_internal_format(components) );
Store_field(res, 4, Val_pixel_data_format(format) );
}
DestroyExceptionInfo(&exception);
DestroyImage(image_bloc);
CAMLreturn(res);
}
static void hash_aux(value obj)
{
unsigned char * p;
mlsize_t i, j;
tag_t tag;
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) return;
again:
if (Is_long(obj)) {
hash_univ_count--;
Combine(Long_val(obj));
return;
}
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
Assert (Is_block (obj));
if (Is_in_value_area(obj)) {
tag = Tag_val(obj);
switch (tag) {
case String_tag:
hash_univ_count--;
i = caml_string_length(obj);
for (p = &Byte_u(obj, 0); i > 0; i--, p++)
Combine_small(*p);
break;
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Double_array_tag:
hash_univ_count--;
for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, j), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
}
break;
case Abstract_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Infix_tag:
hash_aux(obj - Infix_offset_val(obj));
break;
case Forward_tag:
obj = Forward_val (obj);
goto again;
case Object_tag:
hash_univ_count--;
Combine(Oid_val(obj));
break;
case Custom_tag:
/* If no hashing function provided, do nothing */
if (Custom_ops_val(obj)->hash != NULL) {
hash_univ_count--;
Combine(Custom_ops_val(obj)->hash(obj));
}
break;
default:
hash_univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(Field(obj, i));
}
break;
}
return;
}
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((intnat) obj);
}
CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
{
CAMLparam3(vnode, vserv, vopts);
CAMLlocal3(vres, v, e);
mlsize_t len;
char * node, * serv;
struct addrinfo hints;
struct addrinfo * res, * r;
int retcode;
/* Extract "node" parameter */
len = string_length(vnode);
if (len == 0) {
node = NULL;
} else {
node = stat_alloc(len + 1);
strcpy(node, String_val(vnode));
}
/* Extract "service" parameter */
len = string_length(vserv);
if (len == 0) {
serv = NULL;
} else {
serv = stat_alloc(len + 1);
strcpy(serv, String_val(vserv));
}
/* Parse options, set hints */
memset(&hints, 0, sizeof(hints));
hints.ai_family = PF_UNSPEC;
for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) {
v = Field(vopts, 0);
if (Is_block(v))
switch (Tag_val(v)) {
case 0: /* AI_FAMILY of socket_domain */
hints.ai_family = socket_domain_table[Int_val(Field(v, 0))];
break;
case 1: /* AI_SOCKTYPE of socket_type */
hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))];
break;
case 2: /* AI_PROTOCOL of int */
hints.ai_protocol = Int_val(Field(v, 0));
break;
}
else
switch (Int_val(v)) {
case 0: /* AI_NUMERICHOST */
hints.ai_flags |= AI_NUMERICHOST; break;
case 1: /* AI_CANONNAME */
hints.ai_flags |= AI_CANONNAME; break;
case 2: /* AI_PASSIVE */
hints.ai_flags |= AI_PASSIVE; break;
}
}
/* Do the call */
enter_blocking_section();
retcode = getaddrinfo(node, serv, &hints, &res);
leave_blocking_section();
if (node != NULL) stat_free(node);
if (serv != NULL) stat_free(serv);
/* Convert result */
vres = Val_int(0);
if (retcode == 0) {
for (r = res; r != NULL; r = r->ai_next) {
e = convert_addrinfo(r);
v = alloc_small(2, 0);
Field(v, 0) = e;
Field(v, 1) = vres;
vres = v;
}
freeaddrinfo(res);
}
CAMLreturn(vres);
}
void caml_oldify_one (value v, value *p)
{
value result;
header_t hd;
mlsize_t sz, i;
tag_t tag;
tail_call:
if (Is_block (v) && Is_young (v)){
if (Hp_val(v) < caml_young_ptr)
printf("%lx, %lx\n", Hp_val(v), caml_young_ptr);
Assert (Hp_val (v) >= caml_young_ptr);
hd = Hd_val (v);
if (hd == 0){ /* If already forwarded */
*p = Field (v, 0); /* then forward pointer is first field. */
}else{
tag = Tag_hd (hd);
if (tag < Infix_tag){
value field0;
sz = Wosize_hd (hd);
result = caml_alloc_shr (sz, tag);
*p = result;
field0 = Field (v, 0);
Hd_val (v) = 0; /* Set forward flag */
Field (v, 0) = result; /* and forward pointer. */
if (sz > 1){
Field (result, 0) = field0;
Field (result, 1) = oldify_todo_list; /* Add this block */
oldify_todo_list = v; /* to the "to do" list. */
}else{
Assert (sz == 1);
p = &Field (result, 0);
v = field0;
goto tail_call;
}
}else if (tag >= No_scan_tag){
sz = Wosize_hd (hd);
result = caml_alloc_shr (sz, tag);
for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
Hd_val (v) = 0; /* Set forward flag */
Field (v, 0) = result; /* and forward pointer. */
*p = result;
}else if (tag == Infix_tag){
mlsize_t offset = Infix_offset_hd (hd);
caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */
*p += offset;
}else{
value f = Forward_val (v);
tag_t ft = 0;
int vv = 1;
Assert (tag == Forward_tag);
if (Is_block (f)){
vv = Is_in_value_area(f);
if (vv) {
ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
}
}
if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
/* Do not short-circuit the pointer. Copy as a normal block. */
Assert (Wosize_hd (hd) == 1);
result = caml_alloc_shr (1, Forward_tag);
*p = result;
Hd_val (v) = 0; /* Set (GC) forward flag */
Field (v, 0) = result; /* and forward pointer. */
p = &Field (result, 0);
v = f;
goto tail_call;
}else{
v = f; /* Follow the forwarding */
goto tail_call; /* then oldify. */
}
}
}
}else{
*p = v;
}
}
CAMLexport mlsize_t caml_array_length(value array){
tag_t tag = Tag_val(array);
if (tag == Double_array_tag)
return Wosize_val(array) / Double_wosize;
else return Wosize_val(array);
}
int netsys_init_value_1(struct htab *t,
struct nqueue *q,
char *dest,
char *dest_end,
value orig,
int enable_bigarrays,
int enable_customs,
int enable_atoms,
int simulation,
void *target_addr,
struct named_custom_ops *target_custom_ops,
int color,
intnat *start_offset,
intnat *bytelen
)
{
void *orig_addr;
void *work_addr;
value work;
int work_tag;
char *work_header;
size_t work_bytes;
size_t work_words;
void *copy_addr;
value copy;
char *copy_header;
header_t copy_header1;
int copy_tag;
size_t copy_words;
void *fixup_addr;
char *dest_cur;
char *dest_ptr;
int code, i;
intnat addr_delta;
struct named_custom_ops *ops_ptr;
void *int32_target_ops;
void *int64_target_ops;
void *nativeint_target_ops;
void *bigarray_target_ops;
copy = 0;
dest_cur = dest;
addr_delta = ((char *) target_addr) - dest;
if (dest_cur >= dest_end && !simulation) return (-4); /* out of space */
if (!Is_block(orig)) return (-2);
orig_addr = (void *) orig;
code = netsys_queue_add(q, orig_addr);
if (code != 0) return code;
/* initialize *_target_ops */
bigarray_target_ops = NULL;
int32_target_ops = NULL;
int64_target_ops = NULL;
nativeint_target_ops = NULL;
ops_ptr = target_custom_ops;
while (ops_ptr != NULL) {
if (strcmp(ops_ptr->name, "_bigarray") == 0)
bigarray_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_i") == 0)
int32_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_j") == 0)
int64_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_n") == 0)
nativeint_target_ops = ops_ptr->ops;
ops_ptr = ops_ptr->next;
};
/* First pass: Iterate over the addresses found in q. Ignore
addresses already seen in the past (which are in t). For
new addresses, make a copy, and add these copies to t.
*/
/* fprintf(stderr, "first pass, orig_addr=%lx simulation=%d addr_delta=%lx\n",
(unsigned long) orig_addr, simulation, addr_delta);
*/
code = netsys_queue_take(q, &work_addr);
while (code != (-3)) {
if (code != 0) return code;
/* fprintf(stderr, "work_addr=%lx\n", (unsigned long) work_addr); */
code = netsys_htab_lookup(t, work_addr, ©_addr);
if (code != 0) return code;
if (copy_addr == NULL) {
/* The address is unknown, so copy the value */
/* Body of first pass */
work = (value) work_addr;
work_tag = Tag_val(work);
work_header = Hp_val(work);
if (work_tag < No_scan_tag) {
/* It is a scanned value (with subvalues) */
switch(work_tag) {
case Object_tag:
case Closure_tag:
case Lazy_tag:
case Forward_tag:
return (-2); /* unsupported */
}
work_words = Wosize_hp(work_header);
if (work_words == 0) {
if (!enable_atoms) return (-2);
if (enable_atoms == 1) goto next;
};
/* Do the copy. */
work_bytes = Bhsize_hp(work_header);
copy_header = dest_cur;
dest_cur += work_bytes;
if (dest_cur > dest_end && !simulation) return (-4);
if (simulation)
copy_addr = work_addr;
else {
memcpy(copy_header, work_header, work_bytes);
copy = Val_hp(copy_header);
copy_addr = (void *) copy;
Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
}
/* Add the association (work_addr -> copy_addr) to t: */
code = netsys_htab_add(t, work_addr, copy_addr);
if (code < 0) return code;
/* Add the sub values of work_addr to q: */
for (i=0; i < work_words; ++i) {
value field = Field(work, i);
if (Is_block (field)) {
code = netsys_queue_add(q, (void *) field);
if (code != 0) return code;
}
}
}
else {
/* It an opaque value */
int do_copy = 0;
int do_bigarray = 0;
void *target_ops = NULL;
char caml_id = ' '; /* only b, i, j, n */
/* Check for bigarrays and other custom blocks */
switch (work_tag) {
case Abstract_tag:
return(-2);
case String_tag:
do_copy = 1; break;
case Double_tag:
do_copy = 1; break;
case Double_array_tag:
do_copy = 1; break;
case Custom_tag:
{
struct custom_operations *custom_ops;
char *id;
custom_ops = Custom_ops_val(work);
id = custom_ops->identifier;
if (id[0] == '_') {
switch (id[1]) {
case 'b':
if (!enable_bigarrays) return (-2);
if (strcmp(id, "_bigarray") == 0) {
caml_id = 'b';
break;
}
case 'i': /* int32 */
case 'j': /* int64 */
case 'n': /* nativeint */
if (!enable_customs) return (-2);
if (id[2] == 0) {
caml_id = id[1];
break;
}
default:
return (-2);
}
}
else
return (-2);
}
}; /* switch */
switch (caml_id) { /* look closer at some cases */
case 'b': {
target_ops = bigarray_target_ops;
do_copy = 1;
do_bigarray = 1;
break;
}
case 'i':
target_ops = int32_target_ops; do_copy = 1; break;
case 'j':
target_ops = int64_target_ops; do_copy = 1; break;
case 'n':
target_ops = nativeint_target_ops; do_copy = 1; break;
};
if (do_copy) {
/* Copy the value */
work_bytes = Bhsize_hp(work_header);
copy_header = dest_cur;
dest_cur += work_bytes;
if (simulation)
copy_addr = work_addr;
else {
if (dest_cur > dest_end) return (-4);
memcpy(copy_header, work_header, work_bytes);
copy = Val_hp(copy_header);
copy_addr = (void *) copy;
Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
if (target_ops != NULL)
Custom_ops_val(copy) = target_ops;
}
code = netsys_htab_add(t, work_addr, copy_addr);
if (code < 0) return code;
}
if (do_bigarray) {
/* postprocessing for copying bigarrays */
struct caml_ba_array *b_work, *b_copy;
void * data_copy;
char * data_header;
header_t data_header1;
size_t size = 1;
size_t size_aligned;
size_t size_words;
b_work = Bigarray_val(work);
b_copy = Bigarray_val(copy);
for (i = 0; i < b_work->num_dims; i++) {
size = size * b_work->dim[i];
};
size =
size *
caml_ba_element_size[b_work->flags & BIGARRAY_KIND_MASK];
size_aligned = size;
if (size%sizeof(void *) != 0)
size_aligned += sizeof(void *) - (size%sizeof(void *));
size_words = Wsize_bsize(size_aligned);
/* If we put the copy of the bigarray into our own
dest buffer, also generate an abstract header,
so it can be skipped when iterating over it.
We use here a special representation, so we can
encode any length in this header (with a normal
Ocaml header we are limited by Max_wosize, e.g.
16M on 32 bit systems). The special representation
is an Abstract_tag with zero length, followed
by the real length (in words)
*/
if (enable_bigarrays == 2) {
data_header = dest_cur;
dest_cur += 2*sizeof(void *);
data_copy = dest_cur;
dest_cur += size_aligned;
} else if (!simulation) {
data_header = NULL;
data_copy = stat_alloc(size_aligned);
};
if (!simulation) {
if (dest_cur > dest_end) return (-4);
/* Initialize header: */
if (data_header != NULL) {
data_header1 = Abstract_tag;
memcpy(data_header,
(char *) &data_header1,
sizeof(header_t));
memcpy(data_header + sizeof(header_t),
(size_t *) &size_words,
sizeof(size_t));
};
/* Copy bigarray: */
memcpy(data_copy, b_work->data, size);
b_copy->data = data_copy;
b_copy->proxy = NULL;
/* If the copy is in our own buffer, it is
now externally managed.
*/
b_copy->flags =
(b_copy->flags & ~CAML_BA_MANAGED_MASK) |
(enable_bigarrays == 2 ?
CAML_BA_EXTERNAL :
CAML_BA_MANAGED);
}
}
} /* if (work_tag < No_scan_tag) */
} /* if (copy_addr == NULL) */
/* Switch to next address in q: */
next:
code = netsys_queue_take(q, &work_addr);
} /* while */
/* Second pass. The copied blocks still have fields pointing to the
original blocks. We fix that now by iterating once over the copied
memory block.
*/
if (!simulation) {
/* fprintf(stderr, "second pass\n"); */
dest_ptr = dest;
while (dest_ptr < dest_cur) {
copy_header1 = *((header_t *) dest_ptr);
copy_tag = Tag_hd(copy_header1);
copy_words = Wosize_hd(copy_header1);
copy = (value) (dest_ptr + sizeof(void *));
if (copy_tag < No_scan_tag) {
for (i=0; i < copy_words; ++i) {
value field = Field(copy, i);
if (Is_block (field)) {
/* It is a pointer. Try to fix it up. */
code = netsys_htab_lookup(t, (void *) field,
&fixup_addr);
if (code != 0) return code;
if (fixup_addr != NULL)
Field(copy,i) =
(value) (((char *) fixup_addr) + addr_delta);
}
}
}
else if (copy_tag == Abstract_tag && copy_words == 0) {
/* our special representation for skipping data regions */
copy_words = ((size_t *) dest_ptr)[1] + 1;
};
dest_ptr += (copy_words + 1) * sizeof(void *);
}
}
/* hey, fine. Return result */
*start_offset = sizeof(void *);
*bytelen = dest_cur - dest;
/* fprintf(stderr, "return regularly\n");*/
return 0;
}
CAMLexport int caml_is_double_array(value array){
return (Tag_val(array) == Double_array_tag);
}
