Exemplo n.º 1
0
/* 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);
  }
}
Exemplo n.º 2
0
CAMLprim value caml_update_dummy(value dummy, value newval)
{
    mlsize_t size, i;
    tag_t tag;

    size = Wosize_val(newval);
    tag = Tag_val (newval);
    Assert (size == Wosize_val(dummy));
    Assert (tag < No_scan_tag || tag == Double_array_tag);

    Tag_val(dummy) = tag;
    if (tag == Double_array_tag) {
        size = Wosize_val (newval) / Double_wosize;
        for (i = 0; i < size; i++) {
            Store_double_field (dummy, i, Double_field (newval, i));
        }
    } else {
        for (i = 0; i < size; i++) {
            caml_modify (&Field(dummy, i), Field(newval, i));
        }
    }
    return Val_unit;
}
Exemplo n.º 3
0
// ML type: surface -> point -> color -> unit
// Draws a pixel on the surface.
EXTERNML value draw_draw_pixel(value wScreen, value wPos, value wColor) {
    SDL_Surface *screen = (SDL_Surface *)Addr_val(wScreen);

    int x = Long_val(Field(wPos, 0)),
        y = Long_val(Field(wPos, 1)),
        colorr = Long_val(Field(wColor, 0)),
        colorg = Long_val(Field(wColor, 1)),
        colorb = Long_val(Field(wColor, 2)),
        colora = Tag_val(wColor) == RGBA ? Long_val(Field(wColor, 3)) : 255;

    pixelRGBA(screen, x, y, colorr, colorg, colorb, colora);

    return Val_unit;
}
Exemplo n.º 4
0
CAMLprim value ml_gsl_ran_sample(value rng, value src, value dest)
{
  if(Tag_val(src) == Double_array_tag)
    gsl_ran_sample(Rng_val(rng), 
		   Double_array_val(dest), Double_array_length(dest),
		   Double_array_val(src), Double_array_length(src),
		   sizeof(double));
  else
    gsl_ran_sample(Rng_val(rng), 
		   (value *)dest, Array_length(dest),
		   (value *)src,  Array_length(src),
		   sizeof(value));
  return Val_unit;
}
Exemplo n.º 5
0
void caml_maybe_expand_stack (value* gc_regs)
{
  CAMLparamN(gc_regs, 5);
  uintnat stack_available;

  Assert(Tag_val(caml_current_stack) == Stack_tag);

  stack_available = Bosize_val(caml_current_stack)
    - (Stack_sp(caml_current_stack) + Stack_ctx_words * sizeof(value));
  if (stack_available < 2 * Stack_threshold)
    caml_realloc_stack ();

  CAMLreturn0;
}
Exemplo n.º 6
0
CAMLprim value ml_stable_copy (value v)
{
    if (Is_block(v) && (char*)(v) < young_end && (char*)(v) > young_start)
    {
        CAMLparam1(v);
        mlsize_t i, wosize = Wosize_val(v);
        int tag = Tag_val(v);
        value ret;
        if (tag < No_scan_tag) invalid_argument("ml_stable_copy");
        ret = alloc_shr (wosize, tag);
        for (i=0; i < wosize; i++) Field(ret,i) = Field(v,i);
        CAMLreturn(ret);
    }
    return v;
}
Exemplo n.º 7
0
static void print_token(struct parser_tables *tables, int state, value tok)
{
  CAMLparam1 (tok);
  CAMLlocal1 (v);

  if (Is_long(tok)) {
    fprintf(stderr, "State %d: read token %s\n",
            state, token_name(tables->names_const, Int_val(tok)));
  } else {
    fprintf(stderr, "State %d: read token %s(",
            state, token_name(tables->names_block, Tag_val(tok)));
    caml_read_field(tok, 0, &v);
    if (Is_long(v))
      fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
    else if (Tag_val(v) == String_tag)
      fprintf(stderr, "%s", String_val(v));
    else if (Tag_val(v) == Double_tag)
      fprintf(stderr, "%g", Double_val(v));
    else
      fprintf(stderr, "_");
    fprintf(stderr, ")\n");
  }
  CAMLreturn0;
}
Exemplo n.º 8
0
//onMouseClicked: string->unit
void Controller::onMouseClicked(QString x0) {
  CAMLparam0();
  CAMLlocal3(_ans,_meth,_x0);
  CAMLlocalN(_args,2);
  CAMLlocal1(_cca0);
  value _camlobj = this->_camlobjHolder;
  Q_ASSERT(Is_block(_camlobj));
  Q_ASSERT(Tag_val(_camlobj) == Object_tag);
  _meth = caml_get_public_method(_camlobj, caml_hash_variant("onMouseClicked"));
  _args[0] = _camlobj;
  _cca0 = caml_copy_string(x0.toLocal8Bit().data() );
  _args[1] = _cca0;
  caml_callbackN(_meth, 2, _args);
  CAMLreturn0;
}
Exemplo n.º 9
0
value unix_util_write(value fd,value buf)
{
  value vres=alloc(1,1); /* Ok result */
  int res;
  enter_blocking_section();
  res = write(Int_val(fd), /* TODO: unsafe coercion */
	      Bigarray_val(buf)->data,Bigarray_val(buf)->dim[0]);
  leave_blocking_section();
  if (res >=0) Field(vres,0)=Val_int(res);
  else 
    {
      Tag_val(vres)=0; /* Bad result */
      Field(vres,0)=Val_int(c2ml_unix_error(res)); /* TODO: EUNKNOWN x is a block */
    }
  return vres;
}
Exemplo n.º 10
0
void get_sockaddr(value mladr,
                  union sock_addr_union * adr /*out*/,
                  socklen_param_type * adr_len /*out*/)
{
  switch(Tag_val(mladr)) {
#ifndef _WIN32
  case 0:                       /* ADDR_UNIX */
    { value path;
      mlsize_t len;
      path = Field(mladr, 0);
      len = string_length(path);
      adr->s_unix.sun_family = AF_UNIX;
      if (len >= sizeof(adr->s_unix.sun_path)) {
        unix_error(ENAMETOOLONG, "", path);
      }
      memmove (adr->s_unix.sun_path, String_val(path), len + 1);
      *adr_len =
        ((char *)&(adr->s_unix.sun_path) - (char *)&(adr->s_unix))
        + len;
      break;
    }
#endif
  case 1:                       /* ADDR_INET */
#ifdef HAS_IPV6
    if (string_length(Field(mladr, 0)) == 16) {
      memset(&adr->s_inet6, 0, sizeof(struct sockaddr_in6));
      adr->s_inet6.sin6_family = AF_INET6;
      adr->s_inet6.sin6_addr = GET_INET6_ADDR(Field(mladr, 0));
      adr->s_inet6.sin6_port = htons(Int_val(Field(mladr, 1)));
#ifdef SIN6_LEN
      adr->s_inet6.sin6_len = sizeof(struct sockaddr_in6);
#endif
      *adr_len = sizeof(struct sockaddr_in6);
      break;
    }
#endif
    memset(&adr->s_inet, 0, sizeof(struct sockaddr_in));
    adr->s_inet.sin_family = AF_INET;
    adr->s_inet.sin_addr = GET_INET_ADDR(Field(mladr, 0));
    adr->s_inet.sin_port = htons(Int_val(Field(mladr, 1)));
#ifdef SIN6_LEN
    adr->s_inet.sin_len = sizeof(struct sockaddr_in);
#endif
    *adr_len = sizeof(struct sockaddr_in);
    break;
  }
}
Exemplo n.º 11
0
void QWidget_twin::keyPressEvent(QKeyEvent *ev) {
    CAMLparam0();
    CAMLlocal3(meth,camlobj,_ev);
    GET_CAML_OBJECT(this,camlobj); // get ocaml object from QObject's property
    printf ("inside QWidget_twin::keyPressedEvent, camlobj = %p, this=%p\n", (void*)camlobj, this);
    meth = caml_get_public_method( camlobj, caml_hash_variant("keyPressEvent"));
    if (meth==0)
        printf ("total fail\n");
    printf ("tag of meth is %d\n", Tag_val(meth) );
    printf("calling callback of meth = %p\n",(void*)meth);
    setAbstrClass(_ev,QKeyEvent,ev);
    value *caller = caml_named_value("make_qKeyEvent");
    _ev = caml_callback(*caller, _ev);
    caml_callback2(meth, camlobj,_ev);
    printf ("exit from QWidget_twin::keyPressedEvent\n");
    CAMLreturn0;
}
Exemplo n.º 12
0
/*
 * 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");
  }
}
Exemplo n.º 13
0
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));
}
Exemplo n.º 14
0
CAMLprim value caml_make_vect(value len, value init)
{
  CAMLparam2 (len, init);
  CAMLlocal1 (res);
  mlsize_t size, wsize, i;
  double d;

  size = Long_val(len);
  if (size == 0) {
    res = Atom(0);
  }
  else if (Is_block(init)
           && Is_in_value_area(init)
           && Tag_val(init) == Double_tag) {
    d = Double_val(init);
    wsize = size * Double_wosize;
    if (wsize > Max_wosize) caml_invalid_argument("Array.make");
    res = caml_alloc(wsize, Double_array_tag);
    for (i = 0; i < size; i++) {
      Store_double_field(res, i, d);
    }
  } else {
    if (size > Max_wosize) caml_invalid_argument("Array.make");
    if (size < Max_young_wosize) {
      res = caml_alloc_small(size, 0);
      for (i = 0; i < size; i++) Field(res, i) = init;
    }
    else if (Is_block(init) && Is_young(init)) {
      caml_minor_collection();
      res = caml_alloc_shr(size, 0);
      for (i = 0; i < size; i++) Field(res, i) = init;
      res = caml_check_urgent_gc (res);
    }
    else {
      res = caml_alloc_shr(size, 0);
      for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init);
      res = caml_check_urgent_gc (res);
    }
  }
  CAMLreturn (res);
}
Exemplo n.º 15
0
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
}
Exemplo n.º 16
0
CAMLprim value c_restore_material( value _face_mode, value v /* material_mode */,
                                   value material_state ) {
    GLenum pname;
    GLenum face_mode;
#include "enums/face_mode.inc.c"
    switch (Tag_val(v))
    {
        case 0: pname = GL_AMBIENT; break;
        case 1: pname = GL_DIFFUSE; break;
        case 2: pname = GL_SPECULAR; break;
        case 3: pname = GL_EMISSION; break;
        case 4: pname = GL_SHININESS; break;
        case 5: pname = GL_AMBIENT_AND_DIFFUSE; break;
        case 6: pname = GL_COLOR_INDEXES; break;
 
        default: caml_failwith("variant handling bug");
    }
    glMaterialfv( face_mode, pname, (GLfloat *)material_state );
    free((void *)material_state);
    return Val_unit;
}
Exemplo n.º 17
0
value
ffmpeg_stream_new(value ctx, value media_kind_)
{
  CAMLparam2(ctx, media_kind_);
  CAMLlocal1(ret);

  if (Context_val(ctx)->fmtCtx) {
    switch (Tag_val(media_kind_)) {
    case 0: {
      ret = ffmpeg_stream_new_video(ctx, Field(media_kind_, 0));
    } break;
    case 1: {
      ret = ffmpeg_stream_new_audio(ctx, Field(media_kind_, 0));
    } break;
    }
  } else {
    raise(ExnClosed, 0);
  }
  
  CAMLreturn(ret);
}
Exemplo n.º 18
0
static value promote_stack(struct domain* domain, value stack)
{
  caml_gc_log("Promoting stack");
  Assert(Tag_val(stack) == Stack_tag);
  if (Is_minor(stack)) {
    /* First, promote the actual stack object */
    Assert(caml_owner_of_young_block(stack) == domain);
    /* Stacks are only referenced via fibers, so we don't bother
       using the promotion_table */
    void* new_stack = caml_shared_try_alloc(domain->shared_heap, Wosize_val(stack), Stack_tag, 0);
    if (!new_stack) caml_fatal_error("allocation failure during stack promotion");
    memcpy(Op_hp(new_stack), (void*)stack, Wosize_val(stack) * sizeof(value));
    stack = Val_hp(new_stack);
  }

  /* Promote each object on the stack. */
  promote_domain = domain;
  caml_scan_stack(&promote_stack_elem, stack);
  /* Since we've promoted the objects on the stack, the stack is now clean. */
  caml_clean_stack_domain(stack, domain);
  return stack;
}
Exemplo n.º 19
0
CAMLprim value
uwt_udp_recv_own(value o_udp,value o_offset,value o_len,value o_buf_cb)
{
  HANDLE_INIT2_NO_UNINIT(u, o_udp, o_buf_cb);
  const int ba = Tag_val(Field(o_buf_cb,0)) != String_tag;
  size_t len = Long_val(o_len);
  value ret;
  if ( u->cb_read != CB_INVALID ){
    ret = VAL_UWT_INT_RESULT_EBUSY;
  }
  else if ( len > ULONG_MAX ){
    ret = VAL_UWT_INT_RESULT_EINVAL;
  }
  else {
    int erg = 0;
    uv_udp_t* ux = (uv_udp_t*)u->handle;
    if ( u->can_reuse_cb_read == 0 ){
      erg = uv_udp_recv_start(ux,uwt__alloc_own_cb,uwt_udp_recv_own_cb);
    }
    if ( erg >= 0 ){
      size_t offset = Long_val(o_offset);
      uwt__gr_register(&u->cb_read,o_buf_cb);
      ++u->in_use_cnt;
      u->c_read_size = len;
      u->use_read_ba = ba;
      u->read_waiting = 1;
      u->can_reuse_cb_read = 0;
      if ( ba == 0 ){
        u->x.obuf_offset = offset;
      }
      else {
        u->x.ba_read = Ba_buf_val(Field(o_buf_cb,0)) + offset;
      }
    }
    ret = VAL_UWT_UNIT_RESULT(erg);
  }
  CAMLreturn(ret);
}
Exemplo n.º 20
0
static int bbbdcomm(sundials_ml_index nlocal, realtype t, N_Vector y,
		    N_Vector yb, void *user_data)
{
    CAMLparam0();
    CAMLlocal3(args, session, cb);

    args = caml_alloc_tuple (RECORD_CVODES_ADJ_BRHSFN_ARGS_SIZE);
    Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_T, caml_copy_double (t));
    Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_Y, NVEC_BACKLINK (y));
    Store_field (args, RECORD_CVODES_ADJ_BRHSFN_ARGS_YB, NVEC_BACKLINK (yb));

    WEAK_DEREF (session, *(value*)user_data);
    cb = CVODE_LS_PRECFNS_FROM_ML (session);
    cb = Field (cb, 0);
    cb = Field (cb, RECORD_CVODES_BBBD_PRECFNS_COMM_FN);
    cb = Some_val (cb);
    assert (Tag_val (cb) == Closure_tag);

    /* NB: Don't trigger GC while processing this return value!  */
    value r = caml_callback_exn (cb, args);

    CAMLreturnT(int, CHECK_EXCEPTION (session, r, RECOVERABLE));
}
Exemplo n.º 21
0
CAMLprim value c_set_get_lightModel( value light_model ) {
    GLfloat *lightModel_state;
    GLenum pname = 0;
    lightModel_state = malloc(4 * sizeof(GLfloat));
    switch (Tag_val(light_model))
    {
        case 0:
          { GLfloat param[4];
            pname = GL_LIGHT_MODEL_AMBIENT;
            param[0] = Double_val(Field(light_model,0));
            param[1] = Double_val(Field(light_model,1));
            param[2] = Double_val(Field(light_model,2));
            param[3] = Double_val(Field(light_model,3));
            glGetFloatv( pname, lightModel_state );
            glLightModelfv( pname, param );
          } break;
 
        case 1:
            pname = GL_LIGHT_MODEL_COLOR_CONTROL;
            glGetFloatv( pname, lightModel_state );
            glLightModeli(
                pname,
                (Int_val(Field(light_model,0)) ?
                    GL_SINGLE_COLOR :
                    GL_SEPARATE_SPECULAR_COLOR) );
            break;
 
        case 2: pname = GL_LIGHT_MODEL_LOCAL_VIEWER;
        case 3: if (pname == 0) pname = GL_LIGHT_MODEL_TWO_SIDE;
            glGetFloatv( pname, lightModel_state );
            glLightModeli(
                pname,
                Int_val(Field(light_model,0)) );
            break;
    }
    return (value) lightModel_state;
}
Exemplo n.º 22
0
/* will need to test every variant cases */
CAMLprim value c_set_get_material( value _face_mode, value v /* material_mode */ ) {
    GLenum face_mode;
    GLfloat * material_state;
#include "enums/face_mode.inc.c"
    material_state = malloc(4 * sizeof(GLfloat));
    switch (Tag_val(v))
    {
#define set_get_glMaterial_with_4_floats(pname) \
          { GLfloat params[4]; \
            params[0] = Double_val(Field(v,0)); \
            params[1] = Double_val(Field(v,1)); \
            params[2] = Double_val(Field(v,2)); \
            params[3] = Double_val(Field(v,3)); \
            glGetMaterialfv( \
                face_mode, \
                (pname == GL_AMBIENT_AND_DIFFUSE ? GL_AMBIENT : pname), \
                material_state ); \
            glMaterialfv( \
                face_mode, \
                pname, \
                params ); \
          }
        case 0:
            set_get_glMaterial_with_4_floats(GL_AMBIENT); break;
        case 1:
            set_get_glMaterial_with_4_floats(GL_DIFFUSE); break;
        case 2:
            set_get_glMaterial_with_4_floats(GL_SPECULAR); break;
        case 3:
            set_get_glMaterial_with_4_floats(GL_EMISSION); break;
        case 5:
            set_get_glMaterial_with_4_floats(GL_AMBIENT_AND_DIFFUSE); break;
 
#undef set_get_glMaterial_with_4_floats
 
        case 4:
            glGetMaterialfv(
                face_mode,
                GL_SHININESS,
                material_state );
            glMaterialf(
                face_mode,
                GL_SHININESS,
                Double_val(Field(v,0)) );
            break;
 
        case 6:
          { GLint params[3];
            params[0] = Int_val(Field(v,0));
            params[1] = Int_val(Field(v,1));
            params[2] = Int_val(Field(v,2));
            glGetMaterialfv(
                face_mode,
                GL_COLOR_INDEXES,
                material_state );
            glMaterialiv(
                face_mode,
                GL_COLOR_INDEXES,
                params );
          }
          break;
 
        default: caml_failwith("variant handling bug");
    }
    return (value) material_state;
}
Exemplo n.º 23
0
CAMLprim value caml_parse_engine(struct parser_tables *tables,
                                 struct parser_env *env, value cmd, value arg)
{
  int state;
  mlsize_t sp, asp;
  int errflag;
  int n, n1, n2, m, state1;

