/* numbers-c.c */


#include <gmp.h>


static void *tags;
static int 
  big_alloc_count = 0,
  rat_alloc_count = 0,
  big_free_count = 0,
  rat_free_count = 0;
static gmp_randstate_t randstate;


#define MAX_LIVE               100


#define fix_to_flo(p, n, f)       C_flonum(p, C_unfix(f))
#define setbig(z, val)            C_memcpy(z, (MP_INT *)C_block_item(val, 0), sizeof(MP_INT))
#define setrat(r, val)            C_memcpy(r, (MP_RAT *)C_block_item(val, 0), sizeof(MP_RAT))
#define defbig(v, val)            mpz_t v; setbig(v, val)
#define defrat(v, val)            mpq_t v; setrat(v, val)
#define big_of(v)                 ((MP_INT *)C_block_item(v, 0))
#define rat_of(v)                 ((MP_RAT *)C_block_item(v, 0))

#define flonump(x)                C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)


static C_word
fetch_counters(C_word vec)
{
  C_set_block_item(vec, 0, C_fix(big_alloc_count));
  C_set_block_item(vec, 1, C_fix(big_free_count));
  C_set_block_item(vec, 2, C_fix(rat_alloc_count));
  C_set_block_item(vec, 3, C_fix(rat_free_count));
  return vec;
}


static C_word
init_tags(___scheme_value tagvec)
{
  tags = CHICKEN_new_gc_root();
  CHICKEN_gc_root_set(tags, tagvec);
  gmp_randinit_default(randstate);
  return C_SCHEME_UNDEFINED;
}


static C_word
big_to_flo(C_word **p, C_word n, C_word big)
{
  return C_flonum(p, mpz_get_d(big_of(big)));
}


static double
mpq_get_d_accurately(mpq_t rat)
{
  MP_INT *num = mpq_numref(rat);
  MP_INT *den = mpq_denref(rat);
  if (mpz_fits_slong_p(num) && mpz_fits_slong_p(den)) {
    return (double) (mpz_get_d(num) / mpz_get_d(den));
  } else {
    return mpq_get_d(rat);
  }
}

static C_word
rat_to_flo(C_word **p, C_word n, C_word rat)
{
  return C_flonum(p, mpq_get_d_accurately(rat_of(rat)));
}


static ___scheme_value
check_number(___scheme_value x)
{
  ___scheme_value tagvec;

  if((x & C_FIXNUM_BIT) != 0) return C_fix(FIX);
  else if(C_immediatep(x)) return C_fix(NONE);
  else if(C_header_bits(x) == C_FLONUM_TYPE) return C_fix(FLO);
  else {
    tagvec = CHICKEN_gc_root_ref(tags);
    
    if(C_header_bits(x) == C_TAGGED_POINTER_TYPE) {
      if(C_block_item(x, 1) == C_block_item(tagvec, BIG_TAG)) return C_fix(BIG);
      else if(C_block_item(x, 1) == C_block_item(tagvec, RAT_TAG)) return C_fix(RAT);
      else return C_fix(NONE);
    }
    else if(C_header_bits(x) == C_STRUCTURE_TYPE && C_block_item(x, 0) == C_block_item(tagvec, COMP_TAG)) 
      return C_fix(COMP);
  }

  return C_fix(NONE);
}


static ___scheme_value
free_bignum(___scheme_value x)
{
  MP_INT *zp = big_of(x);

  mpz_clear(zp);
  C_free(zp);
  ++big_free_count;
  return C_SCHEME_UNDEFINED;
}


static ___scheme_value
free_ratnum(___scheme_value x)
{
  MP_RAT *qp = rat_of(x);

  mpq_clear(qp);
  C_free(qp);
  ++rat_free_count;
  return C_SCHEME_UNDEFINED;
}


