/* IN MEMORY FUNCTIONS */
value mlgz_compress(value v_lvl, value v_src, value v_pos, value v_len)
{
value v_ret;
int pos, len, out_buf_len, r;
int level = Z_BEST_COMPRESSION ;
uLong out_len;
const unsigned char *in_buf;
unsigned char *out_buf;
if(Is_block(v_lvl))
level = Int_val(Field(v_lvl, 0)) ;
pos = Int_val(v_pos);
len = Int_val(v_len);
in_buf = (unsigned char *) String_val(v_src) + pos;
if(level < 0 || level > 9
|| pos < 0 || len < 0
|| pos + len > string_length(v_src))
invalid_argument("Gz.compress");
out_buf_len = len + 12;
out_buf_len += out_buf_len / 1000;
out_buf = malloc(out_buf_len);
if(out_buf == NULL)
raise_out_of_memory();
while(1) {
out_len = out_buf_len;
r = compress2(out_buf, &out_len, in_buf, len, level);
if(r == Z_OK) {
break;
} else if(r == Z_BUF_ERROR) {
unsigned char *new_buf;
out_buf_len *= 2;
new_buf = realloc(out_buf, out_buf_len);
if(new_buf == NULL) {
free(out_buf);
raise_out_of_memory();
}
out_buf = new_buf;
} else {
free(out_buf);
raise_out_of_memory();
}
}
v_ret = alloc_string(out_len);
memcpy(String_val(v_ret), out_buf, out_len);
free(out_buf);
return v_ret ;
}
char *stat_resize (char * blk, asize_t sz)
{
char *result = (char *) realloc (blk, sz);
if (result == NULL) raise_out_of_memory ();
return result;
}
char *stat_alloc(asize_t sz)
{
char *result = (char *) malloc (sz);
if (result == NULL) raise_out_of_memory ();
return result;
}
void realloc_stack()
{
size_t size;
value * new_low, * new_high, * new_sp;
value * p;
assert(extern_sp >= stack_low);
size = stack_high - stack_low;
if (size >= Max_stack_size)
raise_out_of_memory();
size *= 2;
gc_message ("Growing stack to %ld kB.\n",
(long) size * sizeof(value) / 1024);
new_low = (value *) stat_alloc(size * sizeof(value));
new_high = new_low + size;
#define shift(ptr) \
((char *) new_high - ((char *) stack_high - (char *) (ptr)))
new_sp = (value *) shift(extern_sp);
memmove((char *)new_sp, (char *)extern_sp, (stack_high - extern_sp) * sizeof(value));
stat_free((char *) stack_low);
trapsp = (value *) shift(trapsp);
for (p = trapsp; p < new_high; p = Trap_link(p))
Trap_link(p) = (value *) shift(Trap_link(p));
stack_low = new_low;
stack_high = new_high;
stack_threshold = stack_low + Stack_threshold / sizeof (value);
extern_sp = new_sp;
#undef shift
}
value mlgz_uncompress(value v_src, value v_pos, value v_len)
{
value v_ret;
int pos, len, out_buf_len, r;
uLong out_len;
const unsigned char *in_buf;
unsigned char *out_buf;
pos = Int_val(v_pos);
len = Int_val(v_len);
in_buf = (unsigned char *) String_val(v_src) + pos;
if(pos < 0 || len < 0 || pos + len > string_length(v_src))
invalid_argument("Gz.uncompress");
out_buf_len = len * 2;
out_buf = malloc(out_buf_len);
if(out_buf == NULL)
raise_out_of_memory();
while(1) {
out_len = out_buf_len;
r = uncompress(out_buf, &out_len, in_buf, len);
if(r == Z_OK) {
break;
} else if(r == Z_BUF_ERROR) {
unsigned char *new_buf;
out_buf_len *= 2;
new_buf = realloc(out_buf, out_buf_len);
if(new_buf == NULL) {
free(out_buf);
raise_out_of_memory();
}
out_buf = new_buf;
} else if(r == Z_MEM_ERROR) {
free(out_buf);
raise_out_of_memory();
} else {
free(out_buf);
raise_mlgz_exn("uncompress");
}
}
v_ret = alloc_string(out_len);
memcpy(String_val(v_ret), out_buf, out_len);
free(out_buf);
return v_ret ;
}
value mlgz_gzopen_gen(value name, value mode)
{
gzFile str;
str = gzopen(String_val(name), String_val(mode)) ;
if(str==NULL){
if(errno==0)
raise_out_of_memory();
else
raise_sys_error(concat_strings(String_val(name), strerror(errno)));
}
return Val_ptr(str);
}
/* raise the library exception or the Sys_error exn */
static void mlgz_error(gzFile file)
{
int errnum;
const char *msg;
msg = gzerror(file, &errnum);
if(errnum < 0){
gzclose(file) ;
switch(errnum){
case Z_ERRNO :
raise_sys_error(copy_string(strerror(errno))) ;
case Z_MEM_ERROR :
raise_out_of_memory() ;
default :
raise_mlgz_exn(msg) ;
}
}
}
/* a shameless cut-and-paste from putenv.c in the caml Unix module
sources ... */
CAMLprim value sdl_putenv(value name, value val)
{
mlsize_t namelen = string_length(name);
mlsize_t vallen = string_length(val);
char * s = stat_alloc(namelen + 1 + vallen + 1);
memmove (s, String_val(name), namelen);
if(vallen > 0) {
s[namelen] = '=';
memmove (s + namelen + 1, String_val(val), vallen);
s[namelen + 1 + vallen] = 0;
}
else
s[namelen] = 0;
if (putenv(s) == -1) raise_out_of_memory();
return Val_unit;
}
EXTERN value alloc_shr (mlsize_t wosize, tag_t tag)
{
char *hp, *new_block;
hp = fl_allocate (wosize);
if (hp == NULL){
new_block = expand_heap (wosize);
if (new_block == NULL) raise_out_of_memory ();
fl_add_block (new_block);
hp = fl_allocate (wosize);
if (hp == NULL) fatal_error ("alloc_shr: expand heap failed\n");
}
Assert (Is_in_heap (Val_hp (hp)));
if (gc_phase == Phase_mark || (addr)hp >= (addr)gc_sweep_hp){
Hd_hp (hp) = Make_header (wosize, tag, Black);
}else{
Hd_hp (hp) = Make_header (wosize, tag, White);
}
allocated_words += Whsize_wosize (wosize);
if (allocated_words > Wsize_bsize (minor_heap_size)) force_minor_gc ();
return Val_hp (hp);
}
void * coq_stat_alloc (asize_t sz)
{
void * result = malloc (sz);
if (result == NULL) raise_out_of_memory ();
return result;
}