C++ Is_block函数代码示例

CAMLexport char * caml_format_exception_r(CAML_R, value exn)
{
  mlsize_t start, i;
  value bucket, v;
  struct stringbuf buf;
  char intbuf[64];
  char * res;

  buf.ptr = buf.data;
  buf.end = buf.data + sizeof(buf.data) - 1;
  add_string(&buf, String_val(Field(Field(exn, 0), 0)));
  if (Wosize_val(exn) >= 2) {
    /* Check for exceptions in the style of Match_failure and Assert_failure */
    if (Wosize_val(exn) == 2 &&
        Is_block(Field(exn, 1)) &&
        Tag_val(Field(exn, 1)) == 0 &&
        caml_is_special_exception_r(ctx, Field(exn, 0))) {
      bucket = Field(exn, 1);
      start = 0;
    } else {
      bucket = exn;
      start = 1;
    }
    add_char(&buf, '(');
    for (i = start; i < Wosize_val(bucket); i++) {
      if (i > start) add_string(&buf, ", ");
      v = Field(bucket, i);
      if (Is_long(v)) {
        sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
        add_string(&buf, intbuf);
      } else if (Tag_val(v) == String_tag) {
        add_char(&buf, '"');
        add_string(&buf, String_val(v));
        add_char(&buf, '"');
      } else {
        add_char(&buf, '_');
      }
    }
    add_char(&buf, ')');
  }
  *buf.ptr = 0;              /* Terminate string */
  i = buf.ptr - buf.data + 1;
  res = malloc(i);
  if (res == NULL) return NULL;
  memmove(res, buf.data, i);
  return res;
}

static intnat pool_sweep(struct caml_heap_state* local, pool** plist, sizeclass sz) {
  pool* a = *plist;
  if (!a) return 0;
  *plist = a->next;

  value* p = (value*)((char*)a + POOL_HEADER_SZ);
  value* end = (value*)a + POOL_WSIZE;
  mlsize_t wh = wsize_sizeclass[sz];
  int all_free = 1, all_used = 1;
  struct heap_stats* s = &local->stats;

  while (p + wh <= end) {
    header_t hd = (header_t)*p;
    if (hd == 0) {
      /* already on freelist */
      all_used = 0;
    } else if (Has_status_hd(hd, global.GARBAGE)) {
      Assert(Whsize_hd(hd) <= wh);
      /* add to freelist */
      p[0] = 0;
      p[1] = (value)a->next_obj;
      Assert(Is_block((value)p));
      a->next_obj = p;
      all_used = 0;
      /* update stats */
      s->pool_live_blocks--;
      s->pool_live_words -= Whsize_hd(hd);
      s->pool_frag_words -= (wh - Whsize_hd(hd));
    } else {
      /* still live */
      all_free = 0;
    }
    p += wh;
  }

  if (all_free) {
    pool_release(local, a, sz);
  } else {
    pool** list = all_used ? &local->full_pools[sz] : &local->avail_pools[sz];
    a->next = *list;
    *list = a;
  }

  return POOL_WSIZE;
}

CAMLprim value caml_install_signal_handler(value signal_number, value action)
{
  CAMLparam2 (signal_number, action);
  CAMLlocal1 (res);
  int sig, act, oldact;

  sig = caml_convert_signal_number(Int_val(signal_number));
  if (sig < 0 || sig >= NSIG)
    caml_invalid_argument("Sys.signal: unavailable signal");
  switch(action) {
  case Val_int(0):              /* Signal_default */
    act = 0;
    break;
  case Val_int(1):              /* Signal_ignore */
    act = 1;
    break;
  default:                      /* Signal_handle */
    act = 2;
    break;
  }
  oldact = caml_set_signal_action(sig, act);
  switch (oldact) {
  case 0:                       /* was Signal_default */
    res = Val_int(0);
    break;
  case 1:                       /* was Signal_ignore */
    res = Val_int(1);
    break;
  case 2:                       /* was Signal_handle */
    res = caml_alloc_small (1, 0);
    Field(res, 0) = Field(caml_signal_handlers, sig);
    break;
  default:                      /* error in caml_set_signal_action */
    caml_sys_error(NO_ARG);
  }
  if (Is_block(action)) {
    if (caml_signal_handlers == 0) {
      caml_signal_handlers = caml_alloc(NSIG, 0);
      caml_register_global_root(&caml_signal_handlers);
    }
    caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0));
  }
  caml_process_pending_signals();
  CAMLreturn (res);
}

static value next_minor_block(caml_domain_state* domain_state, value curr_hp)
{
  mlsize_t wsz;
  header_t hd;
  value curr_val;
  CAMLassert ((value)domain_state->young_ptr <= curr_hp);
  CAMLassert (curr_hp < (value)domain_state->young_end);
  hd = Hd_hp(curr_hp);
  curr_val = Val_hp(curr_hp);
  if (hd == 0) {
    /* Forwarded object, find the promoted version */
    curr_val = Op_val(curr_val)[0];
  }
  CAMLassert (Is_block(curr_val) && Hd_val(curr_val) != 0 && Tag_val(curr_val) != Infix_tag);
  wsz = Wosize_val(curr_val);
  CAMLassert (wsz <= Max_young_wosize);
  return curr_hp + Bsize_wsize(Whsize_wosize(wsz));
}