static void
check_finalizers(C_word k, C_word result)
{
  C_word tagvec = CHICKEN_gc_root_ref(tags);
  C_word n = C_fudge(C_fix(26));

  if((n & C_FIXNUM_BIT) != 0 && C_unfix(n) > MAX_LIVE)
    ((C_proc3)C_block_item(C_block_item(tagvec, FORCE_FINALIZERS), 0))(3, C_SCHEME_UNDEFINED, k, result);
  else C_kontinue(k, result);
}


static void
alloc_bignum_2(C_word k, mpz_t z, int tmp)
{
  MP_INT *zp;
  C_word big[ C_SIZEOF_TAGGED_POINTER ], *a = big;
  C_word bn;
  C_word tagvec;

  zp = (MP_INT *)C_malloc(sizeof(MP_INT));
  
  if(zp == NULL) {
    fprintf(stderr, "out of memory - can not allocate number");
    exit(EXIT_FAILURE);
  }

  ++big_alloc_count;
  tagvec = CHICKEN_gc_root_ref(tags);
  C_memcpy(zp, z, sizeof(MP_INT));
  bn = C_taggedmpointer(&a, C_block_item(tagvec, BIG_TAG), zp);
  C_do_register_finalizer(bn, C_block_item(tagvec, BIG_FREE));
  check_finalizers(k, bn);
}


static void
alloc_bignum(C_word k, mpz_t z, int tmp)
{
  if(mpz_cmp_si(z, C_MOST_NEGATIVE_FIXNUM) >= 0 && mpz_cmp_si(z, C_MOST_POSITIVE_FIXNUM) <= 0) {
    C_word n = C_fix(mpz_get_si(z));
    
    if(tmp) mpz_clear(z);

    C_kontinue(k, n);
  }
  else alloc_bignum_2(k, z, tmp);
}


static void
alloc_ratnum(C_word k, mpq_t q, int tmp)
{
  MP_RAT *qp;
  C_word rat[ C_SIZEOF_TAGGED_POINTER ], *a = rat;
  C_word rn;
  C_word tagvec;

  if(mpz_cmp_ui(mpq_denref(q), 1) == 0) {
    if(mpz_cmp_si(mpq_numref(q), C_MOST_NEGATIVE_FIXNUM) >= 0 && 
       mpz_cmp_si(mpq_numref(q), C_MOST_POSITIVE_FIXNUM) <= 0) {
      C_word n = C_fix(mpz_get_si(mpq_numref(q)));
    
      if(tmp) mpq_clear(q);

      C_kontinue(k, n);
    }
    else {
      mpz_t z;

      mpz_init_set(z, mpq_numref(q));

      if(tmp) mpq_clear(q);

      alloc_bignum_2(k, z, 1);
    }
  }
  else {
    qp = (MP_RAT *)C_malloc(sizeof(MP_RAT));

    if(qp == NULL) {
      fprintf(stderr, "out of memory - can not allocate number");
      exit(EXIT_FAILURE);
    }

    tagvec = CHICKEN_gc_root_ref(tags);
    ++rat_alloc_count;
    C_memcpy(qp, q, sizeof(MP_RAT));
    rn = C_taggedmpointer(&a, C_block_item(tagvec, RAT_TAG), qp);
    C_do_register_finalizer(rn, C_block_item(tagvec, RAT_FREE));
    check_finalizers(k, rn);
  }
}


static void
fix_plus_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  C_word z;
  mpz_t big;

  if((x & C_INT_SIGN_BIT) == (y & C_INT_SIGN_BIT)) {
    z = C_u_fixnum_plus(x, y);
    
    if((z & C_INT_SIGN_BIT) != (x & C_INT_SIGN_BIT)) {
      mpz_init_set_si(big, C_unfix(x));

      if((y & C_INT_SIGN_BIT) != 0) mpz_sub_ui(big, big, -C_unfix(y));
      else mpz_add_ui(big, big, C_unfix(y));

      alloc_bignum(k, big, 1);
    }

    C_kontinue(k, z);
  }

  C_kontinue(k, C_u_fixnum_plus(x, y));
}


