C++ SCHEME_INT_VAL函数代码示例

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

static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[])
{
    if (SCHEME_CHAPERONEP(argv[0]))
        return scheme_struct_ref(argv[0], SCHEME_INT_VAL(argv[1]));
    else
        return ((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])];
}

Scheme_Object *scheme_rational_add(const Scheme_Object *a, const Scheme_Object *b)
{
  Scheme_Rational *ra = (Scheme_Rational *)a;
  Scheme_Rational *rb = (Scheme_Rational *)b;
  Scheme_Object *ac, *bd, *sum, *cd;
  int no_normalize = 0;

  if (SCHEME_INTP(ra->denom) && (SCHEME_INT_VAL(ra->denom) == 1)) {
    /* Swap, to take advantage of the next optimization */
    Scheme_Rational *rx = ra;
    ra = rb;
    rb = rx;
  }
  if (SCHEME_INTP(rb->denom) && (SCHEME_INT_VAL(rb->denom) == 1)) {
    /* From Brad Lucier: */
    /*    (+ p/q n) = (make-rational (+ p (* n q)) q), no normalize */
    ac = ra->num;
    cd = ra->denom;
    no_normalize = 1;
  } else {
    ac = scheme_bin_mult(ra->num, rb->denom);
    cd = scheme_bin_mult(ra->denom, rb->denom);
  }

  bd = scheme_bin_mult(ra->denom, rb->num);
  sum = scheme_bin_plus(ac, bd);

  if (no_normalize)
    return make_rational(sum, cd, 0);
  else
    return scheme_make_rational(sum, cd);
}

static Scheme_Object *read_quote_syntax(Scheme_Object *obj)
{
  Scheme_Quote_Syntax *qs;
  Scheme_Object *a;
  int c, i, p;
  
  if (!SCHEME_PAIRP(obj)) return NULL;

  a = SCHEME_CAR(obj);
  c = SCHEME_INT_VAL(a);

  obj = SCHEME_CDR(obj);
  if (!SCHEME_PAIRP(obj)) return NULL;
  
  a = SCHEME_CAR(obj);
  i = SCHEME_INT_VAL(a);

  a = SCHEME_CDR(obj);
  p = SCHEME_INT_VAL(a);

  qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
  qs->so.type = scheme_quote_syntax_type;
  qs->depth = c;
  qs->position = i;
  qs->midpoint = p;  

  return (Scheme_Object *)qs;
}

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

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

static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[])
{
    if (SCHEME_NP_CHAPERONEP(argv[0]))
        scheme_chaperone_vector_set(argv[0], SCHEME_INT_VAL(argv[1]), argv[2]);
    else
        SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2];
    return scheme_void;
}

static Scheme_Object *unsafe_struct_set (int argc, Scheme_Object *argv[])
{
    if (SCHEME_CHAPERONEP(argv[0]))
        scheme_struct_set(argv[0], SCHEME_INT_VAL(argv[1]), argv[2]);
    else
        ((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])] = argv[2];
    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;
}

static int zpoll_wait(Scheme_Object *data)
{
  Scheme_Object **argv;
  zmq_pollitem_t *items;
  int nitems, timeout;

  argv = (Scheme_Object **)data;
  items = SCHEME_CPTR_VAL(argv[0]);
  nitems = SCHEME_INT_VAL(argv[1]);
  timeout = SCHEME_INT_VAL(argv[2]);

  return zmq_poll(items, nitems, timeout);
}

/**
 * Convert a Scheme object to a GVariant that will serve as one of
 * the parameters of a call go g_dbus_proxy_call_....  Returns NULL
 * if it is unable to do the conversion.
 */
