/* numbers-c.h */

#define BIG_TAG       0
#define RAT_TAG       1
#define COMP_TAG      2

#ifdef C_SIXTY_FOUR
# define C_HALF_WORD_SIZE           32
# define C_hword                    int
#else
# define C_HALF_WORD_SIZE           16
# define C_hword                    short
#endif
#define C_uhword                    unsigned C_hword

#define C_SIZEOF_STRUCTURE(n)           ((n)+1) /* missing from chicken.h */
#define C_SIZEOF_CLOSURE(n)             ((n)+1) /* missing from chicken.h */
/* The "internal"/"external" bignum distinction should die */
#define C_SIZEOF_INTERNAL_BIGNUM(n)	(C_SIZEOF_VECTOR((n)+1))
#define C_internal_bignum(b)            (C_block_item(b,1))

#define C_SIZEOF_BIGNUM(n)		(C_SIZEOF_INTERNAL_BIGNUM(n)+C_SIZEOF_STRUCTURE(2))
/* This is for convenience and allows flexibility in representation */
#define C_SIZEOF_FIX_BIGNUM             C_SIZEOF_BIGNUM(1)
#define C_BIGNUM_DIGIT_LENGTH           C_WORD_SIZE
#define C_BIGNUM_HALF_DIGIT_LENGTH      C_HALF_WORD_SIZE

/* This defines when we'll switch from schoolbook to Karatsuba
 * multiplication.  The smallest of the two numbers determines the
 * switch.  It is pretty high right now because it generates a bit
 * more garbage and GC overhead dominates the algorithmic performance
 * gains.  If the GC is improved, this can be readjusted.
 */
#define C_KARATSUBA_THRESHOLD        70
/* This defines when to switch from schoolbook to Burnikel-Ziegler
 * division.  It creates even more garbage than Karatsuba :(
 */
#define C_BURNIKEL_ZIEGLER_DIFF_THRESHOLD 300
/* This threshold is in terms of the expected string length.  It
 * depends on division speed: if you change the above, change this too.
 */
#define C_RECURSIVE_TO_STRING_THRESHOLD 750

#define C_BIGNUM_BITS_TO_DIGITS(n) \
        (((n) + (C_BIGNUM_DIGIT_LENGTH - 1)) / C_BIGNUM_DIGIT_LENGTH)

#define C_BIGNUM_DIGIT_LO_HALF(d)       (C_uhword)(d)
#define C_BIGNUM_DIGIT_HI_HALF(d)       (C_uhword)((d) >> C_BIGNUM_HALF_DIGIT_LENGTH)
#define C_BIGNUM_DIGIT_COMBINE(h,l)     ((C_uword)(h) << C_BIGNUM_HALF_DIGIT_LENGTH|(C_uhword)(l))

/* Compatibility for CHICKEN < 4.9.0 */
#ifndef C_block_header_init
#define C_block_header_init(b, v)	C_block_header(b) = (v)
#endif

/* This should be replaced by C_header_bits(x) == C_BIGNUM_TYPE in core */
#define C_IS_BIGNUM_TYPE(x) (C_header_bits(x) == C_STRUCTURE_TYPE && C_block_item(CHICKEN_gc_root_ref(tags), BIG_TAG) == C_block_item(x, 0))

#define C_i_bignump(x)                  C_mk_bool(!C_immediatep(x) && C_IS_BIGNUM_TYPE(x))
#define C_fitsinbignumhalfdigitp(n)     (C_BIGNUM_DIGIT_HI_HALF(n) == 0)
#define C_bignum_negated_fitsinfixnump(b) (C_bignum_size(b) == 1 && (C_bignum_negativep(b) ? C_ufitsinfixnump(*C_bignum_digits(b)) : !(*C_bignum_digits(b) & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)*C_bignum_digits(b))))
#define C_bignum_header(b)              (*(C_word *)C_data_pointer(C_internal_bignum(b)))
#define C_bignum_digits(b)              (((C_uword *)C_data_pointer(C_internal_bignum(b)))+1)
#define C_bignum_negativep(b)           (C_bignum_header(b) != 0)
#define C_a_u_i_fixnum_abs(ptr, n, x)   (((x) & C_INT_SIGN_BIT) ? C_a_u_i_fixnum_negate((ptr), (n), (x)) : (x))
#define C_u_i_fixnum_signum(x)          ((x) == C_fix(0) ? x : (((x) & C_INT_SIGN_BIT) ? C_fix(-1) : C_fix(1)))
#define C_u_i_fixnum_negativep(x)       C_mk_bool((x) & C_INT_SIGN_BIT)
#define C_u_i_fixnum_positivep(x)       C_mk_bool(!((x) & C_INT_SIGN_BIT) && (x) != C_fix(0))
#define C_a_u_i_flonum_signum(ptr, n, x) (C_flonum_magnitude(x) == 0.0 ? x : ((C_flonum_magnitude(x) < 0.0) ? C_flonum(ptr, -1.0) : C_flonum(ptr, 1.0)))
#define C_a_u_i_big_to_flo(p, n, b)     C_flonum(p, C_bignum_to_double(b))
#define C_u_i_fixnum_length(x)          C_fix(C_ilen(((x) & C_INT_SIGN_BIT) ? ~C_unfix(x) : C_unfix(x)))
#define C_u_i_flonum_nanp(x)            C_mk_bool(C_isnan(C_flonum_magnitude(x)))
#define C_u_i_flonum_infinitep(x)       C_mk_bool(C_isinf(C_flonum_magnitude(x)))