static void
fix_plus_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2;

  mpz_init_set_si(big1, C_unfix(x));
  setbig(big2, y);
  mpz_add(big1, big1, big2);
  alloc_bignum(k, big1, 1);
}


static void
fix_times_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  C_word z;
  mpz_t big;

  mpz_init_set_si(big, C_unfix(x));
  mpz_mul_si(big, big, C_unfix(y));
  alloc_bignum(k, big, 1);
}


static void
fix_times_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big, big2;

  mpz_init(big);
  setbig(big2, y);
  mpz_mul_si(big, big2, C_unfix(x));
  alloc_bignum(k, big, 1);
}


static void
fix_minus_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2;

  mpz_init_set_si(big1, C_unfix(x));
  setbig(big2, y);
  mpz_sub(big1, big1, big2);
  alloc_bignum(k, big1, 1);
}


static void
big_minus_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2;

  mpz_init_set_si(big2, C_unfix(y));
  setbig(big1, x);
  mpz_sub(big2, big1, big2);
  alloc_bignum(k, big2, 1);
}


static void
fix_quotient_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t q;

  mpq_init(q);
  mpz_set_si(mpq_numref(q), C_unfix(x));
  mpz_set_si(mpq_denref(q), C_unfix(y));
  mpq_canonicalize(q);
  alloc_ratnum(k, q, 1);
}


static void
fix_quotient_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big2;
  mpq_t q;

  mpq_init(q);
  mpq_set_si(q, C_unfix(x), 1);
  setbig(big2, y);
  mpz_set(mpq_denref(q), big2);
  mpq_canonicalize(q);
  alloc_ratnum(k, q, 1);
}


static void
big_quotient_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2;
  mpq_t q;

  mpq_init(q);
  setbig(big1, x);
  mpq_set_z(q, big1);
  mpz_set_si(mpq_denref(q), C_unfix(y));
  mpq_canonicalize(q);
  alloc_ratnum(k, q, 1);
}


static void
fix_plus_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;

  mpq_init(rat1);
  mpq_set_si(rat1, C_unfix(x), 1);
  mpq_canonicalize(rat1);
  setrat(rat2, y);
  mpq_add(rat1, rat1, rat2);
  alloc_ratnum(k, rat1, 1);
}


static void
fix_times_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;

  mpq_init(rat1);
  mpq_set_si(rat1, C_unfix(x), 1);
  mpq_canonicalize(rat1);
  setrat(rat2, y);
  mpq_mul(rat1, rat1, rat2);
  alloc_ratnum(k, rat1, 1);
}


static void
fix_minus_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;

  mpq_init(rat1);
  mpq_set_si(rat1, C_unfix(x), 1);
  mpq_canonicalize(rat1);
  setrat(rat2, y);
  mpq_sub(rat1, rat1, rat2);
  alloc_ratnum(k, rat1, 1);
}


static void
rat_minus_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;

  mpq_init(rat1);
  mpq_set_si(rat1, C_unfix(y), 1);
  mpq_canonicalize(rat1);
  setrat(rat2, x);
  mpq_sub(rat1, rat2, rat1);
  alloc_ratnum(k, rat1, 1);
}


static void
fix_quotient_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;

  mpq_init(rat1);
  setrat(rat2, y);
  mpz_mul_si(mpq_numref(rat1), mpq_denref(rat2), C_unfix(x));
  mpz_set(mpq_denref(rat1), mpq_numref(rat2));
  mpq_canonicalize(rat1);
  alloc_ratnum(k, rat1, 1);
}


static void
rat_quotient_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;

  setrat(rat1, x);
  mpq_init(rat2);
  mpz_mul_si(mpq_denref(rat2), mpq_denref(rat1), C_unfix(y));
  mpz_set(mpq_numref(rat2), mpq_numref(rat1));
  mpq_canonicalize(rat2);
  alloc_ratnum(k, rat2, 1);
}


