CAMLprim value
PQparamtype_stub(value __unused v_res, value __unused v_field_num)
{
caml_failwith("Postgresql.paramtype: not supported");
return Val_unit;
}
CAMLprim value malloc_trim_stub(value v_n)
{
int ret = malloc_trim(Int_val(v_n));
if (ret != 1) caml_failwith("malloc_trim");
return Val_unit;
}
CAMLprim value PQnparams_stub(value __unused v_res)
{
caml_failwith("Postgresql.nparams: not supported");
return Val_unit;
}
void hh_load_dep_table(value in_filename) {
CAMLparam1(in_filename);
caml_failwith("Program not linked with lz4, so loading is not supported!");
CAMLreturn0;
}
CAMLprim value malloc_mallopt_stub(value v_opt, value v_n)
{
int ret = mallopt(options[Int_val(v_opt)], Int_val(v_n));
if (ret != 1) caml_failwith("mallopt");
return Val_unit;
}
static inline value raise_invalid_hex_encoding()
{
caml_failwith("Postgresql.unescape_bytea_9x: invalid hex encoding");
return Val_unit;
}
PREFIX value ml_edje_object_add(value v_evas)
{
Evas_Object* obj = edje_object_add((Evas*) v_evas);
if(obj == NULL) caml_failwith("edje_object_add");
return (value) obj;
}
static void check_bigstring_proxy(struct caml_ba_array *b)
{
if (b->proxy != NULL) caml_failwith("bigstring_destroy: bigstring has proxy");
}
PREFIX value ml_elm_gesture_layer_add(value v_parent)
{
Evas_Object* obj = elm_gesture_layer_add(Evas_Object_val(v_parent));
if(obj == NULL) caml_failwith("elm_gesture_layer_add");
return copy_Evas_Object(obj);
}
CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
value vshared, value vdim, value vstart)
{
int fd, flags, major_dim, shared;
intnat num_dims, i;
intnat dim[CAML_BA_MAX_NUM_DIMS];
file_offset startpos, file_size, data_size;
struct stat st;
uintnat array_size, page, delta;
void * addr;
fd = Int_val(vfd);
flags = Int_val(vkind) | Int_val(vlayout);
startpos = File_offset_val(vstart);
num_dims = Wosize_val(vdim);
major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
/* Extract dimensions from OCaml array */
num_dims = Wosize_val(vdim);
if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
for (i = 0; i < num_dims; i++) {
dim[i] = Long_val(Field(vdim, i));
if (dim[i] == -1 && i == major_dim) continue;
if (dim[i] < 0)
caml_invalid_argument("Bigarray.create: negative dimension");
}
/* Determine file size. We avoid lseek here because it is fragile,
and because some mappable file types do not support it
*/
caml_enter_blocking_section();
if (fstat(fd, &st) == -1) {
caml_leave_blocking_section();
caml_sys_error(NO_ARG);
}
file_size = st.st_size;
/* Determine array size in bytes (or size of array without the major
dimension if that dimension wasn't specified) */
array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
for (i = 0; i < num_dims; i++)
if (dim[i] != -1) array_size *= dim[i];
/* Check if the major dimension is unknown */
if (dim[major_dim] == -1) {
/* Determine major dimension from file size */
if (file_size < startpos) {
caml_leave_blocking_section();
caml_failwith("Bigarray.mmap: file position exceeds file size");
}
data_size = file_size - startpos;
dim[major_dim] = (uintnat) (data_size / array_size);
array_size = dim[major_dim] * array_size;
if (array_size != data_size) {
caml_leave_blocking_section();
caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
}
} else {
/* Check that file is large enough, and grow it otherwise */
if (file_size < startpos + array_size) {
if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
caml_leave_blocking_section();
caml_sys_error(NO_ARG);
}
}
}
/* Determine offset so that the mapping starts at the given file pos */
page = getpagesize();
delta = (uintnat) startpos % page;
/* Do the mmap */
shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
if (array_size > 0)
addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
shared, fd, startpos - delta);
else
addr = NULL; /* PR#5463 - mmap fails on empty region */
caml_leave_blocking_section();
if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG);
addr = (void *) ((uintnat) addr + delta);
/* Build and return the OCaml bigarray */
return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
}
CAMLprim value ml_text_recode_string(value enc_src, value enc_dst, value str)
{
CAMLparam3(str, enc_src, enc_dst);
CAMLlocal1(result);
iconv_t cd = iconv_open(String_val(enc_dst), String_val(enc_src));
if (cd == (iconv_t)-1)
caml_failwith("Encoding.recode_string: invalid encoding");
/* Length of the output buffer. It is initialised to the length of
the input string, which should be a good
approximation: */
size_t len = caml_string_length(str);
/* Pointer to the beginning of the output buffer. The +1 is for the
NULL terminating byte. */
char *dst_buffer = malloc(len + 1);
if (dst_buffer == NULL)
caml_failwith("Encoding.recode_string: out of memory");
/* iconv arguments */
char *src_bytes = String_val(str);
char *dst_bytes = dst_buffer;
size_t src_remaining = len;
size_t dst_remaining = len;
while (src_remaining) {
size_t count = iconv (cd, &src_bytes, &src_remaining, &dst_bytes, &dst_remaining);
if (count == (size_t) -1) {
switch (errno) {
case EILSEQ:
free(dst_buffer);
iconv_close(cd);
caml_failwith("Encoding.recode_string: invalid multibyte sequence found in the input");
case EINVAL:
free(dst_buffer);
iconv_close(cd);
caml_failwith("Encoding.recode_string: incomplete multibyte sequence found in the input");
case E2BIG: {
/* Ouput offest relative to the beginning of the destination
buffer: */
size_t offset = dst_bytes - dst_buffer;
/* Try with a buffer 2 times bigger: */
len *= 2;
dst_buffer = realloc(dst_buffer, len + 1);
if (dst_buffer == NULL)
caml_failwith("Encoding.recode_string: out of memory");
dst_bytes = dst_buffer + offset;
dst_remaining += len;
break;
}
default:
free(dst_buffer);
iconv_close(cd);
caml_failwith("Encoding.recode_string: unknown error");
}
}
};
*dst_bytes = 0;
result = caml_alloc_string(dst_bytes - dst_buffer);
memcpy(String_val(result), dst_buffer, dst_bytes - dst_buffer);
/* Clean-up */
free(dst_buffer);
iconv_close(cd);
CAMLreturn(result);
}
void ocamlcc_dynlink_error(void) {
caml_failwith("OCamlCC: dynlink not implemented");
}
CAMLprim value caml_new_lex_engine(struct lexing_table *tbl, value start_state,
struct lexer_buffer *lexbuf)
{
int state, base, backtrk, c, pstate ;
state = Int_val(start_state);
if (state >= 0) {
/* First entry */
lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos;
lexbuf->lex_last_action = Val_int(-1);
} else {
/* Reentry after refill */
state = -state - 1;
}
while(1) {
/* Lookup base address or action number for current state */
base = Short(tbl->lex_base, state);
if (base < 0) {
int pc_off = Short(tbl->lex_base_code, state) ;
run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem);
/* fprintf(stderr,"Perform: %d\n",-base-1) ; */
return Val_int(-base-1);
}
/* See if it's a backtrack point */
backtrk = Short(tbl->lex_backtrk, state);
if (backtrk >= 0) {
int pc_off = Short(tbl->lex_backtrk_code, state);
run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem);
lexbuf->lex_last_pos = lexbuf->lex_curr_pos;
lexbuf->lex_last_action = Val_int(backtrk);
}
/* See if we need a refill */
if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){
if (lexbuf->lex_eof_reached == Val_bool (0)){
return Val_int(-state - 1);
}else{
c = 256;
}
}else{
/* Read next input char */
c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos));
lexbuf->lex_curr_pos += 2;
}
/* Determine next state */
pstate=state ;
if (Short(tbl->lex_check, base + c) == state)
state = Short(tbl->lex_trans, base + c);
else
state = Short(tbl->lex_default, state);
/* If no transition on this char, return to last backtrack point */
if (state < 0) {
lexbuf->lex_curr_pos = lexbuf->lex_last_pos;
if (lexbuf->lex_last_action == Val_int(-1)) {
caml_failwith("lexing: empty token");
} else {
return lexbuf->lex_last_action;
}
}else{
/* If some transition, get and perform memory moves */
int base_code = Short(tbl->lex_base_code, pstate) ;
int pc_off ;
if (Short(tbl->lex_check_code, base_code + c) == pstate)
pc_off = Short(tbl->lex_trans_code, base_code + c) ;
else
pc_off = Short(tbl->lex_default_code, pstate) ;
if (pc_off > 0)
run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, lexbuf->lex_curr_pos) ;
/* Erase the EOF condition only if the EOF pseudo-character was
consumed by the automaton (i.e. there was no backtrack above)
*/
if (c == 256) lexbuf->lex_eof_reached = Val_bool (0);
}
}
}
void hh_load(value in_filename) {
CAMLparam1(in_filename);
FILE* fp = fopen(String_val(in_filename), "rb");
if (fp == NULL) {
caml_failwith("Failed to open file");
}
uint64_t magic = 0;
read_all(fileno(fp), (void*)&magic, sizeof magic);
assert(magic == MAGIC_CONSTANT);
size_t revlen = 0;
read_all(fileno(fp), (void*)&revlen, sizeof revlen);
char revision[revlen];
read_all(fileno(fp), (void*)revision, revlen * sizeof(char));
assert(strncmp(revision, BuildInfo_kRevision, revlen) == 0);
read_all(fileno(fp), (void*)&heap_init_size, sizeof heap_init_size);
int compressed_size = 0;
read_all(fileno(fp), (void*)&compressed_size, sizeof compressed_size);
char* chunk_start = (char*)SAVE_START;
pthread_attr_t attr;
pthread_attr_init(&attr);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
pthread_t thread;
decompress_args args;
int thread_started = 0;
// see hh_save for a description of what we are parsing here.
while (compressed_size > 0) {
char* compressed = malloc(compressed_size * sizeof(char));
assert(compressed != NULL);
uintptr_t chunk_size = 0;
read_all(fileno(fp), (void*)&chunk_size, sizeof chunk_size);
read_all(fileno(fp), compressed, compressed_size * sizeof(char));
if (thread_started) {
intptr_t success = 0;
int rc = pthread_join(thread, (void*)&success);
free(args.compressed);
assert(rc == 0);
assert(success);
}
args.compressed = compressed;
args.compressed_size = compressed_size;
args.decompress_start = chunk_start;
args.decompressed_size = chunk_size;
pthread_create(&thread, &attr, (void* (*)(void*))decompress, &args);
thread_started = 1;
chunk_start += chunk_size;
read_all(fileno(fp), (void*)&compressed_size, sizeof compressed_size);
}
if (thread_started) {
int success;
int rc = pthread_join(thread, (void*)&success);
free(args.compressed);
assert(rc == 0);
assert(success);
}
fclose(fp);
CAMLreturn0;
}
CAMLprim value
PQsendDescribePortal_stub(value __unused v_conn, value __unused v_portal_name)
{
caml_failwith("Postgresql.send_describe_portal: not supported");
return Val_unit;
}
static void extern_failwith(char *msg)
{
extern_replay_trail();
free_extern_output();
caml_failwith(msg);
}
CAMLprim value
PQsetSingleRowMode_stub(value __unused conn)
{
caml_failwith("Postgresql.set_single_row_mode: not supported");
return Val_unit;
}
void hh_save_dep_table(value out_filename) {
CAMLparam1(out_filename);
caml_failwith("Program not linked with lz4, so saving is not supported!");
CAMLreturn0;
}
CAMLprim value
caml_SDL_RenderCopyEx(
value renderer,
value texture,
value _srcrect,
value _dstrect,
value angle,
value _center,
value flip,
value unit)
{
SDL_Rect srcrect;
SDL_Rect *srcrect_;
SDL_Rect dstrect;
SDL_Rect *dstrect_;
SDL_Point center;
SDL_Point *center_;
double angle_;
SDL_RendererFlip flip_;
if (_srcrect == Val_none) {
srcrect_ = NULL;
} else {
SDL_Rect_val(&srcrect, Some_val(_srcrect));
srcrect_ = &srcrect;
}
if (_dstrect == Val_none) {
dstrect_ = NULL;
} else {
SDL_Rect_val(&dstrect, Some_val(_dstrect));
dstrect_ = &dstrect;
}
if (_center == Val_none) {
center_ = NULL;
} else {
SDL_Point_val(¢er, Some_val(_center));
center_ = ¢er;
}
angle_ =
(angle == Val_none
? 0.0
: Double_val(Some_val(angle))
);
flip_ =
(flip == Val_none
? SDL_FLIP_NONE
: SDL_RendererFlip_val(Some_val(flip))
);
int r =
SDL_RenderCopyEx(
SDL_Renderer_val(renderer),
SDL_Texture_val(texture),
srcrect_,
dstrect_,
angle_,
center_,
flip_);
if (r)
caml_failwith("Sdlrender.copyEx");
return Val_unit;
}
PREFIX value ml_elm_win_inwin_add(value v_parent)
{
Evas_Object* obj = elm_win_inwin_add((Evas_Object*) v_parent);
if(obj == NULL) caml_failwith("elm_win_inwin_add");
return (value) obj;
}