#define C_isfinite                      isfinite
#define C_u_i_flonum_finitep(x)         C_mk_bool(C_isfinite(C_flonum_magnitude(x)))

/* The bytes->words conversion should be killed, but that can only be
 * done when the representation is made part of core (otherwise the GC
 * will trip on the vector's contents not being proper Scheme objects:
 * it skips objects marked with C_BYTEBLOCK_BIT).  We could set
 * SPECIALBLOCK_BIT, but that would disable the number-syntax hack.
 * So, for now we'll live with back and forth byte<->word conversion.
 */
#define C_bignum_size(b)                (C_bytestowords(C_header_size(C_internal_bignum(b)))-1)
#define C_bignum_mutate_size(b, s)      (C_block_header(C_internal_bignum(b)) = (C_STRING_TYPE | C_wordstobytes((s)+1)))
#define C_u_i_bignum_size(b)            C_fix(C_bignum_size(b))

void C_not_an_integer_error(char *loc, C_word x) C_noret;
void numbers_div_by_zero_error(char *loc) C_noret;

/* XXX: When moving to core, these all need "fctexport" */
void C_ccall C_allocate_bignum(C_word c, C_word self, C_word k, C_word size, C_word negp, C_word initp) C_noret;
void C_ccall C_bignum_destructive_trim(C_word big);
C_word C_ccall C_bignum_simplify(C_word big);
void C_ccall C_u_bignum_extract_digits(C_word c, C_word self, C_word k, C_word x, C_word start, C_word end) C_noret;

C_regparm double C_bignum_to_double(C_word bignum);
C_regparm C_word C_fcall C_i_numbers_numberp(C_word x);
C_regparm C_word C_fcall C_i_numbers_integerp(C_word x);
C_regparm C_word C_fcall C_i_numbers_eqvp(C_word x, C_word y);
C_regparm C_word C_fcall C_i_nanp(C_word x);
C_regparm C_word C_fcall C_i_numbers_finitep(C_word x);
C_regparm C_word C_fcall C_i_numbers_infinitep(C_word x);
C_regparm C_word C_ccall C_i_numbers_zerop(C_word x);

C_word C_ccall C_u_i_2_fixnum_gcd(C_word x, C_word y);
C_word C_ccall C_a_u_i_2_flonum_gcd(C_word **p, C_word n, C_word x, C_word y);
void C_ccall C_u_2_integer_gcd(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

void C_ccall C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
C_regparm C_word C_fcall C_a_u_i_2_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y);
void C_ccall C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

void C_ccall C_basic_abs(C_word c, C_word self, C_word k, C_word x) C_noret;
void C_ccall C_u_integer_abs(C_word c, C_word self, C_word k, C_word x) C_noret;

void C_ccall C_basic_signum(C_word c, C_word self, C_word k, C_word x) C_noret;
C_regparm C_word C_fcall C_u_i_integer_signum(C_word x);

void C_ccall C_basic_negate(C_word c, C_word self, C_word k, C_word x) C_noret;
void C_ccall C_u_integer_negate(C_word c, C_word self, C_word k, C_word x) C_noret;
C_regparm C_word C_fcall C_a_u_i_fixnum_negate(C_word **ptr, C_word n, C_word x);

void C_ccall C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
C_regparm C_word C_fcall C_a_u_i_2_fixnum_minus(C_word **ptr, C_word n, C_word x, C_word y);
void C_ccall C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

