/* 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; }