コード例 #1
0
PREFIX value ml_elm_fileselector_selected_set(value v_obj, value v_path)
{
        return Val_Eina_Bool(elm_fileselector_selected_set((Evas_Object*) v_obj,
                String_val(v_path)));
}
コード例 #2
0
static DWORD WINAPI gr_open_graph_internal(value arg)
{
  RECT rc;
  int ret;
  int event;
  int x, y, w, h;
  int screenx,screeny;
  int attributes;
  static int registered;
  MSG msg;

  gr_initialized = TRUE;
  hInst = GetModuleHandle(NULL);
  x = y = w = h = CW_USEDEFAULT;
  sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y);

  /* Open the display */
  if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) {
    if (!registered) {
      registered = DoRegisterClass();
      if (!registered) {
        open_graph_errmsg = "Cannot register the window class";
        SetEvent(open_graph_event);
        return 1;
      }
    }
    grwindow.hwnd = CreateWindow(szOcamlWindowClass,
                                 WINDOW_NAME,
                                 WS_OVERLAPPEDWINDOW,
                                 x,y,
                                 w,h,
                                 NULL,0,hInst,NULL);
    if (grwindow.hwnd == NULL) {
      open_graph_errmsg = "Cannot create window";
      SetEvent(open_graph_event);
      return 1;
    }
#if 0
    if (x != CW_USEDEFAULT) {
      rc.left = 0;
      rc.top = 0;
      rc.right = w;
      rc.bottom = h;
      AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0);
      MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1);
    }
#endif
  }
  gr_reset();
  ShowWindow(grwindow.hwnd,SW_SHOWNORMAL);
  
  /* Position the current point at origin */
  grwindow.grx = 0;
  grwindow.gry = 0;
  
  caml_gr_init_event_queue();

  /* The global data structures are now correctly initialized.
     Restart the Caml main thread. */
  open_graph_errmsg = NULL;
  SetEvent(open_graph_event);

  /* Enter the message handling loop */
  while (GetMessage(&msg,NULL,0,0)) {
    TranslateMessage(&msg);  // Translates virtual key codes
    DispatchMessage(&msg);   // Dispatches message to window
    if (!IsWindow(grwindow.hwnd))
      break;
  }
  return 0;
}
コード例 #3
0
ファイル: sendmsg.c プロジェクト: haesbaert/extunix
CAMLprim value caml_extunix_recvmsg2(value vfd, value vbuf, value ofs, value vlen,
  value vflags)
{
  CAMLparam4(vfd, vbuf, ofs, vlen);
  CAMLlocal5(vres, vlist, v, vx, vsaddr);
  union {
    struct cmsghdr hdr;
    char buf[CMSG_SPACE(sizeof(int)) /* File descriptor passing */
#ifdef EXTUNIX_HAVE_IP_RECVIF
        + CMSG_SPACE(sizeof(struct sockaddr_dl)) /* IP_RECVIF */
#endif
#ifdef EXTUNIX_HAVE_IP_RECVDSTADDR
        + CMSG_SPACE(sizeof(struct in_addr))     /* IP_RECVDSTADDR */
#endif
    ];
  } cmsgbuf;
  struct iovec             iov;
  struct msghdr            msg;
  struct cmsghdr          *cmsg;
  ssize_t                  n;
  size_t                   len;
  char                     iobuf[UNIX_BUFFER_SIZE];
  struct sockaddr_storage  ss;
  int                      sendflags;
#ifdef EXTUNIX_HAVE_IP_RECVIF
  struct sockaddr_dl      *dst = NULL;
#endif

  len = Long_val(vlen);

  memset(&iov, 0, sizeof(iov));
  memset(&msg, 0, sizeof(msg));

  if (len > UNIX_BUFFER_SIZE)
    len = UNIX_BUFFER_SIZE;

  iov.iov_base = iobuf;
  iov.iov_len = len;
  msg.msg_name = &ss;
  msg.msg_namelen = sizeof(ss);
  msg.msg_iov = &iov;
  msg.msg_iovlen = 1;
  msg.msg_control = &cmsgbuf.buf;
  msg.msg_controllen = sizeof(cmsgbuf.buf);
  sendflags = caml_convert_flag_list(vflags, msg_flag_table);

  caml_enter_blocking_section();
  n = recvmsg(Int_val(vfd), &msg, sendflags);
  caml_leave_blocking_section();

  vres = caml_alloc_small(4, 0);

  if (n == -1) {
    uerror("recvmsg", Nothing);
    CAMLreturn (vres);
  }

  vsaddr = my_alloc_sockaddr(&ss);

  memmove(&Byte(vbuf, Long_val(ofs)), iobuf, n);

  vlist = Val_int(0);

  /* Build the variant list vlist */
  for (cmsg = CMSG_FIRSTHDR(&msg); cmsg != NULL;
       cmsg = CMSG_NXTHDR(&msg, cmsg)) {
    if (cmsg->cmsg_level == SOL_SOCKET &&
        cmsg->cmsg_type == SCM_RIGHTS) {
      /* CMSG_DATA is aligned, so the following is cool */
      v = caml_alloc_small(2, TAG_FILEDESCRIPTOR);
      Field(v, 0) = Val_int(*(int *)CMSG_DATA(cmsg));
      Field(v, 1) = vlist;
      vlist = v;
      continue;
    }

#ifdef EXTUNIX_HAVE_IP_RECVIF
    if (cmsg->cmsg_level == IPPROTO_IP &&
        cmsg->cmsg_type == IP_RECVIF) {
      dst = (struct sockaddr_dl *)CMSG_DATA(cmsg);
      v = caml_alloc_small(2, 0);
      vx = caml_alloc_small(1, TAG_IP_RECVIF);
      Field(vx, 0) = Val_int(dst->sdl_index);
      Field(v, 0) = vx;
      Field(v, 1) = vlist;
      vlist = v;
      continue;
    }
#endif
#ifdef EXTUNIX_HAVE_IP_RECVDSTADDR
    if (cmsg->cmsg_level == IPPROTO_IP &&
        cmsg->cmsg_type == IP_RECVDSTADDR) {
      struct in_addr ipdst;
      ipdst = *(struct in_addr *)CMSG_DATA(cmsg);
      v = caml_alloc_small(2, 0);
      vx = caml_alloc_small(1, TAG_IP_RECVDSTADDR);
      Field(vx, 0) = caml_alloc_string(4);
      memcpy(String_val(Field(vx, 0)), &ipdst, 4);
      Field(v, 0) = vx;
      Field(v, 1) = vlist;
      vlist = v;
      continue;
    }
#endif
  }

  /* Now build the result */
  Field(vres, 0) = Val_long(n);
  Field(vres, 1) = vsaddr;
  Field(vres, 2) = vlist;
  Field(vres, 3) = int_to_recvflags(msg.msg_flags);

  CAMLreturn(vres);
}
コード例 #4
0
ファイル: hh_shared.c プロジェクト: 5heri/hhvm
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 = 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;
}
コード例 #5
0
ファイル: hh_shared.c プロジェクト: 5heri/hhvm
static unsigned long get_hash(value key) {
  return *((unsigned long*)String_val(key));
}
コード例 #6
0
ファイル: SFHttp_stub.cpp プロジェクト: LorantK/PC2R
CAMLextern_C value
caml_sfHttpRequest_setUri(value httpRequest, value uri)
{
    SfHttpRequest_val(httpRequest)->setUri(String_val(uri));
    return Val_unit;
}
コード例 #7
0
ファイル: led_hw.c プロジェクト: davidmobach/paparazzi
value register_leds_cb(value cb_name) {
    leds_closure = caml_named_value(String_val(cb_name));
    return Val_unit;
}
コード例 #8
0
ファイル: target_ocaml.c プロジェクト: 1995hnagamin/llvm
/* string -> Target.t option */
CAMLprim value llvm_target_by_name(value Name) {
  return llvm_target_option(LLVMGetTargetFromName(String_val(Name)));
}
コード例 #9
0
ファイル: target_ocaml.c プロジェクト: 1995hnagamin/llvm
/* string -> DataLayout.t */
CAMLprim value llvm_datalayout_of_string(value StringRep) {
  return llvm_alloc_data_layout(LLVMCreateTargetData(String_val(StringRep)));
}
コード例 #10
0
ファイル: fightInterface.c プロジェクト: hassenc/Game
value setLeftCreatureName(str)
{
	fi.leftName = (char*)(String_val(str));
	return Val_unit;
}
コード例 #11
0
ファイル: fightInterface.c プロジェクト: hassenc/Game
value setRightCreatureName(str)
{
	fi.rightName = (char*)(String_val(str));
	return Val_unit;
}
コード例 #12
0
ファイル: fightInterface.c プロジェクト: hassenc/Game
value setRightCreatureTexture(str)
{
	char* texture = (char*)(String_val(str));
	sfSprite_SetImage(fi.rightCreature, TexturesManager_getTexture(game.texturesManager, texture));
	return Val_unit;
}
コード例 #13
0
ファイル: pcre_stubs.c プロジェクト: DMClambo/pfff
/* Executes a pattern match with runtime options, a regular expression, a
   string offset, a string length, a subject string, a number of subgroup
   offsets, an offset vector and an optional callout function */
CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_ofs,
                              value v_subj, value v_subgroups2, value v_ovec,
                              value v_maybe_cof)
{
  const int ofs = Int_val(v_ofs), len = caml_string_length(v_subj);

  if (ofs > len || ofs < 0)
    caml_invalid_argument("Pcre.pcre_exec_stub: illegal offset");

  {
    const pcre *code = (pcre *) Field(v_rex, 1);  /* Compiled pattern */
    const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);  /* Extra info */
    const char *ocaml_subj = String_val(v_subj);  /* Subject string */
    const int opt = Int_val(v_opt);  /* Runtime options */
    int subgroups2 = Int_val(v_subgroups2);
    const int subgroups2_1 = subgroups2 - 1;
    const int subgroups3 = (subgroups2 >> 1) + subgroups2;

    /* Special case when no callout functions specified */
    if (v_maybe_cof == None) {
      int *ovec = (int *) &Field(v_ovec, 0);

      /* Performs the match */
      const int ret =
        pcre_exec(code, extra, ocaml_subj, len, ofs, opt, ovec, subgroups3);

      if (ret < 0) {
        switch(ret) {
          case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
          case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
          case PCRE_ERROR_MATCHLIMIT :
            caml_raise_constant(*pcre_exc_MatchLimit);
          case PCRE_ERROR_BADPARTIAL :
            caml_raise_constant(*pcre_exc_BadPartial);
          case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
          case PCRE_ERROR_BADUTF8_OFFSET :
            caml_raise_constant(*pcre_exc_BadUTF8Offset);
          default :
            caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
        }
      }

      else {
        const int *ovec_src = ovec + subgroups2_1;
        long int *ovec_dst = (long int *) ovec + subgroups2_1;

        /* Converts offsets from C-integers to OCaml-Integers
           This is a bit tricky, because there are 32- and 64-bit platforms
           around and OCaml chooses the larger possibility for representing
           integers when available (also in arrays) - not so the PCRE */
        while (subgroups2--) {
          *ovec_dst = Val_int(*ovec_src);
          --ovec_src; --ovec_dst;
        }
      }
    }

    /* There are callout functions */
    else {
      value v_cof = Field(v_maybe_cof, 0);
      value v_substrings;
      char *subj = caml_stat_alloc(sizeof(char) * len);
      int *ovec = caml_stat_alloc(sizeof(int) * subgroups3);
      int ret;
      struct cod cod = { (value *) NULL, (value *) NULL, (value) NULL };
      struct pcre_extra new_extra =
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
#else
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif

      memcpy(subj, ocaml_subj, len);

      Begin_roots3(v_rex, v_cof, v_substrings);
        Begin_roots2(v_subj, v_ovec);
          v_substrings = caml_alloc_small(2, 0);
        End_roots();

        Field(v_substrings, 0) = v_subj;
        Field(v_substrings, 1) = v_ovec;

        cod.v_substrings_p = &v_substrings;
        cod.v_cof_p = &v_cof;
        new_extra.callout_data = &cod;

        if (extra == NULL) {
          ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
                          subgroups3);
        }
        else {
          new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
          new_extra.study_data = extra->study_data;
          new_extra.match_limit = extra->match_limit;
          new_extra.tables = extra->tables;
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
          new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif

          ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
                          subgroups3);
        }

        free(subj);
      End_roots();

      if (ret < 0) {
        free(ovec);
        switch(ret) {
          case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
          case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
          case PCRE_ERROR_MATCHLIMIT :
            caml_raise_constant(*pcre_exc_MatchLimit);
          case PCRE_ERROR_BADPARTIAL :
            caml_raise_constant(*pcre_exc_BadPartial);
          case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
          case PCRE_ERROR_BADUTF8_OFFSET :
            caml_raise_constant(*pcre_exc_BadUTF8Offset);
          case PCRE_ERROR_CALLOUT : caml_raise(cod.v_exn);
          default :
            caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
        }
      }

      else {
        int *ovec_src = ovec + subgroups2_1;
        long int *ovec_dst = &Field(v_ovec, 0) + subgroups2_1;

        while (subgroups2--) {
          *ovec_dst = Val_int(*ovec_src);
          --ovec_src; --ovec_dst;
        }

        free(ovec);
      }
    }
  }

  return Val_unit;
}