static GVariant *
scheme_object_to_parameter (Scheme_Object *obj, gchar *type)
{
  gchar *str;           // A temporary string

  switch (type[0])
    {
      // Arrays
      case 'a':
        return scheme_object_to_array (obj, type);

      // Doubles
      case 'd':
        if (SCHEME_DBLP (obj))
          return g_variant_new ("d", SCHEME_DBL_VAL (obj));
        else if (SCHEME_FLTP (obj))
          return g_variant_new ("d", (double) SCHEME_FLT_VAL (obj));
        else if (SCHEME_INTP (obj))
          return g_variant_new ("d", (double) SCHEME_INT_VAL (obj));
        else
          return NULL;

      // 32 bit integers
      case 'i':
        if (SCHEME_INTP (obj))
          return g_variant_new ("i", (int) SCHEME_INT_VAL (obj));
        else if (SCHEME_DBLP (obj))
          return g_variant_new ("i", (int) SCHEME_DBL_VAL (obj));
        else 
          return NULL;

      // Strings
      case 's':
        str = scheme_object_to_string (obj);
        if (str == NULL)
          return NULL;
        return g_variant_new ("s", str);

      // 32 bit unsigned integers
      case 'u':
        if (SCHEME_INTP (obj))
          return g_variant_new ("u", (unsigned int) SCHEME_INT_VAL (obj));
        else
          return NULL;

      // Everything else is currently unsupported
      default:
        return NULL;
    } // switch
} // scheme_object_to_parameter

Scheme_Object *scheme_rational_normalize(const Scheme_Object *o)
{
  Scheme_Rational *r = (Scheme_Rational *)o;
  Scheme_Object *gcd, *tmpn;
  int negate = 0;

  if (r->num == scheme_exact_zero)
    return scheme_make_integer(0);

  if (SCHEME_INTP(r->denom)) {
    if (SCHEME_INT_VAL(r->denom) < 0) {
      tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->denom));
      r->denom = tmpn;
      negate = 1;
    }
  } else if (!SCHEME_BIGPOS(r->denom)) {
    tmpn = scheme_bignum_negate(r->denom);
    r->denom = tmpn;
    negate = 1;
  }

  if (negate) {
    if (SCHEME_INTP(r->num)) {
      tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->num));
      r->num = tmpn;
    } else {
      tmpn = scheme_bignum_negate(r->num);
      r->num = tmpn;
    }
  }
  
  if (r->denom == one)
    return r->num;

  gcd = scheme_bin_gcd(r->num, r->denom);

  if (gcd == one)
    return (Scheme_Object *)o;

  tmpn = scheme_bin_quotient(r->num, gcd);
  r->num = tmpn;
  tmpn = scheme_bin_quotient(r->denom, gcd);
  r->denom = tmpn;

  if (r->denom == one)
    return r->num;

  return (Scheme_Object *)r;
}

Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre)
{
  int len, i;
  Scheme_Object *loc;
  Scheme_Sequence *s;

  if (SCHEME_NULLP(clears))
    return expr;

  len = scheme_list_length(clears);

  s = scheme_malloc_sequence(len + 1);
  s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type);
  s->count = len + 1;
  s->array[pre ? len : 0] = expr;

  for (i = 0; i < len; i++) {
    loc = scheme_make_local(scheme_local_type,
                            SCHEME_INT_VAL(SCHEME_CAR(clears)),
                            SCHEME_LOCAL_CLEAR_ON_READ);
    s->array[i + (pre ? 0 : 1)] = loc;
    clears = SCHEME_CDR(clears);    
  }

  return (Scheme_Object *)s;
}

static Scheme_Object *negate_simple(Scheme_Object *v)
{
  if (SCHEME_INTP(v))
    return scheme_make_integer_value(-SCHEME_INT_VAL(v));
  else
    return scheme_bignum_negate(v);
}

static Scheme_Object *
integer_to_char (int argc, Scheme_Object *argv[])
{
  if (SCHEME_INTP(argv[0])) {
    intptr_t v;
    v = SCHEME_INT_VAL(argv[0]);
    if ((v >= 0) 
	&& (v <= 0x10FFFF)
	&& ((v < 0xD800) || (v > 0xDFFF)))
      return _scheme_make_char((int)v);
  } else if (SCHEME_BIGNUMP(argv[0])
	     && SCHEME_BIGPOS(argv[0])) {
    /* On 32-bit machines, there's still a chance... */
    intptr_t y;
    if (scheme_get_int_val(argv[0], &y)) {
      if (y <= 0x10FFFF)
	return _scheme_make_char((int)y);
    }
  }

  scheme_wrong_contract("integer->char", 
                        "(and/c (integer-in 0 #x10FFFF) (not/c (integer-in #xD800 #xDFFF)))", 
                        0, argc, argv);
  return NULL;
}