CAMLprim value ml_gtk_widget_get_pointer (value w) { int x,y; value ret; gtk_widget_get_pointer (GtkWidget_val(w), &x, &y); ret = alloc_small (2,0); Field(ret,0) = Val_int(x); Field(ret,1) = Val_int(y); return ret; }
CAMLprim value ml_gsl_stats_minmax_index(value data) { size_t len = Double_array_length(data); size_t mi, ma; value r; gsl_stats_minmax_index(&mi, &ma, Double_array_val(data), 1, len); r = alloc_small(2, 0); Field(r, 0) = Val_int(mi); Field(r, 1) = Val_int(ma); return r; }
static value val_of_result_pair (gsl_sf_result *re, gsl_sf_result *im) { CAMLparam0 (); CAMLlocal3 (v, v_re, v_im); v_re = val_of_result (re); v_im = val_of_result (im); v = alloc_small (2, 0); Field (v, 0) = v_re; Field (v, 1) = v_im; CAMLreturn (v); }
CAMLprim value ml_gdk_window_get_pointer_location (value window) { int x = 0; int y = 0; value ret; gdk_window_get_pointer (GdkWindow_val(window), &x, &y, NULL); ret = alloc_small (2, 0); Field(ret, 0) = Val_int(x); Field(ret, 1) = Val_int(y); return ret; }
static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, int button, int keypressed, int key) { value res = alloc_small(5, 0); Field(res, 0) = Val_int(mouse_x); Field(res, 1) = Val_int(mouse_y == -1 ? -1 : Wcvt(mouse_y)); Field(res, 2) = Val_bool(button); Field(res, 3) = Val_bool(keypressed); Field(res, 4) = Val_int(key & 0xFF); return res; }
static value value_of_keyevent(SDL_KeyboardEvent keyevt) { CAMLparam0(); CAMLlocal2(v, r); Uint8 char_code = 0; tag_t tag; r = alloc_small(6, 0); Field(r, 0) = Val_int(keyevt.which) ; Field(r, 1) = keyevt.state == SDL_RELEASED ? Val_int(0) : Val_int(1); Field(r, 2) = find_mlsdl_keysym(keyevt.keysym.sym) ; Field(r, 3) = Val_int(keyevt.keysym.mod) ; if (keyevt.keysym.unicode <= 0x7F) char_code = keyevt.keysym.unicode; Field(r, 4) = Val_int(char_code); Field(r, 5) = Val_long(keyevt.keysym.unicode); tag = keyevt.state == SDL_PRESSED ? 1 : 2 ; v = alloc_small(1, tag); Field(v, 0) = r; CAMLreturn(v); }
METHODDEF JBLOCKARRAY alloc_small_barray (long blocksperrow, long numrows) /* Allocate a "small" (all-in-memory) 2-D coefficient-block array */ { small_barray_ptr hdr; JBLOCKARRAY result; JBLOCKROW workspace; long rowsperchunk, currow, i; #ifdef MEM_STATS total_num_barray++; cur_num_barray++; if (cur_num_barray > max_num_barray) max_num_barray = cur_num_barray; #endif /* Calculate max # of rows allowed in one allocation chunk */ rowsperchunk = MAX_ALLOC_CHUNK / (blocksperrow * SIZEOF(JBLOCK)); if (rowsperchunk <= 0) ERREXIT(methods, "Image too wide for this implementation"); /* Get space for header and row pointers; this is always "near" on 80x86 */ hdr = (small_barray_ptr) alloc_small((size_t) (numrows * SIZEOF(JBLOCKROW) + SIZEOF(small_barray_hdr))); result = (JBLOCKARRAY) (hdr+1); /* advance past header */ /* Insert into list now so free_all does right thing if I fail */ /* after allocating only some of the rows... */ hdr->next = small_barray_list; hdr->numrows = 0; hdr->rowsperchunk = rowsperchunk; small_barray_list = hdr; /* Get the rows themselves; on 80x86 these are "far" */ currow = 0; while (currow < numrows) { rowsperchunk = MIN(rowsperchunk, numrows - currow); #ifdef MEM_STATS total_bytes_barray += rowsperchunk * blocksperrow * SIZEOF(JBLOCK) + MALLOC_FAR_OVERHEAD; #endif workspace = (JBLOCKROW) jget_large((size_t) (rowsperchunk * blocksperrow * SIZEOF(JBLOCK))); if (workspace == NULL) out_of_memory(4); for (i = rowsperchunk; i > 0; i--) { result[currow++] = workspace; workspace += blocksperrow; } hdr->numrows = currow; } return result; }
value alloc_sockaddr(union sock_addr_union * adr /*in*/, socklen_param_type adr_len, int close_on_error) { value res; switch(adr->s_gen.sa_family) { #ifndef _WIN32 case AF_UNIX: { value n = copy_string(adr->s_unix.sun_path); Begin_root (n); res = alloc_small(1, 0); Field(res,0) = n; End_roots(); break; } #endif case AF_INET: { value a = alloc_inet_addr(&adr->s_inet.sin_addr); Begin_root (a); res = alloc_small(2, 1); Field(res,0) = a; Field(res,1) = Val_int(ntohs(adr->s_inet.sin_port)); End_roots(); break; } #ifdef HAS_IPV6 case AF_INET6: { value a = alloc_inet6_addr(&adr->s_inet6.sin6_addr); Begin_root (a); res = alloc_small(2, 1); Field(res,0) = a; Field(res,1) = Val_int(ntohs(adr->s_inet6.sin6_port)); End_roots(); break; } #endif default: if (close_on_error != -1) close (close_on_error); unix_error(EAFNOSUPPORT, "", Nothing); } return res; }
extern CAMLprim value kc_cursor_open(value caml_db) { CAMLparam1(caml_db); KCDB* db = get_db(caml_db); KCCUR* cur = open_cursor(db); value caml_cursor = alloc_small(1, Abstract_tag); KCCUR_val(caml_cursor) = cur; CAMLreturn(caml_cursor); }
value caml_gr_text_size(value str) { int width; value res; caml_gr_check_open(); if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT); width = XTextWidth(caml_gr_font, String_val(str), string_length(str)); res = alloc_small(2, 0); Field(res, 0) = Val_int(width); Field(res, 1) = Val_int(caml_gr_font->ascent + caml_gr_font->descent); return res; }
static inline value val_of_result_e10(gsl_sf_result_e10 *result) { CAMLparam0(); CAMLlocal3(r, v, e) ; v = copy_double(result->val); e = copy_double(result->err); r = alloc_small(3, 0); Field(r, 0) = v; Field(r, 1) = e; Field(r, 2) = Val_int(result->e10); CAMLreturn(r); }
CAMLprim value ml_gdk_window_get_position (value window) { int x, y; value ret; gdk_window_get_position (GdkWindow_val(window), &x, &y); ret = alloc_small (2,0); Field(ret,0) = Val_int(x); Field(ret,1) = Val_int(y); return ret; }
CAMLprim value ml_gdk_drawable_get_size (value drawable) { int x, y; value ret; gdk_drawable_get_size (GdkDrawable_val(drawable), &x, &y); ret = alloc_small (2,0); Field(ret,0) = Val_int(x); Field(ret,1) = Val_int(y); return ret; }
CAMLprim value ml_gtk_calendar_get_date (value w) { guint year, month, day; value ret; gtk_calendar_get_date (GtkCalendar_val(w), &year, &month, &day); ret = alloc_small (3, 0); Field(ret,0) = Val_int(year); Field(ret,1) = Val_int(month); Field(ret,2) = Val_int(day); return ret; }
CAMLprim value ml_gsl_poly_complex_solve_quadratic(value a, value b, value c) { gsl_complex z0, z1; gsl_poly_complex_solve_quadratic(Double_val(a), Double_val(b), Double_val(c), &z0, &z1); { CAMLparam0(); CAMLlocal3(r,rz0,rz1); rz0 = alloc_small(2 * Double_wosize, Double_array_tag); Store_double_field(rz0, 0, GSL_REAL(z0)); Store_double_field(rz0, 1, GSL_IMAG(z0)); rz1 = alloc_small(2 * Double_wosize, Double_array_tag); Store_double_field(rz1, 0, GSL_REAL(z1)); Store_double_field(rz1, 1, GSL_IMAG(z1)); r = alloc_small(2, 0); Field(r,0) = rz0 ; Field(r,1) = rz1 ; CAMLreturn(r); } }
CAMLprim value sdl_version (value unit) { const SDL_version *v; value r; v = SDL_Linked_Version(); r = alloc_small(3, 0); Field(r, 0) = Val_int(v->major); Field(r, 1) = Val_int(v->minor); Field(r, 2) = Val_int(v->patch); return r; }
CAMLprim value ml_gsl_sum_levin_utrunc_getinfo(value ws) { gsl_sum_levin_utrunc_workspace *W=WStrunc_val(ws); CAMLparam0(); CAMLlocal2(v, s); s=copy_double(W->sum_plain); v=alloc_small(3, 0); Field(v, 0)=Val_int(W->size); Field(v, 1)=Val_int(W->terms_used); Field(v, 2)=s; CAMLreturn(v); }
alloc_sarray (j_common_ptr cinfo, int pool_id, JDIMENSION samplesperrow, JDIMENSION numrows) /* Allocate a 2-D sample array */ { my_mem_ptr mem = (my_mem_ptr) cinfo->mem; JSAMPARRAY result; JSAMPROW workspace; JDIMENSION rowsperchunk, currow, i; long ltemp; /* Make sure each row is properly aligned */ if ((ALIGN_SIZE % sizeof(JSAMPLE)) != 0) out_of_memory(cinfo, 5); /* safety check */ if (samplesperrow > MAX_ALLOC_CHUNK) { /* This prevents overflow/wrap-around in round_up_pow2() if sizeofobject is close to SIZE_MAX. */ out_of_memory(cinfo, 9); } samplesperrow = (JDIMENSION)round_up_pow2(samplesperrow, (2 * ALIGN_SIZE) / sizeof(JSAMPLE)); /* Calculate max # of rows allowed in one allocation chunk */ ltemp = (MAX_ALLOC_CHUNK-sizeof(large_pool_hdr)) / ((long) samplesperrow * sizeof(JSAMPLE)); if (ltemp <= 0) ERREXIT(cinfo, JERR_WIDTH_OVERFLOW); if (ltemp < (long) numrows) rowsperchunk = (JDIMENSION) ltemp; else rowsperchunk = numrows; mem->last_rowsperchunk = rowsperchunk; /* Get space for row pointers (small object) */ result = (JSAMPARRAY) alloc_small(cinfo, pool_id, (size_t) (numrows * sizeof(JSAMPROW))); /* Get the rows themselves (large objects) */ currow = 0; while (currow < numrows) { rowsperchunk = MIN(rowsperchunk, numrows - currow); workspace = (JSAMPROW) alloc_large(cinfo, pool_id, (size_t) ((size_t) rowsperchunk * (size_t) samplesperrow * sizeof(JSAMPLE))); for (i = rowsperchunk; i > 0; i--) { result[currow++] = workspace; workspace += samplesperrow; } } return result; }
CAMLprim value ml_gtk_accelerator_parse(value acc) { CAMLparam0(); CAMLlocal2(vmods, tup); guint key; GdkModifierType mods; gtk_accelerator_parse(String_val(acc), &key, &mods); vmods = mods ? Val_GdkModifier_flags(mods) : Val_emptylist; tup = alloc_small(2, 0); Field(tup, 0) = Val_int(key); Field(tup, 1) = vmods; CAMLreturn(tup); }
static value alloc_process_status(HANDLE pid, int status) { value res, st; st = alloc(1, 0); Field(st, 0) = Val_int(status); Begin_root (st); res = alloc_small(2, 0); Field(res, 0) = Val_long((intnat) pid); Field(res, 1) = st; End_roots(); return res; }
static void caml_zlib_not_supported(void) { value bucket; if (caml_zlib_error_exn == NULL) { caml_zlib_error_exn = caml_named_value("Cryptokit.Error"); if (caml_zlib_error_exn == NULL) invalid_argument("Exception Cryptokit.Error not initialized"); } bucket = alloc_small(2, 0); Field(bucket, 0) = *caml_zlib_error_exn; Field(bucket, 1) = Val_int(12); /* Compression_not_supported */ mlraise(bucket); }
CAMLprim value unix_socketpair(value domain, value type, value proto) { int sv[2]; value res; if (socketpair(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(proto), sv) == -1) uerror("socketpair", Nothing); res = alloc_small(2, 0); Field(res,0) = Val_int(sv[0]); Field(res,1) = Val_int(sv[1]); return res; }
static void store_in_job(value job_v) { value adr = Val_unit; value addr_list = Val_unit; int i; /* printf("store_in_job %d\n", job_naddresses); */ Begin_roots3 (job_v, addr_list, adr); #ifdef h_addr addr_list = alloc_small(job_naddresses, 0); for(i=0; i<job_naddresses; i++){ adr = alloc_one_addr(ip_job_result + i * entry_h_length); modify(&Field(addr_list,i), adr); } #else adr = alloc_one_addr(ip_job_result); addr_list = alloc_small(1, 0); Field(addr_list, 0) = adr; #endif /* h_addr */ modify(&Field(job_v,1), addr_list); End_roots(); }
static value alloc_process_status(int pid, int status, value ru) { CAMLparam1(ru); CAMLlocal2(st,res); if (WIFEXITED(status)) { st = alloc_small(1, TAG_WEXITED); Field(st, 0) = Val_int(WEXITSTATUS(status)); } else if (WIFSTOPPED(status)) { st = alloc_small(1, TAG_WSTOPPED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))); } else { st = alloc_small(1, TAG_WSIGNALED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status))); } res = alloc_small(3, 0); Field(res, 0) = Val_int(pid); Field(res, 1) = st; Field(res, 2) = ru; CAMLreturn(res); }
static value alloc_process_status(int pid, int status) { value st, res; if (WIFEXITED(status)) { st = alloc_small(1, TAG_WEXITED); Field(st, 0) = Val_int(WEXITSTATUS(status)); } else if (WIFSTOPPED(status)) { st = alloc_small(1, TAG_WSTOPPED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))); } else { st = alloc_small(1, TAG_WSIGNALED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status))); } Begin_root (st); res = alloc_small(2, 0); Field(res, 0) = Val_int(pid); Field(res, 1) = st; End_roots(); return res; }
CAMLprim value ml_gtk_label_get_selection_bounds (value label) { gint s, e; value r; if (gtk_label_get_selection_bounds (GtkLabel_val(label), &s, &e)) { r = alloc_small(2, 0); Field(r, 0) = Val_int(s); Field(r, 1) = Val_int(e); r = ml_some(r); } else r = Val_unit; return r; }
CAMLprim value netsys_fdopendir(value fd) { #ifdef HAVE_FDOPENDIR DIR * d; value res; d = fdopendir(Int_val(fd)); if (d == (DIR *) NULL) uerror("fdopendir", Nothing); res = alloc_small(1, Abstract_tag); DIR_Val(res) = d; return res; #else invalid_argument("Netsys_posix.fdopendir not available"); #endif }
value mlptrace_peekregisters (value pid_v) { pid_t pid; struct user usreg; long l = 0; int savederrno = errno; CAMLparam1 (pid_v); CAMLlocal5 (res_v, eip_v, eax_v, ebx_v, ecx_v); CAMLlocal5 (edx_v, esi_v, edi_v, ebp_v, esp_v); CAMLlocal2 (eflags_v, origeax_v); pid = Long_val (pid_v); memset (&usreg, 0, sizeof (usreg)); #ifndef NO_BLOCKING_SECTION caml_enter_blocking_section (); #endif l = ptrace (PTRACE_GETREGS, pid, (void *) 0, &usreg); #ifndef NO_BLOCKING_SECTION caml_leave_blocking_section (); #endif if (l == -1 && errno) uerror ("Ptrace.peekregisters", Nothing); if (savederrno) errno = savederrno; eip_v = caml_copy_nativeint (usreg.regs.eip); eax_v = caml_copy_nativeint (usreg.regs.eax); ebx_v = caml_copy_nativeint (usreg.regs.ebx); ecx_v = caml_copy_nativeint (usreg.regs.ecx); edx_v = caml_copy_nativeint (usreg.regs.edx); esi_v = caml_copy_nativeint (usreg.regs.esi); edi_v = caml_copy_nativeint (usreg.regs.edi); ebp_v = caml_copy_nativeint (usreg.regs.ebp); esp_v = caml_copy_nativeint (usreg.regs.esp); eflags_v = caml_copy_nativeint (usreg.regs.eflags); origeax_v = caml_copy_nativeint (usreg.regs.orig_eax); res_v = alloc_small (0, 11); Field (res_v, 0) = eip_v; Field (res_v, 1) = eax_v; Field (res_v, 2) = ebx_v; Field (res_v, 3) = ecx_v; Field (res_v, 4) = edx_v; Field (res_v, 5) = esi_v; Field (res_v, 6) = edi_v; Field (res_v, 7) = ebp_v; Field (res_v, 8) = esp_v; Field (res_v, 9) = eflags_v; Field (res_v, 10) = origeax_v; CAMLreturn (res_v); }
static value alloc_proto_entry(struct protoent *entry) { value res; value name = Val_unit, aliases = Val_unit; Begin_roots2 (name, aliases); name = copy_string(entry->p_name); aliases = copy_string_array((const char**)entry->p_aliases); res = alloc_small(3, 0); Init_field(res, 0, name); Init_field(res, 1, aliases); Init_field(res, 2, Val_int(entry->p_proto)); End_roots(); return res; }
static value alloc_tm(struct tm *tm) { value res; res = alloc_small(9, 0); Field(res,0) = Val_int(tm->tm_sec); Field(res,1) = Val_int(tm->tm_min); Field(res,2) = Val_int(tm->tm_hour); Field(res,3) = Val_int(tm->tm_mday); Field(res,4) = Val_int(tm->tm_mon); Field(res,5) = Val_int(tm->tm_year); Field(res,6) = Val_int(tm->tm_wday); Field(res,7) = Val_int(tm->tm_yday); Field(res,8) = tm->tm_isdst ? Val_true : Val_false; return res; }