C++ scheme_make_integer函数代码示例

static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[])
{
  if (SCHEME_HASHTP(argv[0])) {
    Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
    return scheme_make_integer(t->count);
  } else if (SCHEME_BUCKTP(argv[0])) {
    Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
    int count = 0, weak, i;
    Scheme_Bucket **buckets, *bucket;
    const char *key;

    buckets = t->buckets;
    weak = t->weak;

    for (i = t->size; i--; ) {
      bucket = buckets[i];
      if (bucket) {
	if (weak) {
	  key = (const char *)HT_EXTRACT_WEAK(bucket->key);
	} else {
	  key = bucket->key;
	}
	if (key)
	  count++;
      }
      SCHEME_USE_FUEL(1);
    }

    return scheme_make_integer(count);
  } else {
    scheme_wrong_type("hash-table-count", "hash-table", 0, argc, argv);
    return NULL;
  }
}

static Scheme_Object *write_quote_syntax(Scheme_Object *obj)
{
  Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj;

  return cons(scheme_make_integer(qs->depth),
	      cons(scheme_make_integer(qs->position),
		   scheme_make_integer(qs->midpoint)));
}

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

Scheme_Object *scheme_complex_negate(const Scheme_Object *o)
{
  Scheme_Complex *c = (Scheme_Complex *)o;

  return make_complex(scheme_bin_minus(scheme_make_integer(0),
				       c->r), 
		      scheme_bin_minus(scheme_make_integer(0),
				       c->i),
		      0);
}

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_contract("vector-copy!", "(and/c vector? (not/c immutable?))", 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_contract("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_contract_error("vector-copy!",
                              "not enough room in target vector",
                              "target vector", 1, argv[2],
                              "starting index", 1, scheme_make_integer(ostart),
                              "element count", 1, scheme_make_integer(ofinish - ostart),
                              NULL);
        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 *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info)
{
  Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
  Scheme_Object *k, *v, *b, *vec;
  int pos, save_mnt;
  
  scheme_sfs_start_sequence(info, 3, 1);

  k = scheme_sfs_expr(wcm->key, info, -1);
  v = scheme_sfs_expr(wcm->val, info, -1);

  scheme_sfs_push(info, 1, 1);

  pos = info->stackpos;
  save_mnt = info->max_nontail;

  if (!info->pass) {
    vec = scheme_make_vector(3, NULL);
    scheme_sfs_save(info, vec);
  } else {
    vec = scheme_sfs_next_saved(info);
    if (SCHEME_VEC_SIZE(vec) != 3)
      scheme_signal_error("internal error: bad vector length");
    info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
    info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
    info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
  }
  
  b = scheme_sfs_expr(wcm->body, info, -1);
  
  wcm->key = k;
  wcm->val = v;
  wcm->body = b;

# if MAX_SFS_CLEARING
  if (!info->pass)
    info->max_nontail = info->ip;
# endif

  if (!info->pass) {
    int n;
    info->max_calls[pos] = info->max_nontail;
    n = info->max_used[pos];
    SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
    n = info->max_calls[pos];
    SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
    SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
  } else {
    info->max_nontail = save_mnt;
  }

  return o;
}

Scheme_Object *scheme_chaperone_vector_ref2(Scheme_Object *o, int i, Scheme_Object *outermost)
{
  if (!SCHEME_NP_CHAPERONEP(o)) {
    return SCHEME_VEC_ELS(o)[i];
  } else {
    Scheme_Chaperone *px = (Scheme_Chaperone *)o;
    Scheme_Object *a[4], *red, *orig;

#ifdef DO_STACK_CHECK
    {
# include "mzstkchk.h"
      return chaperone_vector_ref_overflow(o, i);
    }
#endif

    if(SCHEME_FALSEP(px->redirects)) {
      /* unsafe chaperones */
      return scheme_chaperone_vector_ref2(px->val, i, outermost);
    }

    orig = scheme_chaperone_vector_ref2(px->prev, i, outermost);

    if (SCHEME_REDIRECTS_PROP_ONLY_VECTORP(px->redirects)) {
      /* chaperone was on property accessors */
      /* or vector chaperone is property only */
      return orig;
    }
    red = SCHEME_CAR(px->redirects);

    if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR) {
      a[0] = outermost;
      a[1] = px->prev;
      a[2] = scheme_make_integer(i);
      a[3] = orig;
      o = _scheme_apply(red, 4, a);
    }
    else {
      a[0] = px->prev;
      a[1] = scheme_make_integer(i);
      a[2] = orig;
      o = _scheme_apply(red, 3, a);
    }

    if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
      if (!scheme_chaperone_of(o, orig))
        scheme_wrong_chaperoned("vector-ref", "result", orig, o);

    return o;
  }
}

