C++ SCHEME_VEC_ELS函数代码示例

static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
    Scheme_Object *vec, *ovec, *v;
    intptr_t len, i;

    vec = argv[0];
    if (SCHEME_NP_CHAPERONEP(vec))
        vec = SCHEME_CHAPERONE_VAL(vec);

    if (!SCHEME_VECTORP(vec))
        scheme_wrong_contract("vector->immutable-vector", "vector?", 0, argc, argv);

    if (SCHEME_IMMUTABLEP(vec))
        return argv[0];

    ovec = vec;
    len = SCHEME_VEC_SIZE(ovec);

    vec = scheme_make_vector(len, NULL);
    if (!SAME_OBJ(ovec, argv[0])) {
        for (i = 0; i < len; i++) {
            v = scheme_chaperone_vector_ref(argv[0], i);
            SCHEME_VEC_ELS(vec)[i] = v;
        }
    } else {
        for (i = 0; i < len; i++) {
            SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
        }
    }
    SCHEME_SET_IMMUTABLE(vec);

    return vec;
}

static Scheme_Object *define_values_jit(Scheme_Object *data)
{
  Scheme_Object *orig = SCHEME_DEFN_RHS(data), *naya;

  if (SAME_TYPE(SCHEME_TYPE(orig), scheme_lambda_type)
      && (SCHEME_DEFN_VAR_COUNT(data) == 1))
    naya = scheme_jit_closure(orig, SCHEME_DEFN_VAR_(data, 0));
  else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type)
           && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_lambda_type)
           && (SCHEME_DEFN_VAR_COUNT(data) == 1)) {
    naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_DEFN_VAR_(data, 0));
    if (!SAME_OBJ(naya, SCHEME_DEFN_RHS(orig)))
      naya = clone_inline_variant(orig, naya);
  } else
    naya = jit_expr(orig);

  if (SAME_OBJ(naya, orig))
    return data;
  else {
    orig = naya;
    naya = scheme_clone_vector(data, 0, 1);
    SCHEME_DEFN_RHS(naya) = orig;
    return naya;
  }
}

static int vector_equal(Scheme_Object *vec1, Scheme_Object *orig_vec1,
                        Scheme_Object *vec2, Scheme_Object *orig_vec2,
                        Equal_Info *eql)
{
  intptr_t i, len;
  Scheme_Object *v1, *v2;

  len = SCHEME_VEC_SIZE(vec1);
  if (len != SCHEME_VEC_SIZE(vec2))
    return 0;

  SCHEME_USE_FUEL(len);

  for (i = 0; i < len; i++) {
    if (SAME_OBJ(vec1, orig_vec1))
      v1 = SCHEME_VEC_ELS(vec1)[i];
    else
      v1 = scheme_chaperone_vector_ref(orig_vec1, i);
    if (SAME_OBJ(vec2, orig_vec2))
      v2 = SCHEME_VEC_ELS(vec2)[i];
    else
      v2 = scheme_chaperone_vector_ref(orig_vec2, i);

    if (!is_equal(v1, v2, eql))
      return 0;
  }

  return 1;
}

static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
{
  Scheme_Object *a[1], *v, *oprocs;

  a[0] = obj;
  v = _scheme_apply(SCHEME_CDR(procs), 1, a);
  
  if (SCHEME_FALSEP(v))
    return NULL;
  
  oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);  
  if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
    scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
                          "impersonator-of property procedure returned a value with a different prop:impersonator-of source",
                          "original value", 1, obj,
                          "returned value", 1, v,
                          NULL);

  procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
  oprocs = scheme_struct_type_property_ref(scheme_equal_property, v);  
  if (procs || oprocs)
    if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0], 
                                       SCHEME_VEC_ELS(procs)[0]))
      scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
                            "impersonator-of property procedure returned a value with a different prop:equal+hash source",
                            "original value", 1, obj,
                            "returned value", 1, v,
                            NULL);

  return v;
}

static Scheme_Object *
define_values_sfs(Scheme_Object *data, SFS_Info *info)
{
  Scheme_Object *e;
  scheme_sfs_start_sequence(info, 1, 0);
  e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1);
  SCHEME_VEC_ELS(data)[0] = e;
  return data;
}

static Scheme_Object *clone_inline_variant(Scheme_Object *obj, Scheme_Object *naya)
{
  Scheme_Object *naya2;
  naya2 = scheme_make_vector(3, scheme_false);
  naya2->type = scheme_inline_variant_type;
  SCHEME_VEC_ELS(naya2)[0] = naya;
  SCHEME_VEC_ELS(naya2)[1] = SCHEME_VEC_ELS(obj)[1];
  return naya2;
}

static Scheme_Object *
inline_variant_sfs(Scheme_Object *data, SFS_Info *info)
{
  Scheme_Object *e;
  scheme_sfs_start_sequence(info, 1, 0);
  e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1);
  SCHEME_VEC_ELS(data)[0] = e;
  /* we don't bother with inlinable variant, since it isn't called directly */
  return data;
}

static Scheme_Object *write_define_values(Scheme_Object *obj)
{
  Scheme_Object *e;

  obj = scheme_clone_vector(obj, 0, 0);
  e = scheme_protect_quote(SCHEME_VEC_ELS(obj)[0]);
  SCHEME_VEC_ELS(obj)[0] = e;

  return obj;
}