  switch(Int_val(cmd)) {

  case START:
    state = 0;
    sp = Int_val(env->sp);
    errflag = 0;

  loop:
    n = Short(tables->defred, state);
    if (n != 0) goto reduce;
    if (Int_val(env->curr_char) >= 0) goto testshift;
    SAVE;
    return READ_TOKEN;
                                /* The ML code calls the lexer and updates */
                                /* symb_start and symb_end */
  case TOKEN_READ:
    RESTORE;
    if (Is_block(arg)) {
      env->curr_char = Field(tables->transl_block, Tag_val(arg));
      caml_modify(&env->lval, Field(arg, 0));
    } else {
      env->curr_char = Field(tables->transl_const, Int_val(arg));
      caml_modify(&env->lval, Val_long(0));
    }
    if (caml_parser_trace) print_token(tables, state, arg);

  testshift:
    n1 = Short(tables->sindex, state);
    n2 = n1 + Int_val(env->curr_char);
    if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
        Short(tables->check, n2) == Int_val(env->curr_char)) goto shift;
    n1 = Short(tables->rindex, state);
    n2 = n1 + Int_val(env->curr_char);
    if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
        Short(tables->check, n2) == Int_val(env->curr_char)) {
      n = Short(tables->table, n2);
      goto reduce;
    }
    if (errflag > 0) goto recover;
    SAVE;
    return CALL_ERROR_FUNCTION;
                                /* The ML code calls the error function */
  case ERROR_DETECTED:
    RESTORE;
  recover:
    if (errflag < 3) {
      errflag = 3;
      while (1) {
        state1 = Int_val(Field(env->s_stack, sp));
        n1 = Short(tables->sindex, state1);
        n2 = n1 + ERRCODE;
        if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
            Short(tables->check, n2) == ERRCODE) {
          if (caml_parser_trace)
#ifdef _KERNEL
            printf("Recovering in state %d\n", state1);
#else
            fprintf(stderr, "Recovering in state %d\n", state1);
#endif
          goto shift_recover;
        } else {
          if (caml_parser_trace){
#ifdef _KERNEL
            printf("Discarding state %d\n", state1);
#else
            fprintf(stderr, "Discarding state %d\n", state1);
#endif
          }
          if (sp <= Int_val(env->stackbase)) {
            if (caml_parser_trace){
#ifdef _KERNEL
              printf("No more states to discard\n");
#else
              fprintf(stderr, "No more states to discard\n");
#endif
            }
            return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
          }
          sp--;
        }
      }
    } else {
      if (Int_val(env->curr_char) == 0)
        return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
#ifdef _KERNEL
      if (caml_parser_trace) printf("Discarding last token read\n");
#else
      if (caml_parser_trace) fprintf(stderr, "Discarding last token read\n");
#endif
      env->curr_char = Val_int(-1);
      goto loop;
    }

  shift:
    env->curr_char = Val_int(-1);
    if (errflag > 0) errflag--;
  shift_recover:
    if (caml_parser_trace)