/*
 * Compute the size of the argument (of type TkArgs).
 * TkTokenList must be expanded,
 * TkQuote count for one.
 */
int argv_size(value v)
{
  switch (Tag_val(v)) {
  case 0:                       /* TkToken */
    return 1;
  case 1:                       /* TkTokenList */
    { int n = 0;
      value l;
      for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1))
        n+=argv_size(Field(l,0));
      return n;
    }
  case 2:                       /* TkQuote */
    return 1;
  default:
    tk_error("argv_size: illegal tag");
  }
}

/* Test if the ephemeron is alive */
static inline int ephe_check_alive_data (struct caml_ephe_ref_elt *re,
                                         char* young_ptr, char* young_end)
{
  mlsize_t i;
  value child;

  for (i = CAML_EPHE_FIRST_KEY; i < Wosize_val(re->ephe); i++) {
    child = Op_val(re->ephe)[i];
    if (child != caml_ephe_none
        && Is_block (child) && is_in_interval(child, young_ptr, young_end)) {
      resolve_infix_val(&child);
      if (Hd_val(child) != 0) {
        /* value not copied to major heap */
        return 0;
      }
    }
  }
  return 1;
}

CAMLprim value unix_error_message(value err)
{
  int errnum;
  char buffer[512];

  errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
  if (errnum > 0)
    return copy_string(strerror(errnum));
  if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
                    NULL,
                    -errnum,
                    0,
                    buffer,
                    sizeof(buffer),
                    NULL))
    return copy_string(buffer);
  sprintf(buffer, "unknown error #%d", errnum);
  return copy_string(buffer);
}

/* Make sure the minor heap is empty by performing a minor collection
   if needed.
*/
void caml_empty_minor_heap (void)
{
  value **r;

  if (caml_young_ptr != caml_young_end){
    caml_in_minor_collection = 1;
    caml_gc_message (0x02, "<", 0);
    caml_oldify_local_roots();
    for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){
      caml_oldify_one (**r, *r);
    }
    caml_oldify_mopup ();
    for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){
      if (Is_block (**r) && Is_young (**r)){
        if (Hd_val (**r) == 0){
          **r = Field (**r, 0);
        }else{
          **r = caml_weak_none;
        }
      }
    }
    if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start;
    caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr);
    caml_young_ptr = caml_young_end;
    caml_young_limit = caml_young_start;
    clear_table (&caml_ref_table);
    clear_table (&caml_weak_ref_table);
    caml_gc_message (0x02, ">", 0);
    caml_in_minor_collection = 0;
  }
  caml_final_empty_young ();
#ifdef DEBUG
  {
    value *p;
    for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){
      *p = Debug_free_minor;
    }
    ++ minor_gc_counter;
  }
#endif
}

CAMLexport value caml_promote(struct domain* domain, value root)
{
  struct promotion_stack stk = {0};

  if (Is_long(root))
    /* Integers are already shared */
    return root;

  if (Tag_val(root) == Stack_tag)
    /* Stacks are handled specially */
    return promote_stack(domain, root);

  if (!Is_minor(root))
    /* This value is already shared */
    return root;

  Assert(caml_owner_of_young_block(root) == domain);

  value ret = caml_promote_one(&stk, domain, root);

  while (stk.sp > 0) {
    struct promotion_stack_entry* curr = &stk.stack[stk.sp - 1];
    value local = curr->local;
    value global = curr->global;
    int field = curr->field;
    Assert(field < Wosize_val(local));
    curr->field++;
    if (curr->field == Wosize_val(local))
      stk.sp--;
    value x = Op_val(local)[field];
    if (Is_block(x) && Tag_val(x) == Stack_tag) {
      /* stacks are not promoted unless explicitly requested */
      Ref_table_add(&domain->state->remembered_set->ref, global, field);
    } else {
      x = caml_promote_one(&stk, domain, x);
    }
    Op_val(local)[field] = Op_val(global)[field] = x;
  }
  caml_stat_free(stk.stack);
  return ret;
}

