C++ SAME_OBJ函数代码示例

static Scheme_Object *define_values_jit(Scheme_Object *data)
{
  Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya;

  if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type)
      && (SCHEME_VEC_SIZE(data) == 2))
    naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]);
  else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type)
           && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_unclosed_procedure_type)
           && (SCHEME_VEC_SIZE(data) == 2)) {
    naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_VEC_ELS(data)[1]);
    if (!SAME_OBJ(naya, SCHEME_VEC_ELS(orig)[0]))
      naya = clone_inline_variant(orig, naya);
  } else
    naya = scheme_jit_expr(orig);

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

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 int check_home(Scheme_Object *o)
{
#ifdef MZ_PRECISE_GC
  return (SCHEME_INTP(o) || GC_is_tagged(o) 
	  || SAME_OBJ(o, scheme_true) 
	  || SAME_OBJ(o, scheme_false)
	  || SAME_OBJ(o, scheme_null)
	  || SAME_OBJ(o, scheme_eof)
	  || SAME_OBJ(o, scheme_void));
#else
  /* GC_set(o) */
  return 1;
#endif
}

static Scheme_Object *make_immutable_hash_table(int argc, Scheme_Object *argv[])
{
  Scheme_Object *l = argv[0], *a;
  Scheme_Hash_Table *ht;

  if (scheme_proper_list_length(l) >= 0) {
    for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
      a = SCHEME_CAR(l);
      if (!SCHEME_PAIRP(a))
	break;
    }
  }

  if (!SCHEME_NULLP(l))
    scheme_wrong_type("make-immutable-hash-table", "list of pairs", 0, argc, argv);

  if (argc > 1) {
    if (!SAME_OBJ(equal_symbol, argv[1]))
      scheme_wrong_type("make-immutable-hash-table", "'equal", 1, argc, argv);
    ht = scheme_make_hash_table_equal();
  } else
    ht = scheme_make_hash_table(SCHEME_hash_ptr);

  for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
    a = SCHEME_CAR(l);
    scheme_hash_set(ht, SCHEME_CAR(a), SCHEME_CDR(a));
  }

  SCHEME_SET_IMMUTABLE((Scheme_Object *)ht);

  return (Scheme_Object *)ht;
}

int
scheme_proper_list_length (Scheme_Object *list)
{
  int len;
  Scheme_Object *turtle;

  len = 0;
  turtle = list;
  while (SCHEME_PAIRP(list)) {
    len++;
    list = SCHEME_CDR(list);
    if (!SCHEME_PAIRP(list))
      break;
    len++;
    list = SCHEME_CDR(list);

    if (SAME_OBJ(turtle, list))
      break;

    turtle = SCHEME_CDR(turtle);
  }

  if (SCHEME_NULLP(list))
    return len;

  return -1;
}

static Scheme_Object *jit_application(Scheme_Object *o)
{
  Scheme_Object *orig, *naya = NULL;
  Scheme_App_Rec *app, *app2;
  int i, n, size;

  app = (Scheme_App_Rec *)o;
  n = app->num_args + 1;

  for (i = 0; i < n; i++) {
    orig = app->args[i];
    naya = jit_expr(orig);
    if (!SAME_OBJ(orig, naya))
      break;
  }

  if (i >= n)
    return o;

  size = (sizeof(Scheme_App_Rec) 
	  + ((n - mzFLEX_DELTA) * sizeof(Scheme_Object *))
	  + n * sizeof(char));
  app2 = (Scheme_App_Rec *)scheme_malloc_tagged(size);
  memcpy(app2, app, size);
  app2->args[i] = naya;

  for (i++; i < n; i++) {
    orig = app2->args[i];
    naya = jit_expr(orig);
    app2->args[i] = naya;
  }
  
  return (Scheme_Object *)app2;
}