static void
big_plus_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2, big3;

  setbig(big1, x);
  setbig(big2, y);
  mpz_init(big3);
  mpz_add(big3, big1, big2);
  alloc_bignum(k, big3, 1);
}


static void
big_times_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2, big3;

  setbig(big1, x);
  setbig(big2, y);
  mpz_init(big3);
  mpz_mul(big3, big1, big2);
  alloc_bignum(k, big3, 1);
}


static void
big_minus_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2, big3;

  setbig(big1, x);
  setbig(big2, y);
  mpz_init(big3);
  mpz_sub(big3, big1, big2);
  alloc_bignum(k, big3, 1);
}


static void
big_quotient_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t big1, big2;
  mpq_t q;

  mpq_init(q);
  setbig(big1, x);
  setbig(big2, y);
  mpz_set(mpq_numref(q), big1);
  mpz_set(mpq_denref(q), big2);
  mpq_canonicalize(q);
  alloc_ratnum(k, q, 1);
}


static void
big_plus_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;
  mpz_t big;

  mpq_init(rat1);
  setbig(big, x);
  mpq_set_z(rat1, big); 
  mpq_canonicalize(rat1);
  setrat(rat2, y);
  mpq_add(rat1, rat1, rat2);
  alloc_ratnum(k, rat1, 1);
}


static void
big_times_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;
  mpz_t big;

  mpq_init(rat1);
  setbig(big, x);
  mpq_set_z(rat1, big); 
  setrat(rat2, y);
  mpq_mul(rat1, rat1, rat2);
  alloc_ratnum(k, rat1, 1);
}


static void
big_minus_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;
  mpz_t big;

  mpq_init(rat1);
  setbig(big, x);
  mpq_set_z(rat1, big); 
  setrat(rat2, y);
  mpq_sub(rat1, rat1, rat2);
  alloc_ratnum(k, rat1, 1);
}


static void
big_quotient_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;
  mpz_t big;

  mpq_init(rat2);
  setbig(big, x);
  setrat(rat1, y);
  mpz_mul(mpq_numref(rat2), big, mpq_denref(rat1));
  mpz_set(mpq_denref(rat2), mpq_numref(rat1));
  mpq_canonicalize(rat2);
  alloc_ratnum(k, rat2, 1);
}


static void
rat_plus_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2, rat3;

  setrat(rat1, x);
  setrat(rat2, y);
  mpq_init(rat3);
  mpq_add(rat3, rat1, rat2);
  alloc_ratnum(k, rat3, 1);
}


static void
rat_times_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2, rat3;

  setrat(rat1, x);
  setrat(rat2, y);
  mpq_init(rat3);
  mpq_mul(rat3, rat1, rat2);
  alloc_ratnum(k, rat3, 1);
}


static void
big_neg(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z2;
  defbig(z, x);

  mpz_init(z2);
  mpz_neg(z2, z);
  alloc_bignum(k, z2, 1);
}


static void
rat_neg(C_word c, C_word self, C_word k, C_word x)
{
  mpq_t q;
  defrat(r, x);

  mpq_init(q);
  mpq_neg(q, r);
  alloc_ratnum(k, q, 1);
}


static void
rat_minus_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;
  mpz_t big;

  mpq_init(rat1);
  setbig(big, y);
  mpq_set_z(rat1, big); 
  setrat(rat2, x);
  mpq_sub(rat1, rat1, rat2);
  alloc_ratnum(k, rat1, 1);
}


static void
rat_minus_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2, rat3;

  setrat(rat1, x);
  setrat(rat2, y);
  mpq_init(rat3);
  mpq_sub(rat3, rat1, rat2);
  alloc_ratnum(k, rat3, 1);
}