/* Byte-code hook for pcre_exec_stub
   Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
  return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3],
                        argv[4], argv[5], argv[6]);
}

/* Generates a new set of chartables for the current locale (see man
   page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
  /* GC will do a full cycle every 100 table set allocations
     (one table set consumes 864 bytes -> maximum of 86400 bytes
     unreclaimed table sets) */
  const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 864, 86400);
  Field(v_res, 1) = (value) pcre_maketables();
  return v_res;
}

/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
  return Val_bool(isspace(Int_val(v_c)));
}

/* Returns number of substring associated with a name */
CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name)
{
  const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1),
                                        String_val(v_name));
  if (ret == PCRE_ERROR_NOSUBSTRING)
    caml_invalid_argument("Named string not found");

  return Val_int(ret);
}

/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
  CAMLparam0();
  CAMLlocal1(v_res);
  int name_count;
  int entry_size;
  const char *tbl_ptr;
  int i;

  int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  v_res = caml_alloc(name_count, 0);

  for (i = 0; i < name_count; ++i) {
    value v_name = caml_copy_string(tbl_ptr + 2);
    Store_field(v_res, i, v_name);
    tbl_ptr += entry_size;
  }

  CAMLreturn(v_res);
}
コード例 #14
0
static void extern_rec(value v)
{
  struct code_fragment * cf;
  struct extern_item * sp;
  sp = extern_stack;

  while(1) {
  if (Is_long(v)) {
    intnat n = Long_val(v);
    if (n >= 0 && n < 0x40) {
      Write(PREFIX_SMALL_INT + n);
    } else if (n >= -(1 << 7) && n < (1 << 7)) {
      writecode8(CODE_INT8, n);
    } else if (n >= -(1 << 15) && n < (1 << 15)) {
      writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
    } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
      writecode64(CODE_INT64, n);
#endif
    } else
      writecode32(CODE_INT32, n);
    goto next_item;
  }
  if (Is_in_value_area(v)) {
    header_t hd = Hd_val(v);
    tag_t tag = Tag_hd(hd);
    mlsize_t sz = Wosize_hd(hd);

    if (tag == Forward_tag) {
      value f = Forward_val (v);
      if (Is_block (f)
          && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
              || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
        /* Do not short-circuit the pointer. */
      }else{
        v = f;
        continue;
      }
    }
    /* Atoms are treated specially for two reasons: they are not allocated
       in the externed block, and they are automatically shared. */
    if (sz == 0) {
      if (tag < 16) {
        Write(PREFIX_SMALL_BLOCK + tag);
      } else {
        writecode32(CODE_BLOCK32, hd);
      }
      goto next_item;
    }
    /* Check if already seen */
    if (Color_hd(hd) == Caml_blue) {
      uintnat d = obj_counter - (uintnat) Field(v, 0);
      if (d < 0x100) {
        writecode8(CODE_SHARED8, d);
      } else if (d < 0x10000) {
        writecode16(CODE_SHARED16, d);
      } else {
        writecode32(CODE_SHARED32, d);
      }
      goto next_item;
    }

    /* Output the contents of the object */
    switch(tag) {
    case String_tag: {
      mlsize_t len = caml_string_length(v);
      if (len < 0x20) {
        Write(PREFIX_SMALL_STRING + len);
      } else if (len < 0x100) {
        writecode8(CODE_STRING8, len);
      } else {
        writecode32(CODE_STRING32, len);
      }
      writeblock(String_val(v), len);
      size_32 += 1 + (len + 4) / 4;
      size_64 += 1 + (len + 8) / 8;
      extern_record_location(v);
      break;
    }
    case Double_tag: {
      if (sizeof(double) != 8)
        extern_invalid_argument("output_value: non-standard floats");
      Write(CODE_DOUBLE_NATIVE);
      writeblock_float8((double *) v, 1);
      size_32 += 1 + 2;
      size_64 += 1 + 1;
      extern_record_location(v);
      break;
    }
    case Double_array_tag: {
      mlsize_t nfloats;
      if (sizeof(double) != 8)
        extern_invalid_argument("output_value: non-standard floats");
      nfloats = Wosize_val(v) / Double_wosize;
      if (nfloats < 0x100) {
        writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
      } else {
        writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
      }
      writeblock_float8((double *) v, nfloats);
      size_32 += 1 + nfloats * 2;
      size_64 += 1 + nfloats;
      extern_record_location(v);
      break;
    }
    case Abstract_tag:
      extern_invalid_argument("output_value: abstract value (Abstract)");
      break;
    case Infix_tag:
      writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
      extern_rec(v - Infix_offset_hd(hd));
      break;
    case Custom_tag: {
      uintnat sz_32, sz_64;
      char * ident = Custom_ops_val(v)->identifier;
      void (*serialize)(value v, uintnat * wsize_32,
                        uintnat * wsize_64)
        = Custom_ops_val(v)->serialize;
      if (serialize == NULL)
        extern_invalid_argument("output_value: abstract value (Custom)");
      Write(CODE_CUSTOM);
      writeblock(ident, strlen(ident) + 1);
      Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
      size_32 += 2 + ((sz_32 + 3) >> 2);  /* header + ops + data */
      size_64 += 2 + ((sz_64 + 7) >> 3);
      extern_record_location(v);
      break;
    }
    default: {
      value field0;
      if (tag < 16 && sz < 8) {
        Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
      } else if (hd >= ((uintnat)1 << 32)) {
        writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
      } else {
        writecode32(CODE_BLOCK32, Whitehd_hd (hd));
      }
      size_32 += 1 + sz;
      size_64 += 1 + sz;
      field0 = Field(v, 0);
      extern_record_location(v);
      /* Remember that we still have to serialize fields 1 ... sz - 1 */
      if (sz > 1) {
        sp++;
        if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
        sp->v = &Field(v,1);
        sp->count = sz-1;
      }
      /* Continue serialization with the first field */
      v = field0;
      continue;
    }
    }
  }
  else if ((cf = extern_find_code((char *) v)) != NULL) {
    if (!extern_closures)
      extern_invalid_argument("output_value: functional value");
    writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
    writeblock((char *) cf->digest, 16);
  } else {
    extern_invalid_argument("output_value: abstract value (outside heap)");
  }
  next_item:
    /* Pop one more item to marshal, if any */
    if (sp == extern_stack) {
        /* We are done.   Cleanup the stack and leave the function */
        extern_free_stack();
        return;
    }
    v = *((sp->v)++);
    if (--(sp->count) == 0) sp--;
  }