static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
{
  if (!info->pass) {
    if (!info->tail_pos) {
      if (SAME_OBJ(scheme_values_func, rator))
        /* no need to clear for app of `values' */
        return;
      if (SCHEME_PRIMP(rator)) {
        int opt;
        opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
        if (opt >= SCHEME_PRIM_OPT_IMMEDIATE)
          /* Don't need to clear stack before an immediate/folding call */
          return;
      }
      info->max_nontail = info->ip;
    } else {
      if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) {
        if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) {
          if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
            /* No point in clearing out any of the closure before the
               tail call. */
            int i;
            for (i = info->selflen; i--; ) {
              if ((info->selfstart + i) != info->tlpos)
                scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
            }
          }
        }
      }
    }
  }
}

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

    if (SCHEME_CHAPERONEP(vec))
        vec = SCHEME_CHAPERONE_VAL(vec);

    if (!SCHEME_MUTABLE_VECTORP(vec))
        scheme_wrong_contract("vector-set!", "(and/c vector? (not/c immutable?))", 0, argc, argv);

    len = SCHEME_VEC_SIZE(vec);

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

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

    if (!SAME_OBJ(vec, argv[0]))
        scheme_chaperone_vector_set(argv[0], i, argv[2]);
    else
        SCHEME_VEC_ELS(vec)[i] = argv[2];

    return scheme_void;
}

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];
}

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 *
vector_fill (int argc, Scheme_Object *argv[])
{
    int i, sz;
    Scheme_Object *v, *vec = argv[0];

    if (SCHEME_NP_CHAPERONEP(vec))
        vec = SCHEME_CHAPERONE_VAL(vec);

    if (!SCHEME_MUTABLE_VECTORP(vec))
        scheme_wrong_contract("vector-fill!", "(and/c vector? (not/c immutable?))", 0, argc, argv);

    v = argv[1];
    sz = SCHEME_VEC_SIZE(vec);
    if (SAME_OBJ(vec, argv[0])) {
        for (i = 0; i < sz; i++) {
            SCHEME_VEC_ELS(argv[0])[i] = v;
        }
    } else {
        for (i = 0; i < sz; i++) {
            scheme_chaperone_vector_set(argv[0], i, v);
        }
    }

    return scheme_void;
}

Scheme_Object *scheme_complex_sqrt(const Scheme_Object *o)
{
    Scheme_Complex *c = (Scheme_Complex *)o;
    Scheme_Object *r, *i, *ssq, *srssq, *nrsq, *prsq, *nr, *ni;

    r = c->r;
    i = c->i;

    if (scheme_is_zero(i)) {
        /* Special case for x+0.0i: */
        r = scheme_sqrt(1, &r);
        if (!SCHEME_COMPLEXP(r))
            return scheme_make_complex(r, i);
        else {
            c = (Scheme_Complex *)r;
            if (SAME_OBJ(c->r, zero)) {
                /* need an inexact-zero real part: */
#ifdef MZ_USE_SINGLE_FLOATS
                if (SCHEME_FLTP(c->i))
                    r = scheme_make_float(0.0);
                else
#endif
                    r = scheme_make_double(0.0);
                return scheme_make_complex(r, c->i);
            } else
                return r;
        }
    }

    ssq = scheme_bin_plus(scheme_bin_mult(r, r),
                          scheme_bin_mult(i, i));

    srssq = scheme_sqrt(1, &ssq);

    if (SCHEME_FLOATP(srssq)) {
        /* We may have lost too much precision, if i << r.  The result is
           going to be inexact, anyway, so switch to using expt. */
        Scheme_Object *a[2];
        a[0] = (Scheme_Object *)o;
        a[1] = scheme_make_double(0.5);
        return scheme_expt(2, a);
    }

    nrsq = scheme_bin_div(scheme_bin_minus(srssq, r),
                          scheme_make_integer(2));

    nr = scheme_sqrt(1, &nrsq);
    if (scheme_is_negative(i))
        nr = scheme_bin_minus(zero, nr);

    prsq = scheme_bin_div(scheme_bin_plus(srssq, r),
                          scheme_make_integer(2));

    ni = scheme_sqrt(1, &prsq);

    return scheme_make_complex(ni, nr);
}

static void check_hash_table_flags(const char *name, int i, int argc, Scheme_Object **argv, int *flags)
{
  for (; i < argc; i++) {
    int j;
    if (SAME_OBJ(argv[i], weak_symbol))
      j = 0;
    else if (SAME_OBJ(argv[i], equal_symbol))
      j = 1;
    else {
      scheme_wrong_type(name, "'weak or 'equal", i, argc, argv);
      return;
    }

    if (flags[j])
      scheme_arg_mismatch(name, "redundant flag: ", argv[i]);

    flags[j] = 1;
  }
}