static void
rat_quotient_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2;
  mpz_t big;

  mpq_init(rat2);
  setbig(big, y);
  setrat(rat1, x);
  mpz_mul(mpq_denref(rat2), big, mpq_denref(rat1));
  mpz_set(mpq_numref(rat2), mpq_numref(rat1));
  mpq_canonicalize(rat2);
  alloc_ratnum(k, rat2, 1);
}


static void
rat_quotient_rat(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpq_t rat1, rat2, rat3;

  setrat(rat1, x);
  setrat(rat2, y);
  mpq_init(rat3);
  mpz_mul(mpq_numref(rat3), mpq_numref(rat1), mpq_denref(rat2));
  mpz_mul(mpq_denref(rat3), mpq_denref(rat1), mpq_numref(rat2));
  mpq_canonicalize(rat3);
  alloc_ratnum(k, rat3, 1);
}


static C_word
big_comp(C_word x, C_word y)
{
  defbig(b1, x);
  defbig(b2, y);
  return C_fix(mpz_cmp(b1, b2));
}


static C_word
rat_equalp(C_word x, C_word y)
{
  defrat(r1, x);
  defrat(r2, y);
  return C_mk_bool(mpq_equal(r1, r2));
}


static C_word
rat_comp(C_word x, C_word y)
{
  defrat(r1, x);
  defrat(r2, y);
  return C_fix(mpq_cmp(r1, r2));
}


static C_word
fix_comp_big(C_word x, C_word y)
{
  mpz_t b1;
  int c;
  defbig(b2, y);

  mpz_init_set_si(b1, C_unfix(x));
  c = mpz_cmp(b1, b2);
  mpz_clear(b1);
  return C_fix(c);
}


static C_word
fix_comp_rat(C_word x, C_word y)
{
  mpq_t b1;
  int c;
  defrat(b2, y);

  mpq_init(b1);
  mpq_set_si(b1, C_unfix(x), 1);
  c = mpq_cmp(b1, b2);
  mpq_clear(b1);
  return C_fix(c);
}


static C_word
rat_comp_big(C_word x, C_word y)
{
  defrat(q, x);
  defbig(z, y);
  mpq_t r;
  int c;

  mpq_init(r);
  mpq_set_z(r, z);
  c = mpq_cmp(q, r);
  mpq_clear(r);
  return C_fix(c);
}


static void
big_abs(C_word c, C_word self, C_word k, C_word big)
{
  mpz_t z1;
  defbig(z2, big);

  mpz_init(z1);
  mpz_abs(z1, z2);
  alloc_bignum(k, z1, 1);
}


static void 
rat_abs(C_word c, C_word self, C_word k, C_word rat)
{
  mpq_t q1;
  defrat(q2, rat);

  mpq_init(q1);
  mpq_abs(q1, q2);
  alloc_ratnum(k, q1, 1);
}


static void
rat_numerator(C_word c, C_word self, C_word k, C_word rat)
{
  mpz_t z;
  defrat(q, rat);

  mpz_init(z);
  mpz_set(z, mpq_numref(q));
  alloc_bignum(k, z, 1);
}


static void
rat_denominator(C_word c, C_word self, C_word k, C_word rat)
{
  mpz_t z;
  defrat(q, rat);

  mpz_init(z);
  mpz_set(z, mpq_denref(q));
  alloc_bignum(k, z, 1);
}


static C_word
big_oddp(C_word big)
{
  defbig(z, big);
  return C_mk_bool(mpz_odd_p(z));
}


static void
fix_div_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t z1;
  defbig(z2, y);

  mpz_init_set_si(z1, C_unfix(x));
  mpz_tdiv_q(z1, z1, z2);
  alloc_bignum(k, z1, 1);
}


static void
big_div_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t z2;
  defbig(z1, x);

  mpz_init_set_si(z2, C_unfix(y));
  mpz_tdiv_q(z2, z1, z2);
  alloc_bignum(k, z2, 1);
}


