value dGifGetExtension( value hdl )
{
CAMLparam1(hdl);
CAMLlocal3(ext,exts,res);
CAMLlocal1(newres);
GifFileType *GifFile = (GifFileType*) hdl;
int func;
GifByteType *extData;
exts = Val_int(0);
if (DGifGetExtension(GifFile,&func, &extData) == GIF_ERROR){
failwith("DGifGetExtension");
}
while( extData != NULL ){
ext= alloc_string(extData[0]);
memcpy(String_val(ext), &extData[1], extData[0]);
newres = alloc_small(2,0);
caml_modify_field(newres, 0, ext);
caml_modify_field(newres, 1, exts);
exts= newres;
DGifGetExtensionNext(GifFile, &extData);
}
res = alloc_small(2,0);
caml_modify_field(res,0, Val_int(func));
caml_modify_field(res,1, exts);
CAMLreturn(res);
}
CAMLexport void caml_delete_root(caml_root root)
{
value v = (value)root;
Assert(root);
/* the root will be removed from roots_all and freed at the next GC */
caml_modify_field(v, 0, Val_unit);
caml_modify_field(v, 1, Val_int(0));
}
value dGifOpenFileName( value name )
{
CAMLparam1(name);
CAMLlocal1(res);
CAMLlocalN(r,2);
GifFileType *GifFile;
int i;
#if (GIFLIB_MAJOR <= 4)
GifFile = DGifOpenFileName( String_val(name) );
#else
GifFile = DGifOpenFileName( String_val(name), NULL);
#endif
if(GifFile == NULL){
failwith("DGifOpenFileName");
}
r[0] = Val_ScreenInfo( GifFile );
r[1] = (value) GifFile;
res = alloc_small(2,0);
for(i=0; i<2; i++) caml_modify_field(res, i, r[i]);
CAMLreturn(res);
}
void caml_cleanup_deleted_roots()
{
value r, prev;
int first = 1;
caml_plat_lock(&roots_mutex);
r = roots_all;
while (Is_block(r)) {
value next = Field(r, 2);
if (Field(r, 1) == Val_int(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);
}
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_dump_image(value image)
{
int width, height, i, j;
XImage * idata, * imask;
value m = Val_unit;
Begin_roots2(image, m);
caml_gr_check_open();
width = Width_im(image);
height = Height_im(image);
m = alloc(height, 0);
for (i = 0; i < height; i++) {
value v = alloc(width, 0);
caml_modify_field(m, i, v);
}
idata =
XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1),
ZPixmap);
for (i = 0; i < height; i++)
for (j = 0; j < width; j++)
caml_modify_field(Field(m, i), j,
Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i))));
XDestroyImage(idata);
if (Mask_im(image) != None) {
imask =
XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1,
ZPixmap);
for (i = 0; i < height; i++)
for (j = 0; j < width; j++)
if (XGetPixel(imask, j, i) == 0)
caml_modify_field(Field(m, i), j, Val_int(Transparent));
XDestroyImage(imask);
}
End_roots();
return m;
}
value Val_GifColorType( GifColorType *color )
{
CAMLparam0();
CAMLlocal1(res);
CAMLlocalN(r,3);
int i;
r[0] = Val_int( color->Red );
r[1] = Val_int( color->Green );
r[2] = Val_int( color->Blue );
res = alloc_small(3,0);
for(i=0; i<3; i++) caml_modify_field(res, i, r[i]);
#ifdef DEBUG_GIF
fprintf(stderr, "Color(%d,%d,%d)\n", color->Red, color->Green, color->Blue);
fflush(stderr);
#endif
CAMLreturn(res);
}
value Val_ScreenInfo( GifFileType *GifFile )
{
CAMLparam0();
CAMLlocal1(res);
CAMLlocalN(r,5);
int i;
r[0] = Val_int(GifFile->SWidth);
r[1] = Val_int(GifFile->SHeight);
r[2] = Val_int(GifFile->SColorResolution);
r[3] = Val_int(GifFile->SBackGroundColor);
r[4] = Val_ColorMapObject(GifFile->SColorMap);
res = alloc_small(5,0);
for(i=0; i<5; i++) caml_modify_field(res, i, r[i]);
CAMLreturn(res);
}
value Val_GifImageDesc( GifImageDesc *imageDesc )
{
CAMLparam0();
CAMLlocal1(res);
CAMLlocalN(r,6);
int i;
#ifdef DEBUG_GIF
fprintf(stderr, "imagedesc...\n");
fflush(stderr);
#endif
/*
{
int Len,i,j;
Len = 1 << imageDesc->ColorMap->BitsPerPixel;
for (i = 0; i < Len; i+=4) {
for (j = 0; j < 4 && j < Len; j++) {
printf("%3d: %02xh %02xh %02xh ", i + j,
imageDesc->ColorMap->Colors[i + j].Red,
imageDesc->ColorMap->Colors[i + j].Green,
imageDesc->ColorMap->Colors[i + j].Blue);
}
printf("\n");
}
}
*/
r[0] = Val_int( imageDesc->Left );
r[1] = Val_int( imageDesc->Top );
r[2] = Val_int( imageDesc->Width );
r[3] = Val_int( imageDesc->Height );
r[4] = Val_int( imageDesc->Interlace );
r[5] = Val_ColorMapObject( imageDesc->ColorMap );
res = alloc_small(6,0);
for(i=0; i<6; i++) caml_modify_field(res, i, r[i]);
CAMLreturn(res);
}
CAMLprim value caml_weak_set (value ar, value n, value el)
{
caml_modify_field(ar, n, el);
return Val_unit;
}
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 */
}
CAMLexport void caml_modify_root(caml_root root, value newv)
{
value v = (value)root;
Assert(root);
caml_modify_field(v, 0, newv);
}