コード例 #15
0
ファイル: sys.c プロジェクト: jessicah/snowflake-jocaml
CAMLprim value caml_sys_rename(value oldname, value newname)
{
  if (rename(String_val(oldname), String_val(newname)) != 0)
    caml_sys_error(NO_ARG);
  return Val_unit;
}
コード例 #16
0
CAMLprim value mmdb_ml_lookup_path(value ip, value query_list, value mmdb)
{
  CAMLparam3(ip, query_list, mmdb);
  CAMLlocal3(iter_count, caml_clean_result, query_r);

  int total_len = 0, copy_count = 0, gai_error = 0, mmdb_error = 0;
  char *clean_result;
  long int int_result;

  iter_count = query_list;

  unsigned int len = caml_string_length(ip);
  char *as_string = caml_strdup(String_val(ip));
  if (strlen(as_string) != (size_t)len) {
    caml_failwith("Could not copy IP address properly");
  }

  MMDB_s *as_mmdb = (MMDB_s*)Data_custom_val(mmdb);
  MMDB_lookup_result_s *result = caml_stat_alloc(sizeof(*result));
  *result = MMDB_lookup_string(as_mmdb, as_string, &gai_error, &mmdb_error);
  check_error(gai_error, mmdb_error);
  caml_stat_free(as_string);

  while (iter_count != Val_emptylist) {
    total_len++;
    iter_count = Field(iter_count, 1);
  }

  char **query = caml_stat_alloc(sizeof(char *) * (total_len + 1));

  while (query_list != Val_emptylist) {
    query[copy_count] = caml_strdup(String_val(Field(query_list, 0)));
    copy_count++;
    query_list = Field(query_list, 1);
  }
  query[total_len] = NULL;
  MMDB_entry_data_s entry_data;

  int status = MMDB_aget_value(&result->entry,
			       &entry_data,
			       (const char *const *const)query);
  check_status(status);
  check_data(entry_data);
  caml_stat_free(result);
  for (int i = 0; i < copy_count; caml_stat_free(query[i]), i++);
  caml_stat_free(query);
  query_r = caml_alloc(2, 0);
  as_mmdb = NULL;
  switch (entry_data.type) {
  case MMDB_DATA_TYPE_BYTES:
    clean_result = caml_stat_alloc(entry_data.data_size + 1);
    memcpy(clean_result, entry_data.bytes, entry_data.data_size);
    caml_clean_result = caml_copy_string(clean_result);
    caml_stat_free(clean_result);
    goto string_finish;

  case MMDB_DATA_TYPE_UTF8_STRING:
    clean_result = strndup(entry_data.utf8_string, entry_data.data_size);
    caml_clean_result = caml_copy_string(clean_result);
    free(clean_result);
    goto string_finish;

  case MMDB_DATA_TYPE_FLOAT:
    Store_field(query_r, 0, polymorphic_variants.poly_float);
    Store_field(query_r, 1, caml_copy_double(entry_data.float_value));
    goto finish;

  case MMDB_DATA_TYPE_BOOLEAN:
    Store_field(query_r, 0, polymorphic_variants.poly_bool);
    Store_field(query_r, 1, Val_true ? entry_data.boolean : Val_false);
    goto finish;

  case MMDB_DATA_TYPE_DOUBLE:
    Store_field(query_r, 0, polymorphic_variants.poly_float);
    Store_field(query_r, 1, caml_copy_double(entry_data.double_value));
    goto finish;

  case MMDB_DATA_TYPE_UINT16:
    Store_field(query_r, 0, polymorphic_variants.poly_int);
    int_result = Val_long(entry_data.uint16);
    goto int_finish;

  case MMDB_DATA_TYPE_UINT32:
    Store_field(query_r, 0, polymorphic_variants.poly_int);
    int_result = Val_long(entry_data.uint32);
    goto int_finish;

  case MMDB_DATA_TYPE_UINT64:
    Store_field(query_r, 0, polymorphic_variants.poly_int);
    int_result = Val_long(entry_data.uint32);
    goto int_finish;

    // look at /usr/bin/sed -n 1380,1430p src/maxminddb.c
  case MMDB_DATA_TYPE_ARRAY:
  case MMDB_DATA_TYPE_MAP:
    caml_failwith("Can't return a Map or Array yet");
  }

 string_finish:
  Store_field(query_r, 0, polymorphic_variants.poly_string);
  Store_field(query_r, 1, caml_clean_result);
  CAMLreturn(query_r);

 int_finish:
  Store_field(query_r, 1, int_result);
  CAMLreturn(query_r);

 finish:
  CAMLreturn(query_r);
}
コード例 #17
0
ファイル: sys.c プロジェクト: jessicah/snowflake-jocaml
CAMLprim value caml_sys_chdir(value dirname)
{
  if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname);
  return Val_unit;
}
コード例 #18
0
ファイル: link.c プロジェクト: MassD/ocaml
CAMLprim value unix_link_r(CAML_R, value path1, value path2)
{
  if (link(String_val(path1), String_val(path2)) == -1) uerror_r(ctx,"link", path2);
  return Val_unit;
}
コード例 #19
0
ファイル: SFHttp_stub.cpp プロジェクト: LorantK/PC2R
CAMLextern_C value
caml_sfHttpRequest_setBody(value httpRequest, value body)
{
    SfHttpRequest_val(httpRequest)->setBody(String_val(body));
    return Val_unit;
}
コード例 #20
0
ファイル: netdevice_stub.c プロジェクト: jkilburg/ocaml-lldp
    char *ifname = String_val(caml_ifname);				\
    struct ifreq ifr;							\
    									\
    memset(&ifr, 0, sizeof(struct ifreq));				\
    copyifname(ifr.ifr_name, ifname);					\
    SETTER;								\
    FI(socket, REQUEST, &ifr);						\
    RESULT(Val_unit, 0);						\
  }