static void
big_div_big(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t z;
  defbig(z1, x);
  defbig(z2, y);

  mpz_init(z);
  mpz_tdiv_q(z, z1, z2);
  alloc_bignum(k, z, 1);
}


static void
flo_to_big(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z;

  mpz_init_set_d(z, C_flonum_magnitude(x));
  alloc_bignum_2(k, z, 1);
}


static void
flo_to_int(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z;

  mpz_init_set_d(z, C_flonum_magnitude(x));
  alloc_bignum(k, z, 1);
}


static void
flo_to_rat(C_word c, C_word self, C_word k, C_word x)
{
  mpq_t q;

  mpq_init(q);
  mpq_set_d(q, C_flonum_magnitude(x));
  mpq_canonicalize(q);
  alloc_ratnum(k, q, 1);
}


static void
rat_floor(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z;
  defrat(q, x);

  mpz_init(z);
  mpz_fdiv_q(z, mpq_numref(q), mpq_denref(q));
  alloc_bignum(k, z, 1);
}


static void
rat_ceiling(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z;
  defrat(q, x);

  mpz_init(z);
  mpz_cdiv_q(z, mpq_numref(q), mpq_denref(q));
  alloc_bignum(k, z, 1);
}


static void
rat_truncate(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z;
  defrat(q, x);

  mpz_init(z);
  mpz_tdiv_q(z, mpq_numref(q), mpq_denref(q));
  alloc_bignum(k, z, 1);
}


static void
rat_round(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z, w;
  mpq_t h;
  int cmp;
  defrat(q, x);

  mpz_init(z);

  if(mpz_cmp_ui(mpq_denref(q), 2) == 0) {
    mpz_tdiv_q(z, mpq_numref(q), mpq_denref(q));

    if(mpz_odd_p(z)) {
      if(mpz_sgn(z) < 0) mpz_sub_ui(z, z, 1);
      else mpz_add_ui(z, z, 1);
    }
  }
  else {
    /* if the remainder is >= 1/2 the denominator, round up */
    mpz_init(w);
    mpz_fdiv_qr(z, w, mpq_numref(q), mpq_denref(q));
    mpz_mul_2exp(w, w, 1);
    cmp = mpz_cmp(w, mpq_denref(q));
    if(cmp > 0 || (cmp == 0 && ! mpz_divisible_2exp_p(z, 1)))
      mpz_add_ui(z, z, 1);
    mpz_clear(w);
  }

  alloc_bignum(k, z, 1);
}


static void 
int_and_int(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t z1, z2, z3;

  if((x & C_FIXNUM_BIT) != 0) mpz_init_set_si(z1, C_unfix(x));
  else setbig(z1, x);

  if((y & C_FIXNUM_BIT) != 0) mpz_init_set_si(z2, C_unfix(y));
  else setbig(z2, y);

  mpz_init(z3);
  mpz_and(z3, z1, z2);

  if((x & C_FIXNUM_BIT) != 0) mpz_clear(z1);

  if((y & C_FIXNUM_BIT) != 0) mpz_clear(z2);

  alloc_bignum(k, z3, 1);
}


static void 
int_ior_int(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t z1, z2, z3;

  if((x & C_FIXNUM_BIT) != 0) mpz_init_set_si(z1, C_unfix(x));
  else setbig(z1, x);

  if((y & C_FIXNUM_BIT) != 0) mpz_init_set_si(z2, C_unfix(y));
  else setbig(z2, y);

  mpz_init(z3);
  mpz_ior(z3, z1, z2);

  if((x & C_FIXNUM_BIT) != 0) mpz_clear(z1);

  if((y & C_FIXNUM_BIT) != 0) mpz_clear(z2);

  alloc_bignum(k, z3, 1);
}