static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
{
  Scheme_Thread *p;
  Scheme_Object *vec, **a;
  long len, start, finish, i;

  vec = argv[0];

  if (!SCHEME_VECTORP(vec))
    scheme_wrong_type("vector->values", "vector", 0, argc, argv);

  len = SCHEME_VEC_SIZE(vec);

  if (argc > 1)
    start = scheme_extract_index("vector->values", 1, argc, argv, len + 1, 0);
  else
    start = 0;
  if (argc > 2)
    finish = scheme_extract_index("vector->values", 2, argc, argv, len + 1, 0);
  else
    finish = len;

  if (!(start <= len)) {
    bad_index("vector->values", argv[1], vec, 0);
  }
  if (!(finish >= start && finish <= len)) {
    bad_index("vector->values", argv[2], vec, start);
  }

  len = finish - start;
  if (len == 1)
    return SCHEME_VEC_ELS(vec)[start];

  p = scheme_current_thread;
  if (p->values_buffer && (p->values_buffer_size >= len))
    a = p->values_buffer;
  else {
    a = MALLOC_N(Scheme_Object *, len);
    p->values_buffer = a;
    p->values_buffer_size = len;
  }

  p->ku.multiple.array = a;
  p->ku.multiple.count = len;

  for (i = 0; i < len; i++) {
    a[i] = SCHEME_VEC_ELS(vec)[start + i];
  }

  return SCHEME_MULTIPLE_VALUES;
}

static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
{
  Scheme_Object *s1, *s2;
  intptr_t istart, ifinish;
  intptr_t ostart, ofinish;
  int slow = 0;

  s1 = argv[0];
  if (SCHEME_NP_CHAPERONEP(s1)) {
    slow = 1;
    s1 = SCHEME_CHAPERONE_VAL(s1);
  }
  if (!SCHEME_MUTABLE_VECTORP(s1))
    scheme_wrong_type("vector-copy!", "mutable vector", 0, argc, argv);

  scheme_do_get_substring_indices("vector-copy!", s1, 
                                  argc, argv, 1, 5, 
                                  &ostart, &ofinish, SCHEME_VEC_SIZE(s1));

  s2 = argv[2];
  if (SCHEME_NP_CHAPERONEP(s2)) {
    slow = 1;
    s2 = SCHEME_CHAPERONE_VAL(s2);
  }
  if (!SCHEME_VECTORP(s2))
    scheme_wrong_type("vector-copy!", "vector", 2, argc, argv);

  scheme_do_get_substring_indices("vector-copy!", s2, 
                                  argc, argv, 3, 4, 
                                  &istart, &ifinish, SCHEME_VEC_SIZE(s2));

  if ((ofinish - ostart) < (ifinish - istart)) {
    scheme_arg_mismatch("vector-copy!",
			"not enough room in target vector: ",
			argv[2]);
    return NULL;
  }

  if (slow) {
    int i, o;
    for (i = istart, o = ostart; i < ifinish; i++, o++) {
      scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i));
    }
  } else {
    memmove(SCHEME_VEC_ELS(s1) + ostart,
            SCHEME_VEC_ELS(s2) + istart,
            (ifinish - istart) * sizeof(Scheme_Object*));
  }
  
  return scheme_void;
}

static Scheme_Object *do_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info)
{
  Scheme_Object *e;

  if (!info->pass) {
    int depth;
    depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]);
    info = scheme_new_sfs_info(depth);
    e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth);
    SCHEME_VEC_ELS(data)[0] = e;
  }

  return data;
}

Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
    intptr_t i, len;
    Scheme_Object *vec;

    vec = argv[0];
    if (SCHEME_CHAPERONEP(vec))
        vec = SCHEME_CHAPERONE_VAL(vec);

    if (!SCHEME_VECTORP(vec))
        scheme_wrong_contract("vector-ref", "vector?", 0, argc, argv);

    len = SCHEME_VEC_SIZE(vec);

    i = scheme_extract_index("vector-ref", 1, argc, argv, len, 0);

    if (i >= len)
        return bad_index("vector-ref", "", argv[1], argv[0], 0);

    if (!SAME_OBJ(vec, argv[0]))
        /* chaperone */
        return scheme_chaperone_vector_ref(argv[0], i);
    else
        return (SCHEME_VEC_ELS(vec))[i];
}

Scheme_Object *
scheme_make_vector (int size, Scheme_Object *fill)
{
  Scheme_Object *vec;
  int i;

  if (size <= 0) {
    if (size) {
      vec = scheme_make_integer(size);
      scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
    } else
      return zero_length_vector;
  }

  if (size < 1024) {
    vec = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector) 
						+ (size - 1) * sizeof(Scheme_Object *));
  } else {
    vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged,
						 sizeof(Scheme_Vector) 
						 + (size - 1) * sizeof(Scheme_Object *));
  }

  vec->type = scheme_vector_type;
  SCHEME_VEC_SIZE(vec) = size;

  if (fill) {
    for (i = 0; i < size; i++) {
      SCHEME_VEC_ELS(vec)[i] = fill;
    }
  }

  return vec;
}

Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
  Scheme_Object *vec;
  intptr_t i;

  if (size < 0) {
    vec = scheme_make_integer(size);
    scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
  }

  if (size < 1024) {
    vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
  } else {
    vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, VECTOR_BYTES(size));
  }

  vec->type = scheme_vector_type;
  SCHEME_VEC_SIZE(vec) = size;

  if (fill) {
    for (i = 0; i < size; i++) {
      SCHEME_VEC_ELS(vec)[i] = fill;
    }
  }

  return vec;
}

static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[])
{
    if (SCHEME_NP_CHAPERONEP(argv[0]))
        return scheme_chaperone_vector_ref(argv[0], SCHEME_INT_VAL(argv[1]));
    else
        return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])];
}