static int jacfn(
realtype t,
N_Vector y,
N_Vector fy,
SlsMat Jac,
void *user_data,
N_Vector tmp1,
N_Vector tmp2,
N_Vector tmp3)
{
CAMLparam0();
CAMLlocalN (args, 2);
CAMLlocal3(session, cb, smat);
WEAK_DEREF (session, *(value*)user_data);
args[0] = sunml_cvode_make_jac_arg (t, y, fy,
sunml_cvode_make_triple_tmp (tmp1, tmp2, tmp3));
cb = CVODE_LS_CALLBACKS_FROM_ML(session);
cb = Field (cb, 0);
// always rewrap without caching (simplified backwards compatibility)
args[1] = sunml_matrix_sparse_wrap(Jac);
/* NB: Don't trigger GC while processing this return value! */
value r = caml_callbackN_exn (Field(cb, 0), 2, args);
CAMLreturnT(int, CHECK_EXCEPTION(session, r, RECOVERABLE));
}
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 proc_start( const char* logdir,
const uint32_t analysis_id,
const char* sockname,
bool debug_flag,
const THREADID tid,
char** argvp,
int envc,
char** envp )
{
CAMLparam0();
CAMLlocalN( caml_args, 8 );
static value *proc_start_closure = NULL;
if ( !proc_start_closure ) {
proc_start_closure = caml_named_value( "proc_start" );
}
caml_args[0] = caml_copy_string( logdir );
caml_args[1] = caml_copy_int32( analysis_id );
caml_args[2] = caml_copy_string( sockname );
caml_args[3] = Val_bool( debug_flag );
caml_args[4] = Val_int( tid );
caml_args[5] = caml_copy_nativeint( (long) argvp );
caml_args[6] = caml_copy_int32( envc );
caml_args[7] = caml_copy_nativeint( (long) envp );
caml_callbackN( *proc_start_closure, 8, caml_args );
CAMLreturn0;
}
static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
const char *context,
const char *doing_what /* no \r,\n */,
int percent, unsigned long done, unsigned long total)
{
caml_leave_blocking_section();
CAMLparam0();
CAMLlocalN(args, 5);
struct caml_xtl *xtl = (struct caml_xtl*)logger;
value *func = caml_named_value(xtl->progress_cb) ;
if (func == NULL)
caml_raise_sys_error(caml_copy_string("Unable to find callback"));
/* progress : string option -> string -> int -> int64 -> int64 -> unit; */
args[0] = Val_context(context);
args[1] = caml_copy_string(doing_what);
args[2] = Val_int(percent);
args[3] = caml_copy_int64(done);
args[4] = caml_copy_int64(total);
caml_callbackN(*func, 5, args);
CAMLdone;
caml_enter_blocking_section();
}
static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
xentoollog_level level,
int errnoval,
const char *context,
const char *format,
va_list al)
{
caml_leave_blocking_section();
CAMLparam0();
CAMLlocalN(args, 4);
struct caml_xtl *xtl = (struct caml_xtl*)logger;
value *func = caml_named_value(xtl->vmessage_cb) ;
char *msg;
if (func == NULL)
caml_raise_sys_error(caml_copy_string("Unable to find callback"));
if (vasprintf(&msg, format, al) < 0)
caml_raise_out_of_memory();
/* vmessage : level -> int option -> string option -> string -> unit; */
args[0] = Val_level(level);
args[1] = Val_errno(errnoval);
args[2] = Val_context(context);
args[3] = caml_copy_string(msg);
free(msg);
caml_callbackN(*func, 4, args);
CAMLdone;
caml_enter_blocking_section();
}
Hunpos hunpos_tagger_new(const char* model_file, const char* morph_table_file, int max_guessed_tags, int theta, int* error)
{
*error = 0;
if(model_file == NULL) {
*error = 3;
return NULL;
}
if(morph_table_file == NULL) {
morph_table_file = "";
}
/* Startup OCaml */
if (is_initialized == 0)
{
is_initialized = 1;
char* dummyargv[2];
dummyargv[0]="";
dummyargv[1]=NULL;
caml_startup(dummyargv);
}
CAMLparam0();
/* get hunpos init function from ocaml */
static value* init_fun;
if (init_fun == NULL)
{
init_fun = caml_named_value("init_from_files");
}
Hunpos tagger_fun = (Hunpos) malloc(sizeof(value));
*((value*)tagger_fun) = 0;
// we pass some argument to the function
CAMLlocalN ( args, 4 );
args[0] = caml_copy_string(model_file);
args[1] = caml_copy_string(morph_table_file);
args[2] = Val_int(max_guessed_tags);
args[3] = Val_int(theta);
/* due to the garbage collector we have to register the */
/* returned value not to be deallocated */
caml_register_global_root(tagger_fun);
value* t = tagger_fun;
*t = caml_callbackN_exn( *init_fun, 4, args );
if (Is_exception_result(*t))
{
*error = 1;
CAMLreturnT(Hunpos, NULL);
}
// CAMLreturn1(tagger_fun)
CAMLreturnT(Hunpos,tagger_fun);
}
static int jacfn_withsens( /* IDASlsSparseJacFnB */
realtype t,
realtype cjB,
N_Vector yy,
N_Vector yp,
N_Vector *ys,
N_Vector *yps,
N_Vector yyB,
N_Vector ypB,
N_Vector resvalB,
SlsMat jacB,
void *user_data,
N_Vector tmp1B,
N_Vector tmp2B,
N_Vector tmp3B)
{
CAMLparam0();
CAMLlocalN(args, 4);
CAMLlocal4(session, bsensext, cb, smat);
WEAK_DEREF (session, *(value*)user_data);
bsensext = IDA_SENSEXT_FROM_ML(session);
cb = IDA_LS_CALLBACKS_FROM_ML(session);
cb = Field (cb, 0);
args[0] = sunml_idas_make_jac_arg(t, yy, yp, yyB, ypB, resvalB, cjB,
sunml_ida_make_triple_tmp (tmp1B, tmp2B, tmp3B));
int ns = Int_val(Field(bsensext, RECORD_IDAS_BWD_SESSION_NUMSENSITIVITIES));
args[1] = IDAS_BSENSARRAY1_FROM_EXT(bsensext);
sunml_idas_wrap_to_nvector_table(ns, args[1], ys);
args[2] = IDAS_BSENSARRAY2_FROM_EXT(bsensext);
sunml_idas_wrap_to_nvector_table(ns, args[2], yps);
smat = Field(cb, 1);
if (smat == Val_none) {
Store_some(smat, sunml_matrix_sparse_wrap(jacB));
Store_field(cb, 1, smat);
args[3] = Some_val(smat);
} else {
args[3] = Some_val(smat);
sunml_matrix_sparse_rewrap(args[3]);
}
/* NB: Don't trigger GC while processing this return value! */
value r = caml_callbackN_exn (Field(cb, 0), 4, args);
CAMLreturnT(int, CHECK_EXCEPTION(session, r, RECOVERABLE));
}
//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;
}
static int callml_custom_solve(SUNLinearSolver ls, SUNMatrix A, N_Vector x,
N_Vector b, realtype tol)
{
CAMLparam0();
CAMLlocal1(r);
CAMLlocalN(args, 4);
Store_field(args, 0, (A == NULL) ? Val_unit : MAT_BACKLINK(A));
Store_field(args, 1, NVEC_BACKLINK(x));
Store_field(args, 2, NVEC_BACKLINK(b));
Store_field(args, 3, caml_copy_double(tol));
r = caml_callbackN_exn(GET_OP(ls, SOLVE), 4, args);
CAMLreturnT(int, CHECK_EXCEPTION_SUCCESS(r));
}
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_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);
}
static int jacfn_nosens( /* IDASlsSparseJacFnB */
realtype t,
realtype cjB,
N_Vector yy,
N_Vector yp,
N_Vector yyB,
N_Vector ypB,
N_Vector resvalB,
SlsMat jacB,
void *user_data,
N_Vector tmp1B,
N_Vector tmp2B,
N_Vector tmp3B)
{
CAMLparam0();
CAMLlocalN(args, 2);
CAMLlocal3(session, cb, smat);
WEAK_DEREF (session, *(value*)user_data);
cb = IDA_LS_CALLBACKS_FROM_ML(session);
cb = Field (cb, 0);
args[0] = sunml_idas_make_jac_arg(t, yy, yp, yyB, ypB, resvalB, cjB,
sunml_ida_make_triple_tmp (tmp1B, tmp2B, tmp3B));
smat = Field(cb, 1);
if (smat == Val_none) {
Store_some(smat, sunml_matrix_sparse_wrap(jacB));
Store_field(cb, 1, smat);
args[1] = Some_val(smat);
} else {
args[1] = Some_val(smat);
sunml_matrix_sparse_rewrap(args[1]);
}
/* NB: Don't trigger GC while processing this return value! */
value r = caml_callbackN_exn (Field(cb, 0), 2, args);
CAMLreturnT(int, CHECK_EXCEPTION(session, r, RECOVERABLE));
}
int bbl_instrument( unsigned long addr,
const bbl_content* content,
const reg_context* context,
const THREADID tid )
{
CAMLparam0();
CAMLlocal1( ret );
CAMLlocalN( caml_args, 5 );
unsigned i, j;
uint32_t size = (uint32_t) content->size;
static value *bbl_instrument_closure = NULL;
if ( !bbl_instrument_closure ) {
bbl_instrument_closure = caml_named_value( "bbl_instrument" );
}
caml_args[0] = caml_copy_nativeint( addr );
caml_args[1] = caml_copy_int32( size );
caml_args[2] = caml_alloc_string( size );
memcpy( (unsigned char*)String_val(caml_args[2]), content->content, size );
caml_args[3] = caml_alloc_tuple( 45 );
for ( i = 0; i < 20; ++i ) {
Store_field( caml_args[3], i, caml_copy_nativeint( ((long*) &context->eax)[i] ) );
}
for ( i = 20; i < 29; ++i ) {
Store_field( caml_args[3], i, Val_bool( ((long*) &context->eax)[i] ) );
}
for ( i = 29, j = 0; i < 45; ++i ) {
Store_field( caml_args[3], i, caml_copy_int64( ((uint64_t*) &context->xmm0)[j++] ) );
Store_field( caml_args[3], i, caml_copy_int64( ((uint64_t*) &context->xmm0)[j++] ) );
}
caml_args[4] = Val_int( tid );
ret = caml_callbackN( *bbl_instrument_closure, 5, caml_args );
CAMLreturnT( int, Int_val(ret) );
}
void stub_raise_if(int condition) {
CAMLparam0 ();
CAMLlocalN(error_parameters, 2);
if(condition) {
int error_to_raise = EUNKNOWN;
int current_errno = zmq_errno();
int i;
for (i = 0; i < EUNKNOWN; i++) {
if (current_errno == stub_error_table[i]) {
error_to_raise = i;
break;
}
}
error_parameters[0] = Val_int(error_to_raise);
error_parameters[1] = caml_copy_string(zmq_strerror(current_errno));
caml_raise_with_args(
*ZMQ_EXCEPTION_NAME,
2,
error_parameters);
}
CAMLreturn0;
}
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);
}
void symbolic_read( ADDRINT addr,
ADDRINT pos,
ADDRINT ret,
ADDRINT totalsize,
const char* fname )
{
CAMLparam0();
CAMLlocalN( caml_args, 5 );
static value *proc_symbolic_read = NULL;
if ( !proc_symbolic_read ) {
proc_symbolic_read = caml_named_value( "symbolic_read" );
}
caml_args[0] = caml_copy_nativeint( (long) addr );
caml_args[1] = caml_copy_nativeint( (long) pos );
caml_args[2] = Val_int( (int) ret );
caml_args[3] = Val_int( (int) totalsize );
caml_args[4] = caml_copy_string( fname );
caml_callbackN( *proc_symbolic_read, 5, caml_args );
CAMLreturn0;
}
extern "C" void
monda_val_print (struct type* type, struct frame_info* frame,
int embedded_offset, CORE_ADDR address,
struct ui_file* stream, int recurse, struct value* val,
const struct value_print_options* options, int depth,
int max_string_length, int only_print_short_type,
int only_print_short_value)
{
CAMLparam0();
CAMLlocal4(v_type, v_stream, v_value, v_search_path);
CAMLlocal2(v_val, v_frame);
CAMLlocalN(args, 12);
static caml_value* callback = NULL;
int is_synthetic_pointer;
const gdb_byte* valaddr;
/* The try/catch is required so we don't leave local roots incorrectly
registered in the case of an exception.
We also ensure that any GDB function we call from the OCaml code
invoked below (via [caml_callbackN]) never throws any exceptions
across the OCaml -> C boundary. If it were to, then we would fail to
run the second part of the [caml_start_program] code, causing global
variables (e.g. [caml_last_return_address]) to be set incorrectly. */
TRY {
if (callback == NULL) {
callback = caml_named_value("From_gdb_ocaml.print_value");
assert (callback != NULL);
}
valaddr = value_contents_for_printing(val);
v_value =
(valaddr == NULL) ? caml_copy_nativeint(0)
: caml_copy_nativeint(*(intnat*) valaddr);
/* Determine whether the value is actually a construction made up in the
debugger's address space by virtue of interpreting DW_OP_implicit_pointer.
The second part of this conditional is really just a sanity check.
*/
is_synthetic_pointer =
(value_lval_const(val) == lval_computed
&& value_bits_synthetic_pointer(val, 0, sizeof(CORE_ADDR) * 8));
/*
fprintf(stderr, "monda_val_print. SP %d *valaddr=%p v_value=%p value_lval_const=%d lval_funcs=%p lazy=%d\n",
is_synthetic_pointer,
(void*) *(intnat*) valaddr,
(void*) v_value,
(int) (value_lval_const(val)),
value_lval_const(val) == lval_computed ? value_computed_funcs(val) : NULL,
value_lazy(val));
*/
/* CR mshinwell: improve this test */
#if 0
if ((TYPE_NAME(type) == NULL && !is_synthetic_pointer)
|| (is_synthetic_pointer && TYPE_CODE(type) != TYPE_CODE_PTR)) {
/*
fprintf(stderr, "monda_val_print -> c_val_print (1)\n");
fflush(stderr);
*/
c_val_print(type, frame, valaddr, embedded_offset, address, stream,
recurse, val, options, depth);
}
else
#endif
{
v_type = caml_copy_string(TYPE_NAME(type) == NULL ? "" : TYPE_NAME(type));
v_stream = caml_copy_int64((uint64_t) stream);
v_search_path = caml_copy_string(""); /* CR mshinwell: remove */
v_val = caml_copy_nativeint((intnat) val);
v_frame = caml_copy_nativeint((intnat) frame);
/* N.B. [Store_field] must not be used on [args]! */
args[0] = Val_bool(is_synthetic_pointer);
args[1] = v_value;
args[2] = v_val;
args[3] = v_stream;
args[4] = v_type;
args[5] = Val_bool(options->summary);
args[6] = Val_long(depth);
args[7] = Val_long(max_string_length);
args[8] = v_search_path;
args[9] = Val_bool(only_print_short_type);
args[10] = Val_bool(only_print_short_value);
args[11] = v_frame;
/*
fprintf(stderr, "monda_val_print -> OCaml printer. Type '%s'\n", TYPE_NAME(type));
fflush(stderr);
*/
/* CR mshinwell: This should catch any OCaml exceptions. */
if (caml_callbackN(*callback, 12, args) == Val_false) {
/*
fprintf(stderr, "monda_val_print -> c_val_print (2)\n");
fflush(stderr);
*/
c_val_print (type, frame, embedded_offset, address, stream, recurse,
val, options);
}
}
}
CATCH (exn, RETURN_MASK_ALL) {
fprintf(stderr, "monda_val_print: exception: %s\n",
exn.message ? exn.message : "<no message>");
CAMLdrop;
throw_exception(exn);
}
CAMLprim value open_jpeg_file_for_read(value name) {
CAMLparam1(name);
CAMLlocal1(res);
char *filename;
/* This struct contains the JPEG decompression parameters and pointers to
* working space (which is allocated as needed by the JPEG library).
*/
struct jpeg_decompress_struct* cinfop;
/* We use our private extension JPEG error handler.
* Note that this struct must live as long as the main JPEG parameter
* struct, to avoid dangling-pointer problems.
*/
struct my_error_mgr *jerrp;
/* More stuff */
FILE * infile; /* source file */
int i;
filename= String_val(name);
if ((infile = fopen(filename, "rb")) == NULL) {
failwith("failed to open jpeg file");
}
cinfop = malloc(sizeof (struct jpeg_decompress_struct));
jerrp = malloc(sizeof (struct my_error_mgr));
/* In this example we want to open the input file before doing anything else,
* so that the setjmp() error recovery below can assume the file is open.
* VERY IMPORTANT: use "b" option to fopen() if you are on a machine that
* requires it in order to read binary files.
*/
/* Step 1: allocate and initialize JPEG decompression object */
/* We set up the normal JPEG error routines, then override error_exit. */
cinfop->err = jpeg_std_error(&jerrp->pub);
jerrp->pub.error_exit = my_error_exit;
/* Establish the setjmp return context for my_error_exit to use. */
if (setjmp(jerrp->setjmp_buffer)) {
/* If we get here, the JPEG code has signaled an error.
* We need to clean up the JPEG object, close the input file, and return.
*/
jpeg_destroy_decompress(cinfop);
free(jerrp);
fclose(infile);
failwith(jpg_error_message);
}
/* Now we can initialize the JPEG decompression object. */
jpeg_create_decompress(cinfop);
/* Step 2: specify data source (eg, a file) */
jpeg_stdio_src(cinfop, infile);
/* Step 3: read file parameters with jpeg_read_header() */
(void) jpeg_read_header(cinfop, TRUE);
{
CAMLlocalN(r,3);
r[0] = Val_int(cinfop->image_width);
r[1] = Val_int(cinfop->image_height);
r[2] = alloc_tuple(3);
Field(r[2], 0) = (value)cinfop;
Field(r[2], 1) = (value)infile;
Field(r[2], 2) = (value)jerrp;
res = alloc_tuple(3);
for(i=0; i<3; i++) Field(res, i) = r[i];
}
CAMLreturn(res);
}
CAMLprim value open_jpeg_file_for_read_start(value jpegh) {
CAMLparam1(jpegh);
CAMLlocal1(res);
struct jpeg_decompress_struct* cinfop;
struct my_error_mgr *jerrp;
FILE *infile;
int i;
cinfop = (struct jpeg_decompress_struct *) Field(jpegh, 0);
infile = (FILE *) Field(jpegh, 1);
jerrp = (struct my_error_mgr *) Field(jpegh, 2);
/* We can ignore the return value from jpeg_read_header since
* (a) suspension is not possible with the stdio data source, and
* (b) we passed TRUE to reject a tables-only JPEG file as an error.
* See libjpeg.doc for more info.
*/
/* Step 4: set parameters for decompression */
/* In this example, we don't need to change any of the defaults set by
* jpeg_read_header(), so we do nothing here.
*/
cinfop->out_color_space = JCS_RGB;
/* Step 5: Start decompressor */
(void) jpeg_start_decompress(cinfop);
/* We can ignore the return value since suspension is not possible
* with the stdio data source.
*/
/* We may need to do some setup of our own at this point before reading
* the data. After jpeg_start_decompress() we have the correct scaled
* output image dimensions available, as well as the output colormap
* if we asked for color quantization.
* In this example, we need to make an output work buffer of the right size.
*/
/* JSAMPLEs per row in output buffer */
/* row_stride = cinfop->output_width * cinfop->output_components; */
{
CAMLlocalN(r,3);
// CR jfuruse: integer overflow
r[0] = Val_int(cinfop->output_width);
r[1] = Val_int(cinfop->output_height);
r[2] = alloc_tuple(3);
Field(r[2], 0) = (value)cinfop;
Field(r[2], 1) = (value)infile;
Field(r[2], 2) = (value)jerrp;
res = alloc_tuple(3);
for(i=0; i<3; i++) Field(res, i) = r[i];
}
#ifdef DEBUG_JPEG
fprintf(stderr, "cinfop= %d infile= %d %d %d \n", cinfop, infile, cinfop->output_scanline, cinfop->output_height);
fflush(stderr);
#endif
CAMLreturn(res);
}
read_JPEG_file (value name)
{
CAMLparam1(name);
CAMLlocal1(res);
char *filename;
/* This struct contains the JPEG decompression parameters and pointers to
* working space (which is allocated as needed by the JPEG library).
*/
struct jpeg_decompress_struct cinfo;
/* We use our private extension JPEG error handler.
* Note that this struct must live as long as the main JPEG parameter
* struct, to avoid dangling-pointer problems.
*/
struct my_error_mgr jerr;
/* More stuff */
FILE * infile; /* source file */
JSAMPARRAY buffer; /* Output row buffer */
int row_stride; /* physical row width in output buffer */
int i;
filename= String_val( name );
/* In this example we want to open the input file before doing anything else,
* so that the setjmp() error recovery below can assume the file is open.
* VERY IMPORTANT: use "b" option to fopen() if you are on a machine that
* requires it in order to read binary files.
*/
if ((infile = fopen(filename, "rb")) == NULL) {
failwith("failed to open jpeg file");
}
/* Step 1: allocate and initialize JPEG decompression object */
/* We set up the normal JPEG error routines, then override error_exit. */
cinfo.err = jpeg_std_error(&jerr.pub);
jerr.pub.error_exit = my_error_exit;
/* Establish the setjmp return context for my_error_exit to use. */
if (setjmp(jerr.setjmp_buffer)) {
/* If we get here, the JPEG code has signaled an error.
* We need to clean up the JPEG object, close the input file, and return.
*/
fprintf(stderr, "Exiting...");
jpeg_destroy_decompress(&cinfo);
fclose(infile);
exit(-1);
failwith(jpg_error_message);
}
/* Now we can initialize the JPEG decompression object. */
jpeg_create_decompress(&cinfo);
/* Step 2: specify data source (eg, a file) */
jpeg_stdio_src(&cinfo, infile);
/* Step 3: read file parameters with jpeg_read_header() */
(void) jpeg_read_header(&cinfo, TRUE);
/* We can ignore the return value from jpeg_read_header since
* (a) suspension is not possible with the stdio data source, and
* (b) we passed TRUE to reject a tables-only JPEG file as an error.
* See libjpeg.doc for more info.
*/
/* Step 4: set parameters for decompression */
/* In this example, we don't need to change any of the defaults set by
* jpeg_read_header(), so we do nothing here.
*/
cinfo.out_color_space = JCS_RGB;
/* Step 5: Start decompressor */
(void) jpeg_start_decompress(&cinfo);
/* We can ignore the return value since suspension is not possible
* with the stdio data source.
*/
/* We may need to do some setup of our own at this point before reading
* the data. After jpeg_start_decompress() we have the correct scaled
* output image dimensions available, as well as the output colormap
* if we asked for color quantization.
* In this example, we need to make an output work buffer of the right size.
*/
/* JSAMPLEs per row in output buffer */
if( oversized(cinfo.output_width, cinfo.output_components) ){
jpeg_destroy_decompress(&cinfo);
fclose(infile);
failwith_oversized("jpeg");
}
row_stride = cinfo.output_width * cinfo.output_components;
/* Make a one-row-high sample array that will go away when done with image */
buffer = (*cinfo.mem->alloc_sarray)
((j_common_ptr) &cinfo, JPOOL_IMAGE, row_stride,
cinfo.output_height );
/* Step 6: while (scan lines remain to be read) */
/* jpeg_read_scanlines(...); */
/* Here we use the library's state variable cinfo.output_scanline as the
* loop counter, so that we don't have to keep track ourselves.
*/
while (cinfo.output_scanline < cinfo.output_height) {
/* jpeg_read_scanlines expects an array of pointers to scanlines.
* Here the array is only one element long, but you could ask for
* more than one scanline at a time if that's more convenient.
*/
jpeg_read_scanlines(&cinfo, buffer + cinfo.output_scanline, 1);
}
if( oversized(row_stride, cinfo.output_height) ){
jpeg_destroy_decompress(&cinfo);
fclose(infile);
failwith_oversized("jpeg");
}
{
CAMLlocalN(r,3);
r[0] = Val_int(cinfo.output_width);
r[1] = Val_int(cinfo.output_height);
r[2] = alloc_string ( row_stride * cinfo.output_height );
for(i=0; i<cinfo.output_height; i++){
memcpy( String_val(r[2]) + i * row_stride,
buffer[i], row_stride);
}
res = alloc_tuple(3);
for(i=0; i<3; i++) Field(res, i) = r[i];
}
/* Step 7: Finish decompression */
(void) jpeg_finish_decompress(&cinfo);
/* We can ignore the return value since suspension is not possible
* with the stdio data source.
*/
/* Step 8: Release JPEG decompression object */
/* This is an important step since it will release a good deal of memory. */
jpeg_destroy_decompress(&cinfo);
/* After finish_decompress, we can close the input file.
* Here we postpone it until after no more JPEG errors are possible,
* so as to simplify the setjmp error logic above. (Actually, I don't
* think that jpeg_destroy can do an error exit, but why assume anything...)
*/
fclose(infile);
/* At this point you may want to check to see whether any corrupt-data
* warnings occurred (test whether jerr.pub.num_warnings is nonzero).
*/
/* And we're done! */
CAMLreturn(res);
}