SET_FIELD(SIOCSIFFLAGS, siocsifflags_c, ifr.ifr_flags = Int_val(caml_val))
SET_FIELD(SIOCSIFPFLAGS, siocsifpflags_c, ifr.ifr_flags = Int_val(caml_val))
SET_FIELD(SIOCSIFMTU, siocsifmtu_c, ifr.ifr_mtu = Int_val(caml_val))
SET_FIELD(SIOCSIFTXQLEN, siocsiftxqlen_c, ifr.ifr_qlen = Int_val(caml_val))

SET_FIELD(SIOCSIFNAME, siocsifname_c, copyifname(ifr.ifr_newname, String_val(caml_val)))

static void
set_hwaddr(struct sockaddr *sa, value hwaddr)
{
  /* quick and dirty checks */
  if (caml_string_length(hwaddr) != ETHERNET_MAC_LEN) caml_failwith("Expected 6 byte ethernet MAC");
  memcpy(sa->sa_data, String_val(hwaddr), ETHERNET_MAC_LEN);
  return;
}

SET_FIELD(SIOCSIFHWADDR, siocsifhwaddr_c, set_hwaddr(&ifr.ifr_hwaddr, caml_val))

static void
set_ipaddr(struct sockaddr *sa, value ipaddr)
{
コード例 #21
0
ファイル: extern.c プロジェクト: avsm/ocaml-community
static void extern_rec(value v)
{
 tailcall:
  if (Is_long(v)) {
    intnat n = Long_val(v);
    if (n >= 0 && n < 0x40) {
      Write(PREFIX_SMALL_INT + n);
    } else if (n >= -(1 << 7) && n < (1 << 7)) {
      writecode8(CODE_INT8, n);
    } else if (n >= -(1 << 15) && n < (1 << 15)) {
      writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
    } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
      writecode64(CODE_INT64, n);
#endif
    } else
      writecode32(CODE_INT32, n);
    return;
  }
  if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) {
    header_t hd = Hd_val(v);
    tag_t tag = Tag_hd(hd);
    mlsize_t sz = Wosize_hd(hd);

    if (tag == Forward_tag) {
      value f = Forward_val (v);
      if (Is_block (f) && (Is_young (f) || Is_in_heap (f))
          && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag
              || Tag_val (f) == Double_tag)){
        /* Do not short-circuit the pointer. */
      }else{
        v = f;
        goto tailcall;
      }
    }
    /* Atoms are treated specially for two reasons: they are not allocated
       in the externed block, and they are automatically shared. */
    if (sz == 0) {
      if (tag < 16) {
        Write(PREFIX_SMALL_BLOCK + tag);
      } else {
        writecode32(CODE_BLOCK32, hd);
      }
      return;
    }
    /* Check if already seen */
    if (Color_hd(hd) == Caml_blue) {
      uintnat d = obj_counter - (uintnat) Field(v, 0);
      if (d < 0x100) {
        writecode8(CODE_SHARED8, d);
      } else if (d < 0x10000) {
        writecode16(CODE_SHARED16, d);
      } else {
        writecode32(CODE_SHARED32, d);
      }
      return;
    }

    /* Output the contents of the object */
    switch(tag) {
    case String_tag: {
      mlsize_t len = caml_string_length(v);
      if (len < 0x20) {
        Write(PREFIX_SMALL_STRING + len);
      } else if (len < 0x100) {
        writecode8(CODE_STRING8, len);
      } else {
        writecode32(CODE_STRING32, len);
      }
      writeblock(String_val(v), len);
      size_32 += 1 + (len + 4) / 4;
      size_64 += 1 + (len + 8) / 8;
      extern_record_location(v);
      break;
    }
    case Double_tag: {
      if (sizeof(double) != 8)
        extern_invalid_argument("output_value: non-standard floats");
      Write(CODE_DOUBLE_NATIVE);
      writeblock_float8((double *) v, 1);
      size_32 += 1 + 2;
      size_64 += 1 + 1;
      extern_record_location(v);
      break;
    }
    case Double_array_tag: {
      mlsize_t nfloats;
      if (sizeof(double) != 8)
        extern_invalid_argument("output_value: non-standard floats");
      nfloats = Wosize_val(v) / Double_wosize;
      if (nfloats < 0x100) {
        writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
      } else {
        writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
      }
      writeblock_float8((double *) v, nfloats);
      size_32 += 1 + nfloats * 2;
      size_64 += 1 + nfloats;
      extern_record_location(v);
      break;
    }
    case Abstract_tag:
      extern_invalid_argument("output_value: abstract value (Abstract)");
      break;
    case Infix_tag:
      writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
      extern_rec(v - Infix_offset_hd(hd));
      break;
    case Custom_tag: {
      uintnat sz_32, sz_64;
      char * ident = Custom_ops_val(v)->identifier;
      void (*serialize)(value v, uintnat * wsize_32,
                        uintnat * wsize_64)
        = Custom_ops_val(v)->serialize;
      if (serialize == NULL)
        extern_invalid_argument("output_value: abstract value (Custom)");
      Write(CODE_CUSTOM);
      writeblock(ident, strlen(ident) + 1);
      Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
      size_32 += 2 + ((sz_32 + 3) >> 2);  /* header + ops + data */
      size_64 += 2 + ((sz_64 + 7) >> 3);
      extern_record_location(v);
      break;
    }
    default: {
      value field0;
      mlsize_t i;
      if (tag < 16 && sz < 8) {
        Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
      } else if (hd >= ((uintnat)1 << 32)) {
        writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
      } else {
        writecode32(CODE_BLOCK32, Whitehd_hd (hd));
      }
      size_32 += 1 + sz;
      size_64 += 1 + sz;
      field0 = Field(v, 0);
      extern_record_location(v);
      if (sz == 1) {
        v = field0;
      } else {
        extern_rec(field0);
        for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
        v = Field(v, i);
      }
      goto tailcall;
    }
    }
  }
