Exemple #1
0
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;
}
Exemple #2
0
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;
}
Exemple #3
0
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);
}
Exemple #4
0
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;
}
Exemple #5
0
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;
}
Exemple #6
0
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);
}
Exemple #10
0
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;
}
Exemple #11
0
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);
}
Exemple #12
0
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;
}
Exemple #13
0
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;
}
Exemple #14
0
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;
}
Exemple #15
0
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);
    }
}
Exemple #16
0
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;
}
Exemple #17
0
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);
}
Exemple #18
0
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;
}
Exemple #19
0
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);
}
Exemple #20
0
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;
}
Exemple #21
0
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);
}
Exemple #22
0
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;
}
Exemple #23
0
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();
}
Exemple #24
0
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);
}
Exemple #25
0
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;
}
Exemple #26
0
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;
}
Exemple #27
0
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
}
Exemple #28
0
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);
}
Exemple #29
0
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;
}
Exemple #30
0
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;
}