CAMLprim value netsys_mknod (value name, value perm, value nt)
{
#ifdef _WIN32
    invalid_argument("Netsys_posix.mknod not available");
#else
    mode_t m;
    dev_t d;
    int e;

    m = Long_val(perm) & 07777;
    d = 0;
    if (Is_block(nt)) {
	switch (Tag_val(nt)) {
	case 0:  /* = S_IFCHR */
	    m |= S_IFCHR;
	    d = Long_val(Field(nt,0));
	    break;
	case 1:  /* = S_IFBLK */
	    m |= S_IFBLK;
	    d = Long_val(Field(nt,0));
	    break;
	}
    }
    else {
	switch (Long_val(nt)) {
	case 0:  /* = S_IFREG */
	    m |= S_IFREG; break;
	case 1:  /* = S_IFIFO */
	    m |= S_IFIFO; break;
	case 2:  /* = S_IFSOCK */
	    m |= S_IFSOCK; break;
	}

    }

    e = mknod(String_val(name), m, d);
    if (e < 0) uerror("mknod", Nothing);

    return Val_unit;
#endif
}

CAMLprim value ml_gsl_monte_vegas_set_params(value state, value params)
{
    gsl_monte_vegas_state *s = GSLVEGASSTATE_VAL(state);
    s->alpha      = Double_val(Field(params, 0));
    s->iterations = Int_val(Field(params, 1));
    s->stage      = Int_val(Field(params, 2));
    s->mode       = Int_val(Field(params, 3)) - 1;
    s->verbose    = Int_val(Field(params, 4));
    {
        value vchan = Field(params, 5);
        if(Is_block(vchan)) {
            struct channel *chan=Channel(Field(vchan, 0));
            if(s->ostream != stdout && s->ostream != stderr)
                fclose(s->ostream);
            flush(chan);
            s->ostream = fdopen(dup(chan->fd), "w");
            GSLVEGASSTREAM_VAL(state) = vchan;
        }
    }
    return Val_unit;
}

CAMLprim value caml_weak_get (value ar, value n)
{
  CAMLparam2 (ar, n);
  mlsize_t offset = Long_val (n) + 1;
  CAMLlocal2 (res, elt);
                                                   Assert (Is_in_heap (ar));
  if (offset < 1 || offset >= Wosize_val (ar)){
    caml_invalid_argument ("Weak.get");
  }
  if (Field (ar, offset) == caml_weak_none){
    res = None_val;
  }else{
    elt = Field (ar, offset);
    if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){
      caml_darken (elt, NULL);
    }
    res = caml_alloc_small (1, Some_tag);
    Field (res, 0) = elt;
  }
  CAMLreturn (res);
}

CAMLexport value
unix_setsockopt_aux(char * name,
                    enum option_type ty, int level, int option,
                    value socket, value val)
{
  union option_value optval;
  socklen_param_type optsize;
  double f;

  switch (ty) {
  case TYPE_BOOL:
  case TYPE_INT:
    optsize = sizeof(optval.i);
    optval.i = Int_val(val);
    break;
  case TYPE_LINGER:
    optsize = sizeof(optval.lg);
    optval.lg.l_onoff = Is_block (val);
    if (optval.lg.l_onoff)
      optval.lg.l_linger = Int_val (Field (val, 0));
    break;
  case TYPE_TIMEVAL:
    f = Double_val(val);
    optsize = sizeof(optval.tv);
    optval.tv.tv_sec = (int) f;
    optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec));
    break;
  case TYPE_UNIX_ERROR:
  default:
    unix_error(EINVAL, name, Nothing);
  }

  if (setsockopt(Int_val(socket), level, option,
                 (void *) &optval, optsize) == -1)
    uerror(name, Nothing);

  return Val_unit;
}

/* Check that [v]'s header looks good.  [v] must be a block in the heap. */
static void check_head (value v)
{
  Assert (Is_block (v));
  Assert (Is_in_heap (v));

  Assert (Wosize_val (v) != 0);
  Assert (Color_hd (Hd_val (v)) != Caml_blue);
  Assert (Is_in_heap (v));
  if (Tag_val (v) == Infix_tag){
    int offset = Wsize_bsize (Infix_offset_val (v));
    value trueval = Val_op (&Field (v, -offset));
    Assert (Tag_val (trueval) == Closure_tag);
    Assert (Wosize_val (trueval) > offset);
    Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1)));
  }else{
    Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1)));
  }
  if (Tag_val (v) ==  Double_tag){
    Assert (Wosize_val (v) == Double_wosize);
  }else if (Tag_val (v) == Double_array_tag){
    Assert (Wosize_val (v) % Double_wosize == 0);
  }
}

CAMLprim value ocaml_f0r_update(value plugin, value instance, value time, value inframe, value outframe)
{
  CAMLparam5(plugin, instance, time, inframe, outframe);
  f0r_instance_t *i = Instance_val(instance);
  plugin_t *p = Plugin_val(plugin);
  double t = Double_val(time);
  const uint32_t *in;
  uint32_t *out = Caml_ba_data_val(outframe);

  if (Is_block(inframe))
    in = Caml_ba_data_val(Field(inframe,0));
  else
    in = NULL;

  caml_release_runtime_system();
  if (p->update)
    p->update(i, t, in, out);
  else
    p->update2(i, t, in, NULL, NULL, out);
  caml_acquire_runtime_system();

  CAMLreturn(Val_unit);
}