void C_ccall C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
C_regparm C_word C_fcall C_a_u_i_2_fixnum_times(C_word **ptr, C_word n, C_word x, C_word y);
void C_ccall C_u_2_integer_times(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

void C_ccall C_basic_quotient(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
void C_ccall C_u_integer_quotient(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

void C_ccall C_basic_remainder(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
void C_ccall C_u_integer_remainder(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

void C_ccall C_basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
void C_ccall C_u_integer_divrem(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

void C_ccall C_numbers_nequalp(C_word c, C_word self, C_word k, ...) C_noret;
C_regparm C_word C_fcall C_i_2_basic_equalp(C_word x, C_word y);
C_word C_ccall C_u_i_2_integer_equalp(C_word x, C_word y);
void C_ccall C_numbers_lessp(C_word c, C_word self, C_word k, ...) C_noret;
C_regparm C_word C_fcall C_i_2_basic_lessp(C_word x, C_word y);
C_word C_ccall C_u_i_2_integer_lessp(C_word x, C_word y);
void C_ccall C_numbers_less_or_equalp(C_word c, C_word self, C_word k, ...) C_noret;
C_regparm C_word C_fcall C_i_2_basic_less_or_equalp(C_word x, C_word y);
C_word C_ccall C_u_i_2_integer_or_equal_p(C_word x, C_word y);
void C_ccall C_numbers_greaterp(C_word c, C_word self, C_word k, ...) C_noret;
C_regparm C_word C_fcall C_i_2_basic_greaterp(C_word x, C_word y);
C_word C_ccall C_u_i_2_integer_greaterp(C_word x, C_word y);
void C_ccall C_numbers_greater_or_equal_p(C_word c, C_word self, C_word k, ...) C_noret;
C_regparm C_word C_fcall C_i_2_basic_greater_or_equalp(C_word x, C_word y);
C_word C_ccall C_u_i_2_integer_or_equalp(C_word x, C_word y);

C_word C_u_i_bignum_cmp(C_word x, C_word y);

/** TODO: rename to C_i_evenp/C_i_oddp, or is this fine? */
C_regparm C_word C_fcall C_i_basic_evenp(C_word x);
C_regparm C_word C_fcall C_u_i_integer_evenp(C_word x);
C_regparm C_word C_fcall C_i_basic_oddp(C_word x);
C_regparm C_word C_fcall C_u_i_integer_oddp(C_word x);
C_regparm C_word C_fcall C_i_basic_positivep(C_word x);
C_regparm C_word C_fcall C_u_i_integer_positivep(C_word x);
C_regparm C_word C_fcall C_i_basic_negativep(C_word x);
C_regparm C_word C_fcall C_u_i_integer_negativep(C_word x);

C_regparm C_word C_ccall C_u_i_integer_randomize(C_word seed);
void C_ccall C_u_integer_random(C_word c, C_word self, C_word k, C_word max) C_noret;

void C_ccall C_digits_to_integer(C_word c, C_word self, C_word k, C_word n, C_word start, C_word end, C_word radix, C_word negp) C_noret;
void C_ccall C_basic_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
void C_ccall C_u_fixnum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix) C_noret;
void C_ccall C_u_flonum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix) C_noret;
void C_ccall C_u_integer_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix) C_noret;
void C_ccall C_u_fixnum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix) C_noret;
void C_ccall C_u_flo_to_int(C_word c, C_word self, C_word k, C_word x) C_noret;
C_word C_ccall C_u_i_integer_bit_setp(C_word n, C_word i);
C_word C_ccall C_u_i_integer_length(C_word x);

void C_ccall C_u_integer_shift(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
void C_ccall C_u_2_integer_bitwise_and(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
void C_ccall C_u_2_integer_bitwise_ior(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
void C_ccall C_u_2_integer_bitwise_xor(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;

/* Silly but in some cases needed */
C_inline C_word C_bignum0(C_word **ptr)
{
  C_word *p = *ptr, p0 = (C_word)p;

  C_word tagvec = CHICKEN_gc_root_ref(tags);

  /* Not using C_a_i_vector4, to make it easier to rewrite later */
  *(p++) = C_STRING_TYPE | C_wordstobytes(1);
  *(p++) = 0; /* zero is always positive */
  *ptr = p;

  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
}

C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
{
  C_word *p = *ptr, p0 = (C_word)p;

  /* TODO: Get rid of structure wrapper and tag vector. */
  C_word tagvec = CHICKEN_gc_root_ref(tags);

  /* Not using C_a_i_vector2, to make it easier to rewrite later */
  *(p++) = C_STRING_TYPE | C_wordstobytes(2);
  *(p++) = negp;
  *(p++) = d1;
  *ptr = p;

  return C_a_i_record2(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
}

/* Here d1, d2, ... are low to high (ie, little endian)! */
C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
{
  C_word *p = *ptr, p0 = (C_word)p;

  C_word tagvec = CHICKEN_gc_root_ref(tags);

  /* Not using C_a_i_vector3, to make it easier to rewrite later */
  *(p++) = C_STRING_TYPE | C_wordstobytes(3);
  *(p++) = negp;
  *(p++) = d1;
  *(p++) = d2;
  *ptr = p;

  return C_a_i_record2(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
}

/* TODO: Is this correctly named?  Shouldn't it accept an argcount? */
C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
{
  x = C_unfix(x);
  if (x < 0)
    return C_bignum1(ptr, 1, -x);
  else if (x == 0)
    return C_bignum0(ptr);
  else
    return C_bignum1(ptr, 0, x);
}

/* XXX: Naming convention is inconsistent!  Core has C_fixnum_divide()
 * but also C_a_i_flonum_quotient_checked()
 */
C_inline C_word C_a_u_i_fixnum_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
{
  if (y == C_fix(0)) {
    numbers_div_by_zero_error("fx/");
  } else if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(-1)) {
    return C_bignum1(ptr, 0, -C_MOST_NEGATIVE_FIXNUM); /* Special case */
  } else {
    return C_u_fixnum_divide(x, y); /* Inconsistent, too: missing _i_ */
  }
}

C_inline C_word C_u_i_fixnum_remainder_checked(C_word x, C_word y)
{
  if (y == C_fix(0)) {
    numbers_div_by_zero_error("remainder");
  } else {
    x = C_unfix(x);
    y = C_unfix(y);
    return C_fix(x - ((x / y) * y));
  }
}

/* Workaround for CHICKENs < 4.9.0, which contain broken fpintegerp */
C_inline C_word C_u_i_fpintegerp_fixed(C_word x)
{
  double dummy, val;

  val = C_flonum_magnitude(x);

  if(C_isnan(val) || C_isinf(val)) return C_SCHEME_FALSE;

  return C_mk_bool(C_modf(val, &dummy) == 0.0);
}


/* More weirdness: the other flonum_quotient macros and inline functions
 * do not compute the quotient but the "plain" division!
 */
C_inline C_word
C_a_i_flonum_actual_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
{
  double dy = C_flonum_magnitude(y), r;

  if(dy == 0.0) {
    numbers_div_by_zero_error("quotient");
  } else if (!C_truep(C_u_i_fpintegerp_fixed(x))) {
    C_not_an_integer_error("quotient", x);
  } else if (!C_truep(C_u_i_fpintegerp_fixed(y))) {
    C_not_an_integer_error("quotient", y);
  } else {
    modf(C_flonum_magnitude(x) / dy, &r);
    return C_flonum(ptr, r);
  }
}

C_inline C_word
C_a_i_flonum_remainder_checked(C_word **ptr, int c, C_word x, C_word y)
{
  double dx = C_flonum_magnitude(x),
         dy = C_flonum_magnitude(y), r;

  if(dy == 0.0) {
    numbers_div_by_zero_error("remainder");
  } else if (!C_truep(C_u_i_fpintegerp_fixed(x))) {
    C_not_an_integer_error("remainder", x);
  } else if (!C_truep(C_u_i_fpintegerp_fixed(y))) {
    C_not_an_integer_error("remainder", y);
  } else {
    modf(dx / dy, &r);
    return C_flonum(ptr, dx - r * dy);
  }
}

/*
 * From Hacker's Delight by Henry S. Warren
 * based on a modified nlz() from section 5-3 (fig. 5-7)
 */
C_inline int C_ilen(C_uword x)
{
  C_uword y;
  C_word n = 0;

#ifdef C_SIXTY_FOUR
  y = x >> 32; if (y != 0) { n += 32; x = y; }
#endif
  y = x >> 16; if (y != 0) { n += 16; x = y; }
  y = x >>  8; if (y != 0) { n +=  8; x = y; }
  y = x >>  4; if (y != 0) { n +=  4; x = y; }
  y = x >>  2; if (y != 0) { n +=  2; x = y; }
  y = x >>  1; if (y != 0) return n + 2;
  return n + x;
}