#ifdef _KERNEL
      printf("State %d: shift to state %d\n",
              state, Short(tables->table, n2));
#else
      fprintf(stderr, "State %d: shift to state %d\n",
              state, Short(tables->table, n2));
#endif
    state = Short(tables->table, n2);
    sp++;
    if (sp < Long_val(env->stacksize)) goto push;
    SAVE;
    return GROW_STACKS_1;
                                 /* The ML code resizes the stacks */
  case STACKS_GROWN_1:
    RESTORE;
  push:
    Field(env->s_stack, sp) = Val_int(state);
    caml_modify(&Field(env->v_stack, sp), env->lval);
    Store_field (env->symb_start_stack, sp, env->symb_start);
    Store_field (env->symb_end_stack, sp, env->symb_end);
    goto loop;

  reduce:
    if (caml_parser_trace)
#ifdef _KERNEL
      printf("State %d: reduce by rule %d\n", state, n);
#else
      fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
#endif
    m = Short(tables->len, n);
    env->asp = Val_int(sp);
    env->rule_number = Val_int(n);
    env->rule_len = Val_int(m);
    sp = sp - m + 1;
    m = Short(tables->lhs, n);
    state1 = Int_val(Field(env->s_stack, sp - 1));
    n1 = Short(tables->gindex, m);
    n2 = n1 + state1;
    if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
        Short(tables->check, n2) == state1) {
      state = Short(tables->table, n2);
    } else {
      state = Short(tables->dgoto, m);
    }
    if (sp < Long_val(env->stacksize)) goto semantic_action;
    SAVE;
    return GROW_STACKS_2;
                                /* The ML code resizes the stacks */
  case STACKS_GROWN_2:
    RESTORE;
  semantic_action:
    SAVE;
    return COMPUTE_SEMANTIC_ACTION;
                                /* The ML code calls the semantic action */
  case SEMANTIC_ACTION_COMPUTED:
    RESTORE;
    Field(env->s_stack, sp) = Val_int(state);
    caml_modify(&Field(env->v_stack, sp), arg);
    asp = Int_val(env->asp);
    Store_field (env->symb_end_stack, sp, Field(env->symb_end_stack, asp));
    if (sp > asp) {
      /* This is an epsilon production. Take symb_start equal to symb_end. */
      Store_field (env->symb_start_stack, sp, Field(env->symb_end_stack, asp));
    }
    goto loop;

  default:                      /* Should not happen */
    Assert(0);
    return RAISE_PARSE_ERROR;   /* Keeps gcc -Wall happy */
  }

}
Exemplo n.º 24
0
CAMLprim value
magick_loader(value input)
{
    CAMLparam1(input);
    CAMLlocal2(pixel_matrix, res);
    Image *image_bloc;
    int image_type_code;
    int components;
    GLenum format;
    ExceptionInfo exception;
    GetExceptionInfo(&exception);
    {
        if (IsMagickInstantiated() == MagickFalse) {
            InitializeMagick(getenv("PWD"));
        }

        {
            ImageInfo *image_info;
            image_info = CloneImageInfo((ImageInfo *) NULL);
            switch (Tag_val(input))
            {
                /* given a filename of an image */
                case 0:
                    (void) strcpy(image_info->filename, String_val(Field(input,0)));
                    image_bloc = ReadImage(image_info, &exception);
                    break;

                /* given the image data in a buffer */
                case 1:
                    image_bloc = BlobToImage(
                        image_info,
                        (void *)String_val(Field(input,0)),
                        caml_string_length(Field(input,0)),
                        &exception);
                    break;
            }
            DestroyImageInfo(image_info);
        }

        if (exception.severity != UndefinedException) {
            if (image_bloc != (Image *) NULL) {
                DestroyImage(image_bloc);
            }
            DestroyExceptionInfo(&exception);
            caml_failwith( exception.reason );
            /* @TODO  exception.description */
        }

        if (image_bloc == (Image *) NULL) {
            DestroyExceptionInfo(&exception);
            caml_failwith("read image failed");
        }
    }
    {
        ImageType image_type;
        image_type = GetImageType( image_bloc, &exception );

        if (exception.severity != UndefinedException)
            caml_failwith( exception.reason );

        image_type_code = Val_ImageType(image_type, &components);

        if ( image_type_code == 11 )
            caml_failwith("getting image type failed");
    }
    {
        unsigned long x, y;
        unsigned long columns, rows;

        PixelPacket pixel;

        columns = image_bloc->columns;
        rows    = image_bloc->rows;

        const PixelPacket * pixel_packet_array;

        pixel_packet_array =
                AcquireImagePixels(
                         image_bloc,
                         0, 0, columns, rows,
                         &exception );

        if (exception.severity != UndefinedException) {
            caml_failwith(exception.reason);
        }

        {
            unsigned char *image;
            long ndx;
            long dims[3];
            dims[0] = columns;
            dims[1] = rows;
            dims[2] = components;
            pixel_matrix = alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT, 3, NULL, dims);
            image = Data_bigarray_val(pixel_matrix);
            for (x=0; x < columns; ++x) {
                for (y=0; y < rows; ++y) {
                    pixel = pixel_packet_array[(columns * y) + x];

                    ndx = (columns * y * components) + (x * components);
                    switch (components) {
                        case 1:
                            image[ndx + 0] = pixel.red   / SCALE;
                            break;
                        case 2:
                            image[ndx + 0] = pixel.red   / SCALE;
                            image[ndx + 1] = ( MaxMap - pixel.opacity ) / SCALE;
                            break;
                        case 3:
                            image[ndx + 0] = pixel.red   / SCALE;
                            image[ndx + 1] = pixel.green / SCALE;
                            image[ndx + 2] = pixel.blue  / SCALE;
                            break;
                        case 4:
                            image[ndx + 0] = pixel.red   / SCALE;
                            image[ndx + 1] = pixel.green / SCALE;
                            image[ndx + 2] = pixel.blue  / SCALE;
                            image[ndx + 3] = ( MaxMap - pixel.opacity ) / SCALE;
                            break;
                    }
                }
            }
        }

        switch (components) {
            case 1: format = GL_LUMINANCE; break;
            case 2: format = GL_LUMINANCE_ALPHA; break;
            case 3: format = GL_RGB; break;
            case 4: format = GL_RGBA; break;
        }

        res = alloc_tuple(5);
        Store_field(res, 0, pixel_matrix );
        Store_field(res, 1, Val_long(columns) );
        Store_field(res, 2, Val_long(rows) );
        Store_field(res, 3, Val_internal_format(components) );
        Store_field(res, 4, Val_pixel_data_format(format) );
    }
    DestroyExceptionInfo(&exception);
    DestroyImage(image_bloc);
    CAMLreturn(res);
}
Exemplo n.º 25
0
Arquivo: hash.c Projeto: OpenXT/ocaml
static void hash_aux(value obj)
{
  unsigned char * p;
  mlsize_t i, j;
  tag_t tag;

  hash_univ_limit--;
  if (hash_univ_count < 0 || hash_univ_limit < 0) return;

 again:
  if (Is_long(obj)) {
    hash_univ_count--;
    Combine(Long_val(obj));
    return;
  }

  /* Pointers into the heap are well-structured blocks. So are atoms.
     We can inspect the block contents. */

  Assert (Is_block (obj));  
  if (Is_in_value_area(obj)) {
    tag = Tag_val(obj);
    switch (tag) {
    case String_tag:
      hash_univ_count--;
      i = caml_string_length(obj);
      for (p = &Byte_u(obj, 0); i > 0; i--, p++)
        Combine_small(*p);
      break;
    case Double_tag:
      /* For doubles, we inspect their binary representation, LSB first.
         The results are consistent among all platforms with IEEE floats. */
      hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
      for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
           i > 0;
           p--, i--)
#else
      for (p = &Byte_u(obj, 0), i = sizeof(double);
           i > 0;
           p++, i--)
#endif
        Combine_small(*p);
      break;
    case Double_array_tag:
      hash_univ_count--;
      for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
      for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
           i > 0;
           p--, i--)
#else
      for (p = &Byte_u(obj, j), i = sizeof(double);
           i > 0;
           p++, i--)
#endif
        Combine_small(*p);
      }
      break;
    case Abstract_tag:
      /* We don't know anything about the contents of the block.
         Better do nothing. */
      break;
    case Infix_tag:
      hash_aux(obj - Infix_offset_val(obj));
      break;
    case Forward_tag:
      obj = Forward_val (obj);
      goto again;
    case Object_tag:
      hash_univ_count--;
      Combine(Oid_val(obj));
      break;
    case Custom_tag:
      /* If no hashing function provided, do nothing */
      if (Custom_ops_val(obj)->hash != NULL) {
        hash_univ_count--;
        Combine(Custom_ops_val(obj)->hash(obj));
      }
      break;
    default:
      hash_univ_count--;
      Combine_small(tag);
      i = Wosize_val(obj);
      while (i != 0) {
        i--;
        hash_aux(Field(obj, i));
      }
      break;
    }
    return;
  }

  /* Otherwise, obj is a pointer outside the heap, to an object with
     a priori unknown structure. Use its physical address as hash key. */
  Combine((intnat) obj);
}
Exemplo n.º 26
0
CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
{
  CAMLparam3(vnode, vserv, vopts);
  CAMLlocal3(vres, v, e);
  mlsize_t len;
  char * node, * serv;
  struct addrinfo hints;
  struct addrinfo * res, * r;
  int retcode;

  /* Extract "node" parameter */
  len = string_length(vnode);
  if (len == 0) {
    node = NULL;
  } else {
    node = stat_alloc(len + 1);
    strcpy(node, String_val(vnode));
  }
  /* Extract "service" parameter */
  len = string_length(vserv);
  if (len == 0) {
    serv = NULL;
  } else {
    serv = stat_alloc(len + 1);
    strcpy(serv, String_val(vserv));
  }
  /* Parse options, set hints */
  memset(&hints, 0, sizeof(hints));
  hints.ai_family = PF_UNSPEC;
  for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) {
    v = Field(vopts, 0);
    if (Is_block(v))
      switch (Tag_val(v)) {
      case 0:                   /* AI_FAMILY of socket_domain */
        hints.ai_family = socket_domain_table[Int_val(Field(v, 0))];
        break;
      case 1:                   /* AI_SOCKTYPE of socket_type */
        hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))];
        break;
      case 2:                   /* AI_PROTOCOL of int */
        hints.ai_protocol = Int_val(Field(v, 0));
        break;
      }
    else
      switch (Int_val(v)) {
      case 0:                   /* AI_NUMERICHOST */
        hints.ai_flags |= AI_NUMERICHOST; break;
      case 1:                   /* AI_CANONNAME */
        hints.ai_flags |= AI_CANONNAME; break;
      case 2:                   /* AI_PASSIVE */
        hints.ai_flags |= AI_PASSIVE; break;
      }
  }
  /* Do the call */
  enter_blocking_section();
  retcode = getaddrinfo(node, serv, &hints, &res);
  leave_blocking_section();
  if (node != NULL) stat_free(node);
  if (serv != NULL) stat_free(serv);
  /* Convert result */
  vres = Val_int(0);
  if (retcode == 0) {
    for (r = res; r != NULL; r = r->ai_next) {
      e = convert_addrinfo(r);
      v = alloc_small(2, 0);
      Field(v, 0) = e;
      Field(v, 1) = vres;
      vres = v;
    }
    freeaddrinfo(res);
  }
  CAMLreturn(vres);
}
Exemplo n.º 27
0
void caml_oldify_one (value v, value *p)
{
  value result;
  header_t hd;
  mlsize_t sz, i;
  tag_t tag;

 tail_call:
  if (Is_block (v) && Is_young (v)){
    if (Hp_val(v) < caml_young_ptr)
      printf("%lx, %lx\n", Hp_val(v), caml_young_ptr);
    Assert (Hp_val (v) >= caml_young_ptr);
    hd = Hd_val (v);
    if (hd == 0){         /* If already forwarded */
      *p = Field (v, 0);  /*  then forward pointer is first field. */
    }else{
      tag = Tag_hd (hd);
      if (tag < Infix_tag){
        value field0;

        sz = Wosize_hd (hd);
        result = caml_alloc_shr (sz, tag);
        *p = result;
        field0 = Field (v, 0);
        Hd_val (v) = 0;            /* Set forward flag */
        Field (v, 0) = result;     /*  and forward pointer. */
        if (sz > 1){
          Field (result, 0) = field0;
          Field (result, 1) = oldify_todo_list;    /* Add this block */
          oldify_todo_list = v;                    /*  to the "to do" list. */
        }else{
          Assert (sz == 1);
          p = &Field (result, 0);
          v = field0;
          goto tail_call;
        }
      }else if (tag >= No_scan_tag){
        sz = Wosize_hd (hd);
        result = caml_alloc_shr (sz, tag);
        for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
        Hd_val (v) = 0;            /* Set forward flag */
        Field (v, 0) = result;     /*  and forward pointer. */
        *p = result;
      }else if (tag == Infix_tag){
        mlsize_t offset = Infix_offset_hd (hd);
        caml_oldify_one (v - offset, p);   /* Cannot recurse deeper than 1. */
        *p += offset;
      }else{
        value f = Forward_val (v);
        tag_t ft = 0;
        int vv = 1;

        Assert (tag == Forward_tag);
        if (Is_block (f)){
          vv = Is_in_value_area(f);
          if (vv) {
            ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
          }
        }
        if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
          /* Do not short-circuit the pointer.  Copy as a normal block. */
          Assert (Wosize_hd (hd) == 1);
          result = caml_alloc_shr (1, Forward_tag);
          *p = result;
          Hd_val (v) = 0;             /* Set (GC) forward flag */
          Field (v, 0) = result;      /*  and forward pointer. */
          p = &Field (result, 0);
          v = f;
          goto tail_call;
        }else{
          v = f;                        /* Follow the forwarding */
          goto tail_call;               /*  then oldify. */
        }
      }
    }
  }else{
    *p = v;
  }
}
Exemplo n.º 28
0
CAMLexport mlsize_t caml_array_length(value array){
  tag_t tag = Tag_val(array);
  if (tag == Double_array_tag)
    return Wosize_val(array) / Double_wosize;
  else return Wosize_val(array);
}
Exemplo n.º 29
0
int netsys_init_value_1(struct htab *t,
			struct nqueue *q,
			char *dest,
			char *dest_end,
			value orig,  
			int enable_bigarrays, 
			int enable_customs,
			int enable_atoms,
			int simulation,
			void *target_addr,
			struct named_custom_ops *target_custom_ops,
			int color,
			intnat *start_offset,
			intnat *bytelen
			)
{
    void *orig_addr;
    void *work_addr;
    value work;
    int   work_tag;
    char *work_header;
    size_t work_bytes;
    size_t work_words;
    void *copy_addr;
    value copy;
    char *copy_header;
    header_t copy_header1;
    int   copy_tag;
    size_t copy_words;
    void *fixup_addr;
    char *dest_cur;
    char *dest_ptr;
    int code, i;
    intnat addr_delta;
    struct named_custom_ops *ops_ptr;
    void *int32_target_ops;
    void *int64_target_ops;
    void *nativeint_target_ops;
    void *bigarray_target_ops;

    copy = 0;

    dest_cur = dest;
    addr_delta = ((char *) target_addr) - dest;

    if (dest_cur >= dest_end && !simulation) return (-4);   /* out of space */

    if (!Is_block(orig)) return (-2);

    orig_addr = (void *) orig;
    code = netsys_queue_add(q, orig_addr);
    if (code != 0) return code;

    /* initialize *_target_ops */
    bigarray_target_ops = NULL;
    int32_target_ops = NULL;
    int64_target_ops = NULL;
    nativeint_target_ops = NULL;
    ops_ptr = target_custom_ops;
    while (ops_ptr != NULL) {
	if (strcmp(ops_ptr->name, "_bigarray") == 0)
	    bigarray_target_ops = ops_ptr->ops;
	else if (strcmp(ops_ptr->name, "_i") == 0)
	    int32_target_ops = ops_ptr->ops;
	else if (strcmp(ops_ptr->name, "_j") == 0)
	    int64_target_ops = ops_ptr->ops;
	else if (strcmp(ops_ptr->name, "_n") == 0)
	    nativeint_target_ops = ops_ptr->ops;
	ops_ptr = ops_ptr->next;
    };

    /* First pass: Iterate over the addresses found in q. Ignore
       addresses already seen in the past (which are in t). For
       new addresses, make a copy, and add these copies to t.
    */

    /* fprintf(stderr, "first pass, orig_addr=%lx simulation=%d addr_delta=%lx\n",
       (unsigned long) orig_addr, simulation, addr_delta);
    */

    code = netsys_queue_take(q, &work_addr);
    while (code != (-3)) {
	if (code != 0) return code;

	/* fprintf(stderr, "work_addr=%lx\n", (unsigned long) work_addr); */

	code = netsys_htab_lookup(t, work_addr, &copy_addr);
	if (code != 0) return code;

	if (copy_addr == NULL) {
	    /* The address is unknown, so copy the value */

	    /* Body of first pass */
	    work = (value) work_addr;
	    work_tag = Tag_val(work);
	    work_header = Hp_val(work);
	    
	    if (work_tag < No_scan_tag) {
		/* It is a scanned value (with subvalues) */
		
		switch(work_tag) {
		case Object_tag:
		case Closure_tag:
		case Lazy_tag:
		case Forward_tag:
		    return (-2);   /* unsupported */
		}

		work_words = Wosize_hp(work_header);
		if (work_words == 0) {
		    if (!enable_atoms) return (-2);
		    if (enable_atoms == 1) goto next;
		};
		
		/* Do the copy. */

		work_bytes = Bhsize_hp(work_header);
		copy_header = dest_cur;
		dest_cur += work_bytes;
		if (dest_cur > dest_end && !simulation) return (-4);
		
		if (simulation) 
		    copy_addr = work_addr;
		else {
		    memcpy(copy_header, work_header, work_bytes);
		    copy = Val_hp(copy_header);
		    copy_addr = (void *) copy;
		    Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
		}

		/* Add the association (work_addr -> copy_addr) to t: */

		code = netsys_htab_add(t, work_addr, copy_addr);
		if (code < 0) return code;

		/* Add the sub values of work_addr to q: */

		for (i=0; i < work_words; ++i) {
		    value field = Field(work, i);
		    if (Is_block (field)) {
			code = netsys_queue_add(q, (void *) field);
			if (code != 0) return code;
		    }
		}
	    }
	    else {
		/* It an opaque value */
		int do_copy = 0;
		int do_bigarray = 0;
		void *target_ops = NULL;
		char caml_id = ' ';  /* only b, i, j, n */
		/* Check for bigarrays and other custom blocks */
		switch (work_tag) {
		case Abstract_tag:
		    return(-2);
		case String_tag:
		    do_copy = 1; break;
		case Double_tag:
		    do_copy = 1; break;
		case Double_array_tag:
		    do_copy = 1; break;
		case Custom_tag: 
		    {
			struct custom_operations *custom_ops;
			char *id;

			custom_ops = Custom_ops_val(work);
			id = custom_ops->identifier;
			if (id[0] == '_') {
			    switch (id[1]) {
			    case 'b':
				if (!enable_bigarrays) return (-2);
				if (strcmp(id, "_bigarray") == 0) {
				    caml_id = 'b';
				    break;
				}
			    case 'i': /* int32 */
			    case 'j': /* int64 */
			    case 'n': /* nativeint */
				if (!enable_customs) return (-2);
				if (id[2] == 0) {
				    caml_id = id[1];
				    break;
				}
			    default:
				return (-2);
			    }
			}
			else
			    return (-2);
		    }
		}; /* switch */

		switch (caml_id) {  /* look closer at some cases */
		case 'b': {
		    target_ops = bigarray_target_ops;
		    do_copy = 1;
		    do_bigarray = 1;
		    break;
		}
		case 'i':
		    target_ops = int32_target_ops; do_copy = 1; break;
		case 'j':
		    target_ops = int64_target_ops; do_copy = 1; break;
		case 'n':
		    target_ops = nativeint_target_ops; do_copy = 1; break;
		};

		if (do_copy) {  
		    /* Copy the value */
		    work_bytes = Bhsize_hp(work_header);
		    copy_header = dest_cur;
		    dest_cur += work_bytes;

		    if (simulation)
			copy_addr = work_addr;
		    else {
			if (dest_cur > dest_end) return (-4);
			memcpy(copy_header, work_header, work_bytes);
			copy = Val_hp(copy_header);
			copy_addr = (void *) copy;
			Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
			if (target_ops != NULL)
			    Custom_ops_val(copy) = target_ops;
		    }
		    
		    code = netsys_htab_add(t, work_addr, copy_addr);
		    if (code < 0) return code;
		}

		if (do_bigarray) {
		    /* postprocessing for copying bigarrays */
		    struct caml_ba_array *b_work, *b_copy;
		    void * data_copy;
		    char * data_header;
		    header_t data_header1;
		    size_t size = 1;
		    size_t size_aligned;
		    size_t size_words;
		    b_work = Bigarray_val(work);
		    b_copy = Bigarray_val(copy);
		    for (i = 0; i < b_work->num_dims; i++) {
			size = size * b_work->dim[i];
		    };
		    size = 
			size * 
			caml_ba_element_size[b_work->flags & BIGARRAY_KIND_MASK];

		    size_aligned = size;
		    if (size%sizeof(void *) != 0)
			size_aligned += sizeof(void *) - (size%sizeof(void *));
		    size_words = Wsize_bsize(size_aligned);

		    /* If we put the copy of the bigarray into our own
		       dest buffer, also generate an abstract header,
		       so it can be skipped when iterating over it.

		       We use here a special representation, so we can
		       encode any length in this header (with a normal
		       Ocaml header we are limited by Max_wosize, e.g.
		       16M on 32 bit systems). The special representation
		       is an Abstract_tag with zero length, followed
		       by the real length (in words)
		    */
		    
		    if (enable_bigarrays == 2) {
			data_header = dest_cur;
			dest_cur += 2*sizeof(void *);
			data_copy = dest_cur;
			dest_cur += size_aligned;
		    } else if (!simulation) {
			data_header = NULL;
			data_copy = stat_alloc(size_aligned);
		    };

		    if (!simulation) {
			if (dest_cur > dest_end) return (-4);

			/* Initialize header: */
			
			if (data_header != NULL) {
			    data_header1 = Abstract_tag;
			    memcpy(data_header, 
				   (char *) &data_header1,
				   sizeof(header_t));
			    memcpy(data_header + sizeof(header_t),
				   (size_t *) &size_words,
				   sizeof(size_t));
			};

			/* Copy bigarray: */
			
			memcpy(data_copy, b_work->data, size);
			b_copy->data = data_copy;
			b_copy->proxy = NULL;

			/* If the copy is in our own buffer, it is
			   now externally managed.
			*/
			b_copy->flags = 
			    (b_copy->flags & ~CAML_BA_MANAGED_MASK) |
			    (enable_bigarrays == 2 ? 
			     CAML_BA_EXTERNAL :
			     CAML_BA_MANAGED);
		    }
		}

	    } /* if (work_tag < No_scan_tag) */
	} /* if (copy_addr == NULL) */

	/* Switch to next address in q: */
    next:
	code = netsys_queue_take(q, &work_addr);
    } /* while */
    
    /* Second pass. The copied blocks still have fields pointing to the
       original blocks. We fix that now by iterating once over the copied
       memory block.
    */

    if (!simulation) {
	/* fprintf(stderr, "second pass\n"); */
	dest_ptr = dest;
	while (dest_ptr < dest_cur) {
	    copy_header1 = *((header_t *) dest_ptr);
	    copy_tag = Tag_hd(copy_header1);
	    copy_words = Wosize_hd(copy_header1);
	    copy = (value) (dest_ptr + sizeof(void *));
	    
	    if (copy_tag < No_scan_tag) {
		for (i=0; i < copy_words; ++i) {
		    value field = Field(copy, i);
		    if (Is_block (field)) {
			/* It is a pointer. Try to fix it up. */
			code = netsys_htab_lookup(t, (void *) field,
						  &fixup_addr);
			if (code != 0) return code;

			if (fixup_addr != NULL)
			    Field(copy,i) = 
				(value) (((char *) fixup_addr) + addr_delta);
		    }
		}
	    }
	    else if (copy_tag == Abstract_tag && copy_words == 0) {
		/* our special representation for skipping data regions */
		copy_words = ((size_t *) dest_ptr)[1] + 1;
	    };
	    
	    dest_ptr += (copy_words + 1) * sizeof(void *);
	}
    }	

    /* hey, fine. Return result */
    *start_offset = sizeof(void *);
    *bytelen = dest_cur - dest;

    /* fprintf(stderr, "return regularly\n");*/

    return 0;
}
Exemplo n.º 30
0
CAMLexport int caml_is_double_array(value array){
  return (Tag_val(array) == Double_array_tag);
}