static void 
int_xor_int(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t z1, z2, z3;

  if((x & C_FIXNUM_BIT) != 0) mpz_init_set_si(z1, C_unfix(x));
  else setbig(z1, x);

  if((y & C_FIXNUM_BIT) != 0) mpz_init_set_si(z2, C_unfix(y));
  else setbig(z2, y);

  mpz_init(z3);
  mpz_xor(z3, z1, z2);

  if((x & C_FIXNUM_BIT) != 0) mpz_clear(z1);

  if((y & C_FIXNUM_BIT) != 0) mpz_clear(z2);

  alloc_bignum(k, z3, 1);
}


static void 
int_not(C_word c, C_word self, C_word k, C_word x)
{
  mpz_t z1, z2;

  if((x & C_FIXNUM_BIT) != 0) mpz_init_set_si(z1, C_unfix(x));
  else setbig(z1, x);

  mpz_init(z2);
  mpz_com(z2, z1);

  if((x & C_FIXNUM_BIT) != 0) mpz_clear(z1);

  alloc_bignum(k, z2, 1);
}


static void 
int_shift(C_word c, C_word self, C_word k, C_word x, C_word y)
{
  mpz_t z1, z2, z3;

  mpz_init(z3);

  if((x & C_FIXNUM_BIT) != 0) mpz_init_set_si(z1, C_unfix(x));
  else setbig(z1, x);

  if((y & C_FIXNUM_BIT) != 0) {
    int yi = C_unfix(y);

    if(yi >= 0) mpz_mul_2exp(z3, z1, yi);
    else mpz_fdiv_q_2exp(z3, z1, -yi);

    if((x & C_FIXNUM_BIT) != 0) mpz_clear(z1);

    alloc_bignum(k, z3, 1);
    return;
  }
  else setbig(z2, y);

  if(mpz_sgn(z2) < 0) mpz_fdiv_q(z3, z1, z2);
  else {
    mpz_t z4;
    
    mpz_init_set_ui(z3, 2);
    mpz_init_set_ui(z4, 1);
    mpz_powm(z3, z3, z2, z4);
    mpz_clear(z4);
    mpz_mul(z3, z1, z3);
  }

  if((x & C_FIXNUM_BIT) != 0) mpz_clear(z1);

  alloc_bignum(k, z3, 1);
}


static void
big_to_string(C_word c, C_word self, C_word k, C_word n, C_word base)
{
  mpz_t z;
  char *str;
  int len;
  C_word *buf;

  setbig(z, n);
  str = mpz_get_str(NULL, C_unfix(base), z);
  len = strlen(str);
  buf = C_alloc(C_SIZEOF_STRING(len));
  C_kontinue(k, C_string(&buf, len, str));
}


static void
rat_to_string(C_word c, C_word self, C_word k, C_word n, C_word base)
{
  mpq_t q;
  char *str;
  int len;
  C_word *buf;

  setrat(q, n);
  str = mpq_get_str(NULL, C_unfix(base), q);
  len = strlen(str);
  buf = C_alloc(C_SIZEOF_STRING(len));
  C_kontinue(k, C_string(&buf, len, str));
}


static void
string_to_big(C_word c, C_word self, C_word k, C_word n, C_word base)
{
  mpz_t z;
  char *str = C_c_string(n);

  mpz_init(z);

  if(*str == '+') ++str;
  
  if(mpz_set_str(z, str, C_unfix(base)) == 0)
    alloc_bignum(k, z, 1);

  C_kontinue(k, C_SCHEME_FALSE);
}


static void
string_to_rat(C_word c, C_word self, C_word k, C_word n, C_word base)
{
  mpq_t q;
  char *str = C_c_string(n);

  mpq_init(q);
  
  if(*str == '+') ++str;

  if(mpq_set_str(q, str, C_unfix(base)) == 0) {
    if(mpz_cmp_ui(mpq_denref(q), 0) == 0) C_kontinue(k, C_SCHEME_FALSE);
    else {
      mpq_canonicalize(q);
      alloc_ratnum(k, q, 1);
    }
  }
  else C_kontinue(k, C_SCHEME_FALSE);
}