Scheme_Object *scheme_complex_add1(const Scheme_Object *n)
{
  Small_Complex s;

  return scheme_complex_add(scheme_make_small_complex(scheme_make_integer(1), &s), 
			    n);
}

void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
  while (1) {
    if (!SCHEME_NP_CHAPERONEP(o)) {
      SCHEME_VEC_ELS(o)[i] = v;
      return;
    } else {
      Scheme_Chaperone *px = (Scheme_Chaperone *)o;
      Scheme_Object *a[3], *red;
      
      o = px->prev;
      a[0] = o;
      a[1] = scheme_make_integer(i);
      a[2] = v;
      red = SCHEME_CDR(px->redirects);
      v = _scheme_apply(red, 3, a);

      if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
        if (!scheme_chaperone_of(v, a[2]))
          scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                           "vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
                           v, 
                           a[2]);
    }
  }
}

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_fx_mod(int argc, Scheme_Object *argv[])
{
  int neg1, neg2;
  intptr_t v, v1, av1, v2, av2;
  if (scheme_current_thread->constant_folding) return scheme_modulo(argc, argv);

  v1 = SCHEME_INT_VAL(argv[0]);
  v2 = SCHEME_INT_VAL(argv[1]);

  av1 = (v1 < 0) ? -v1 : v1;
  av2 = (v2 < 0) ? -v2 : v2;

  v = av1 % av2;
	
  if (v) {
    neg1 = (v1 < 0);
    neg2 = (v2 < 0);
  
    if (neg1 != neg2)
      v = av2 - v;
  
    if (neg2)
      v = -v;
  }

  return scheme_make_integer(v); 
}

Scheme_Object *
scheme_sub1 (int argc, Scheme_Object *argv[])
{
  Scheme_Type t;
  Scheme_Object *o = argv[0];

  if (SCHEME_INTP(o)) {
    intptr_t v;
    v = SCHEME_INT_VAL(o);
    if (v > -(0x3FFFFFFF))
      return scheme_make_integer(SCHEME_INT_VAL(o) - 1);
    else {
      Small_Bignum b;
      return scheme_bignum_sub1(scheme_make_small_bignum(v, &b));
    }
  }
  t = _SCHEME_TYPE(o);
#ifdef MZ_USE_SINGLE_FLOATS
  if (t == scheme_float_type)
    return scheme_make_float(SCHEME_FLT_VAL(o) - 1.0f);
#endif
  if (t == scheme_double_type)
    return scheme_make_double(SCHEME_DBL_VAL(o) - 1.0);
  if (t == scheme_bignum_type)
    return scheme_bignum_sub1(o);
  if (t == scheme_rational_type)
    return scheme_rational_sub1(o);
  if (t == scheme_complex_type)
    return scheme_complex_sub1(o);
  
  NEED_NUMBER(sub1);

  ESCAPED_BEFORE_HERE;
}

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_chaperone_vector_ref(Scheme_Object *o, int i)
{
    if (!SCHEME_NP_CHAPERONEP(o)) {
        return SCHEME_VEC_ELS(o)[i];
    } else {
        Scheme_Chaperone *px = (Scheme_Chaperone *)o;
        Scheme_Object *a[3], *red, *orig;

#ifdef DO_STACK_CHECK
        {
# include "mzstkchk.h"
            return chaperone_vector_ref_overflow(o, i);
        }
#endif

        orig = scheme_chaperone_vector_ref(px->prev, i);

        if (SCHEME_VECTORP(px->redirects)) {
            /* chaperone was on property accessors */
            return orig;
        }

        a[0] = px->prev;
        a[1] = scheme_make_integer(i);
        a[2] = orig;
        red = SCHEME_CAR(px->redirects);
        o = _scheme_apply(red, 3, a);

        if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
            if (!scheme_chaperone_of(o, orig))
                scheme_wrong_chaperoned("vector-ref", "result", orig, o);

        return o;
    }
}

static Scheme_Object *unsafe_vector_star_len (int argc, Scheme_Object *argv[])
{
    Scheme_Object *vec = argv[0];
    intptr_t n;
    n = SCHEME_VEC_SIZE(vec);
    return scheme_make_integer(n);
}