コード例 #22
0
ファイル: dump_stubs.c プロジェクト: iskandr/parakeet-retired
value read_dump_file(value filename) {
  CAMLparam1(filename);
  CAMLlocal5(ocaml_var, ocaml_list_el1, ocaml_list_el2,
             ocaml_dyn_type, ocaml_dyn_aux);
  CAMLlocal2(ocaml_name, ocaml_hostval);

  printf("opening %s\n", String_val(filename));
  FILE *ifile = fopen(String_val(filename), "r");
  if (ifile == NULL) {
    ocaml_var = Val_int(0);
    CAMLreturn(ocaml_var);
  }

  int num_vars = 0;
  fread(&num_vars, sizeof(int), 1, ifile);
  if (num_vars == 0) {
    ocaml_var = Val_int(0);
    CAMLreturn(ocaml_var);
  }

  printf("parsing vars\n");
  ocaml_list_el2 = caml_alloc_tuple(2);
  int i, j;
  int name_len, shape_len, type, num_bytes;
  int *shape;
  char *name, *data;
  for (i = 0; i < num_vars; ++i) {
    // Allocate the variable tuple of (name, hostval)
    ocaml_var = caml_alloc_tuple(2);

    // Build the name
    fread(&name_len, sizeof(int), 1, ifile);
    ocaml_name = caml_alloc_string(name_len);
    fread(String_val(ocaml_name), sizeof(char), name_len, ifile);
    Store_field(ocaml_var, 0, ocaml_name);
    printf("got var name: %s\n", String_val(ocaml_name));

    // Build the shape
    fread(&shape_len, sizeof(int), 1, ifile);
    shape = (int*)malloc(shape_len * sizeof(int));
    fread(shape, sizeof(int), shape_len, ifile);
    printf("got shape of len %d\n", shape_len);

    // Build the DynType
    fread(&ocaml_dyn_type, sizeof(value), 1, ifile);
    for (j = 0; j < shape_len; ++j) {
      ocaml_dyn_aux = ocaml_dyn_type;
      ocaml_dyn_type = caml_alloc(1, VecT);
      Store_field(ocaml_dyn_type, 0, ocaml_dyn_aux);
    }
    printf("built dyn_type\n");

    // Get the num_bytes
    fread(&num_bytes, sizeof(int), 1, ifile);

    // Get the payload
    data = (char*)malloc(num_bytes);
    fread(data, 1, num_bytes, ifile);
    printf("got payload of %d bytes\n", num_bytes);

    // Build the HostVal
    ocaml_hostval = build_ocaml_hostval(num_bytes, ocaml_dyn_type,
                                        shape, shape_len, data);
    printf("built hostval from inputs\n");
    Store_field(ocaml_var, 1, ocaml_hostval);
    
    // Insert the var into the list
    if (i == 0) {
      Store_field(ocaml_list_el2, 1, Val_int(0));
    } else {
      Store_field(ocaml_list_el2, 1, ocaml_list_el1);
    }
    Store_field(ocaml_list_el2, 0, ocaml_var);
    if (i < num_vars - 1) {
      ocaml_list_el1 = ocaml_list_el2;
      ocaml_list_el2 = caml_alloc_tuple(2);
    }
  }

  fclose(ifile);

  CAMLreturn(ocaml_list_el2);
}
コード例 #23
0
ファイル: hh_shared.c プロジェクト: 5heri/hhvm
static char* hh_store_ocaml(value data) {
  size_t data_size = caml_string_length(data);
  char* addr = hh_alloc(data_size);
  memcpy(addr, String_val(data), data_size);
  return addr;
}
コード例 #24
0
ファイル: xdiff.c プロジェクト: Dunedan/weidu
value xdiff_revpatch( value old_data, value patch) 
{
    CAMLparam2 (old_data, patch);
    CAMLlocal1(res);
    mmfile_t mf1, mf2, mf3, mf4;
    xdemitcb_t ecb, rjecb;
    long new_size, rej_size;


    res = alloc_tuple(2);

    if (xdlt_store_mmfile(String_val(old_data), string_length(old_data), &mf1) < 0) {
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdlt_store_mmfile(String_val(patch), string_length(patch), &mf2) < 0) {
        xdl_free_mmfile(&mf1);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdl_init_mmfile(&mf3, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdl_init_mmfile(&mf4, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    ecb.priv = &mf3;
    ecb.outf = xdlt_outf;
    rjecb.priv = &mf4;
    rjecb.outf = xdlt_outf;

    if (xdl_patch(&mf1, &mf2, XDL_PATCH_REVERSE, &ecb, &rjecb) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        xdl_free_mmfile(&mf4);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    new_size = xdlt_mmfile_size(&mf3);
    rej_size = xdlt_mmfile_size(&mf4);
    Field(res, 0) = alloc_string(new_size);
    Field(res, 1) = alloc_string(rej_size);
    if (xdlt_read_mmfile(String_val(Field(res, 0)), &mf3) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        xdl_free_mmfile(&mf4);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }
    if (xdlt_read_mmfile(String_val(Field(res, 1)), &mf4) < 0) {
        xdl_free_mmfile(&mf1);
        xdl_free_mmfile(&mf2);
        xdl_free_mmfile(&mf3);
        xdl_free_mmfile(&mf4);
        sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
        failwith(ELINE);
    }

    xdl_free_mmfile(&mf1);
    xdl_free_mmfile(&mf2);
    xdl_free_mmfile(&mf3);
    xdl_free_mmfile(&mf4);

    CAMLreturn(res);
}
コード例 #25
0
ファイル: unlink.c プロジェクト: avsm/ocaml-ppa
CAMLprim value unix_unlink(value path)
{
  if (unlink(String_val(path)) == -1) uerror("unlink", path);
  return Val_unit;
}
コード例 #26
0
/* given a return value in OCaml land, translate it to 
   the return_val_t C structure
*/ 
return_val_t translate_return_value(value ocaml_result) {
  CAMLparam1(ocaml_result);
  CAMLlocal5(ocaml_shape, ocaml_strides, ocaml_data, ocaml_cur, ocaml_type);
  CAMLlocal1(v);
  
  return_val_t ret;
  
  if (Is_long(ocaml_result)) {
    // In this case, we know that the return code must have been Pass,
    // since the other two return codes have data.
    ret.return_code = RET_PASS;
    ret.results_len = 0;
  } else if (Tag_val(ocaml_result) == RET_FAIL) {
    ret.return_code = RET_FAIL;
    ret.results_len = caml_string_length(Field(ocaml_result, 0));
    ret.error_msg = malloc(ret.results_len + 1);
    strcpy(ret.error_msg, String_val(Field(ocaml_result, 0)));
  } else if (Tag_val(ocaml_result) == RET_SUCCESS) {
    
    ocaml_cur = Field(ocaml_result, 0);
    ret.return_code = RET_SUCCESS;
    ret.results_len = ocaml_list_length(ocaml_cur);
    ret.results = (ret_t*)malloc(sizeof(ret_t) * ret.results_len);
    
    int i, j;
    host_val h; 
    for (i = 0; i < ret.results_len; ++i) {
      v = Field(ocaml_cur, 0);
      h = create_host_val(v);  
      ocaml_cur = Field(ocaml_cur, 1);
      // returning a scalar
      if (value_is_scalar(h)) {

        ret.results[i].is_scalar = 1;
        ocaml_type = (scalar_type)value_type_of(h);
        ret.results[i].data.scalar.ret_type =
            get_scalar_element_type(ocaml_type);

        // WARNING:
        // Tiny Memory Leak Ahead
        // -----------------------
        // When scalar data is returned to the host language
        // on the heap, it should be manually deleted by the
        // host frontend

        if (type_is_bool(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.boolean = get_bool(h);
        } else if (type_is_int32(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.int32 = get_int32(h);
        } else if (type_is_int64(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.int64 = get_int64(h);
        } else if (type_is_float32(ocaml_type)) { 
          ret.results[i].data.scalar.ret_scalar_value.float32 = get_float64(h);
        } else if (type_is_float64(ocaml_type)) {
          ret.results[i].data.scalar.ret_scalar_value.float64 = get_float64(h);
        } else {
          caml_failwith("Unable to return scalar of this type\n");
        }
      } else {
        // Pass the type
        ret.results[i].is_scalar = 0;
        ret.results[i].data.array.ret_type = array_type_of(h);

        // Pass the data
        ret.results[i].data.array.data = get_array_data(h);

        // Build the shape array
        ocaml_shape = value_get_shape(h);
        int shape_len = Wosize_val(ocaml_shape);

        ret.results[i].data.array.shape =
            (int*)malloc(shape_len * sizeof(int));
        ret.results[i].data.array.shape_len = shape_len;
        for (j = 0; j < shape_len; ++j) {
          ret.results[i].data.array.shape[j] = Int_val(Field(ocaml_shape, j));
        }

        // Build the strides array
        ocaml_strides = value_get_strides(h);
        int strides_len = Wosize_val(ocaml_strides);

        ret.results[i].data.array.strides_len = strides_len;
        ret.results[i].data.array.strides =
            (int*)malloc(strides_len * sizeof(int));
        for (j = 0; j < strides_len; ++j) {
          ret.results[i].data.array.strides[j] =
              Int_val(Field(ocaml_strides, j));
        }
      }
    }
  }
  CAMLreturnT(return_val_t, ret);
	
}
コード例 #27
0
CAMLprim value unix_rmdir(value path)
{
  if (rmdir(String_val(path)) == -1) uerror("rmdir", path);
  return Val_unit;
}
コード例 #28
0
ファイル: sys.c プロジェクト: jessicah/snowflake-jocaml
CAMLprim value caml_sys_file_exists(value name)
{
  struct stat st;
  return Val_bool(stat(String_val(name), &st) == 0);
}
コード例 #29
0
ファイル: sendmsg.c プロジェクト: haesbaert/extunix
CAMLprim value caml_extunix_recvmsg(value fd_val)
{
  CAMLparam1(fd_val);
  CAMLlocal2(data, res);
  struct msghdr msg;
  int fd = Int_val(fd_val);
  int recvfd;
  ssize_t len;
  struct iovec iov[1];
  char buf[4096];

#if defined(CMSG_SPACE)
  union {
    struct cmsghdr cmsg; /* just for alignment */
    char control[CMSG_SPACE(sizeof recvfd)];
  } control_un;
  struct cmsghdr *cmsgp;

  memset(&msg, 0, sizeof msg);
  msg.msg_control = control_un.control;
  msg.msg_controllen = CMSG_LEN(sizeof recvfd);
#else
  msg.msg_accrights = (caddr_t)&recvfd;
  msg.msg_accrightslen = sizeof recvfd;
#endif

  iov[0].iov_base = buf;
  iov[0].iov_len = sizeof buf;
  msg.msg_iov = iov;
  msg.msg_iovlen = 1;

  caml_enter_blocking_section();
  len = recvmsg(fd, &msg, 0);
  caml_leave_blocking_section();

  if (len == -1)
    uerror("recvmsg", Nothing);

  res = caml_alloc(2, 0);

#if defined(CMSG_SPACE)
  cmsgp = CMSG_FIRSTHDR(&msg);
  if (cmsgp == NULL) {
    Store_field(res, 0, Val_none);
  } else {
    CAMLlocal1(some_fd); 
    if (cmsgp->cmsg_len != CMSG_LEN(sizeof recvfd))
      unix_error(EINVAL, "recvmsg", caml_copy_string("wrong descriptor size"));
    if (cmsgp->cmsg_level != SOL_SOCKET || cmsgp->cmsg_type != SCM_RIGHTS)
      unix_error(EINVAL, "recvmsg", caml_copy_string("invalid protocol"));
    some_fd = caml_alloc(1, 0);
    Store_field(some_fd, 0, Val_int(*(int *)CMSG_DATA(cmsgp)));
    Store_field(res, 0, some_fd);
  }
#else
  if (msg.msg_accrightslen != sizeof recvfd) {
    Store_field(res, 0, Val_none);
  } else {
    CAMLlocal1(some_fd);
    some_fd = caml_alloc(1, 0);
    Store_field(some_fd, 0, Val_int(recvfd));
    Store_field(res, 0, some_fd);
  }
#endif

  data = caml_alloc_string(len);
  memcpy(String_val(data), buf, len);
  Store_field(res, 1, data);

  CAMLreturn (res);
}
コード例 #30
0
PREFIX value ml_elm_fileselector_path_set(value v_obj, value v_path)
{
        elm_fileselector_path_set((Evas_Object*) v_obj, String_val(v_path));
        return Val_unit;
}