static C_word
big_randomize(C_word n)
{
  mpz_t z;
  
  setbig(z, n);
  gmp_randseed(randstate, z);
  return C_SCHEME_UNDEFINED;
}


static C_word
fix_randomize(C_word n)
{
  mpz_t z;
  
  mpz_init_set_si(z, C_unfix(n));
  gmp_randseed(randstate, z);
  return C_SCHEME_UNDEFINED;
}


static void
fix_random(C_word c, C_word self, C_word k, C_word n)
{
  mpz_t z, r;

  mpz_init(z);
  mpz_init_set_si(r, C_unfix(n));
  mpz_urandomm(z, randstate, r);
  alloc_bignum(k, z, 1);
}


static void
big_random(C_word c, C_word self, C_word k, C_word n)
{
  mpz_t z, r;

  mpz_init(z);
  setbig(r, n);
  mpz_urandomm(z, randstate, r);
  alloc_bignum(k, z, 1);
}


static C_word
num_equalp_2(C_word x, C_word y)
{
  C_word tx, ty;
  mpz_t bx;
  mpq_t rx;

  switch(tx = check_number(x)) {
  case C_fix(NONE): 
    return C_SCHEME_FALSE;
  case C_fix(BIG):
    setbig(bx, x);
    break;
  case C_fix(RAT):
    setrat(rx, x);
    break;
  }

  ty = check_number(y);

  switch(tx) {
  case C_fix(FIX):
    switch(ty) {
    case C_fix(FIX):
      return C_mk_bool(x == y);
	
    case C_fix(FLO):
      return C_mk_bool((double)C_unfix(x) == C_flonum_magnitude(y));

    default: return C_SCHEME_FALSE;
    }

  case C_fix(FLO):
    switch(ty) {
    case C_fix(FIX):
      return C_mk_bool(C_flonum_magnitude(x) == (double)C_unfix(y));

    case C_fix(FLO):
      return C_mk_bool(C_flonum_magnitude(x) == C_flonum_magnitude(y));

    case C_fix(RAT):
      return C_mk_bool(C_flonum_magnitude(x) == mpq_get_d_accurately(rat_of(y)));

    default: return C_SCHEME_FALSE;
    }

    
  case C_fix(BIG):
    switch(ty) {
    case C_fix(FLO):
      return C_mk_bool(mpz_get_d(bx) == C_flonum_magnitude(y));

    case C_fix(BIG):
      { defbig(by, y);
      return C_mk_bool(mpz_cmp(bx, by) == 0); }

    default: return C_SCHEME_FALSE;
    }

  case C_fix(RAT):
    switch(ty) {
    case C_fix(FLO):
      return C_mk_bool(mpq_get_d_accurately(rx) == C_flonum_magnitude(y));

    case C_fix(RAT):
      { defrat(ry, y);
      return C_mk_bool(mpq_equal(rx, ry)); }

    default: return C_SCHEME_FALSE;
    }

    break;

  case C_fix(COMP):
    switch(ty) {
    case C_fix(COMP):
      return C_mk_bool(num_equalp_2(C_block_item(x, 1), C_block_item(y, 1)) != C_SCHEME_FALSE &&
		       num_equalp_2(C_block_item(x, 2), C_block_item(y, 2)) != C_SCHEME_FALSE);

    default: return C_SCHEME_FALSE;
    }

  default: return C_SCHEME_FALSE;
  }
}

  
static void
num_equalp(C_word c, C_word self, C_word k, ...)
{
  C_word x, y;
  va_list va;

  if(c < 4) C_bad_min_argc_2(c, 4, self);
  
  va_start(va, k);
  x = va_arg(va, C_word);

  while(c-- > 3) {
    y = va_arg(va, C_word);

    if(num_equalp_2(x, y) == C_SCHEME_FALSE) C_kontinue(k, C_SCHEME_FALSE);
  }

  C_kontinue(k, C_SCHEME_TRUE);
}