/* numbers-c.h */ #include #define FIX 0 #define FLO 1 #define BIG 2 #define RAT 3 #define COMP 4 #define NONE 5 #define BIG_TAG 0 #define RAT_TAG 1 #define COMP_TAG 2 #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 convenience so you won't forget a fixnum may need 2 digits! */ #define C_SIZEOF_FIX_BIGNUM C_SIZEOF_BIGNUM(2) /* CHAR_BIT is from , and it equals the number of bits in a char */ #define C_bytestobits(n) ((n) * CHAR_BIT) #ifdef C_SIXTY_FOUR # define C_BIGNUM_DIGIT_LENGTH 62 # define C_BIGNUM_HEADER_SIGN_BIT 0x4000000000000000L # define C_BIGNUM_HEADER_SIZE_MASK 0x3fffffffffffffffL # define C_BIGNUM_DIGIT_MASK 0x3fffffffffffffffL # define C_BIGNUM_HALF_DIGIT_MASK 0x000000007fffffffL # define C_BIGNUM_HALF_DIGIT_LENGTH 31 #else # define C_BIGNUM_DIGIT_LENGTH 30 # define C_BIGNUM_HEADER_SIGN_BIT 0x40000000 # define C_BIGNUM_HEADER_SIZE_MASK 0x3fffffff # define C_BIGNUM_DIGIT_MASK 0x3fffffff # define C_BIGNUM_HALF_DIGIT_MASK 0x00007fff # define C_BIGNUM_HALF_DIGIT_LENGTH 15 #endif #define C_BIGNUM_BITS_TO_DIGITS(n) \ (((n) + (C_BIGNUM_DIGIT_LENGTH - 1)) / C_BIGNUM_DIGIT_LENGTH) #define C_BIGNUM_DIGIT_LO_HALF(d) ((d) & C_BIGNUM_HALF_DIGIT_MASK) #define C_BIGNUM_DIGIT_HI_HALF(d) ((d) >> C_BIGNUM_HALF_DIGIT_LENGTH) #define C_BIGNUM_DIGIT_COMBINE(h,l) ((h) << C_BIGNUM_HALF_DIGIT_LENGTH|(l)) /* 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_fitsinbignumdigitp(n) ((C_uword)(n) == ((C_uword)(n) & C_BIGNUM_DIGIT_MASK)) #define C_fitsinbignumhalfdigitp(n) ((C_uword)(n) == ((C_uword)(n) & C_BIGNUM_HALF_DIGIT_MASK)) /* Only one bignum fits a fixnum when negated: (-C_MOST_NEGATIVE_FIXNUM) */ #define C_bignum_negated_fitsinfixnump(b) (C_bignum_size(b) == 2 && !C_bignum_negativep(b) && C_bignum_digits(b)[0] == 0 && C_bignum_digits(b)[1] == 1) #define C_bignum_header(b) (*(C_word *)C_data_pointer(C_internal_bignum(b))) #define C_bignum_digits(b) (((C_word *)C_data_pointer(C_internal_bignum(b)))+1) #define C_bignum_negativep(b) ((C_bignum_header(b) & C_BIGNUM_HEADER_SIGN_BIT) != 0) #define C_u_i_bignum_negativep(b) C_mk_bool(C_bignum_negativep(b)) #define C_u_i_bignum_oddp(b) C_mk_bool(C_bignum_digits(b)[0] & 1) #define C_u_i_bignum_evenp(b) C_mk_nbool(C_bignum_digits(b)[0] & 1) #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_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_u_i_bignum_signum(x) (C_bignum_negativep(x) ? C_fix(-1) : C_fix(1)) #define C_a_u_i_big_to_flo(p, n, b) C_flonum(p, C_bignum_to_double(b)) #define C_u_i_2_bignum_equalp(x, y) C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(0)) #define C_u_i_2_bignum_lessp(x, y) C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(-1)) #define C_u_i_2_bignum_greaterp(x, y) C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(1)) #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))) /* TODO: Maybe use C99's isfinite()? */ #define C_u_i_flonum_finitep(x) C_mk_nbool(C_isinf(C_flonum_magnitude(x)) || C_isnan(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) char *__strloc_tmp; /* Only use this for locations! (or at least, known short strings) */ #define C_strloc(l) (__strloc_tmp = (char *)C_alloc(C_header_size(C_block_item(l, 1))+1), C_memcpy(__strloc_tmp, C_c_string(C_block_item(l, 1)), C_header_size(C_block_item(l, 1))), __strloc_tmp[C_header_size(C_block_item(l, 1))] = '\0', __strloc_tmp) void C_not_an_integer_error(char *loc, C_word x) C_noret; /* TODO: Maybe get rid of all the _bignum_ versions? It's very rare * to know enough type info that you have a bignum anyway. * 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); C_regparm double C_bignum_to_double(C_word bignum); 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); void C_ccall C_2_basic_gcd(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y) C_noret; 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_u_2_bignum_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_u_2_bignum_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_u_bignum_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_u_bignum_negate(C_word c, C_word self, C_word k, C_word x) C_noret; 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_u_2_bignum_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_u_2_bignum_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 loc, 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 loc, C_word x, C_word y) C_noret; void C_ccall C_u_bignum_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 loc, 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 loc, C_word x, C_word y) C_noret; void C_ccall C_u_bignum_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 loc, 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 loc, C_word x, C_word y) C_noret; void C_ccall C_u_bignum_divrem(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret; void C_ccall C_2_basic_equalp(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret; C_word C_ccall C_u_i_2_integer_equalp(C_word x, C_word y); void C_ccall C_2_basic_lessp(C_word c, C_word self, C_word k, C_word loc, 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_2_basic_greaterp(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y); C_word C_ccall C_u_i_2_integer_greaterp(C_word x, C_word y); C_word C_u_i_bignum_cmp(C_word x, C_word y); void C_ccall C_u_bignum_abs(C_word c, C_word self, C_word k, C_word big) C_noret; /** 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_ccall C_u_i_integer_randomize(C_word seed); C_word C_ccall C_u_i_bignum_randomize(C_word bignum); 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_u_bignum_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_bignum_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 loc, C_word x) C_noret; C_word C_ccall C_u_i_integer_length(C_word x); C_word C_ccall C_u_i_bignum_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; void C_ccall C_u_2_bignum_bitwise_op(C_word c, C_word self, C_word k, C_word op, C_word x, C_word y) C_noret; C_inline C_word C_i_basic_numberp(C_word x) { return C_mk_bool((x & C_FIXNUM_BIT) || (!C_immediatep(x) && (C_block_header(x) == C_FLONUM_TAG || C_IS_BIGNUM_TYPE(x)))); } C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1) { C_word *p = *ptr, p0 = (C_word)p; /* TODO: Rewrite to fit into the bit representation, get rid of * structure wrapper and tag vector. Also, remove the unnecessary * extra length slot if possible... */ 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 ? C_BIGNUM_HEADER_SIGN_BIT | 1 : 1; *(p++) = d1; *ptr = p; /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */ /* TODO: Those exist and are called C_a_i_recordN */ return C_structure(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_vector2, to make it easier to rewrite later */ *(p++) = C_STRING_TYPE | C_wordstobytes(3); *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 2 : 2; *(p++) = d1; *(p++) = d2; *ptr = p; /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */ return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0); } C_inline C_word C_bignum3(C_word **ptr, int negp, C_uword d1, C_uword d2, C_word d3) { 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(4); *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 3 : 3; *(p++) = d1; *(p++) = d2; *(p++) = d3; *ptr = p; /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */ return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0); } C_inline C_word C_bignum4(C_word **ptr, int negp, C_uword d1, C_uword d2, C_word d3, C_word d4) { 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(5); *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 4 : 4; *(p++) = d1; *(p++) = d2; *(p++) = d3; *(p++) = d4; *ptr = p; /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */ return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0); } C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x) { x = C_unfix(x); if (x == C_MOST_NEGATIVE_FIXNUM) return C_bignum2(ptr, 1, 0, 1); else if (x < 0) return C_bignum1(ptr, 1, -x); 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_loc(C_word **ptr, int c, C_word loc, C_word x, C_word y) { if (y == C_fix(0)) { C_div_by_zero_error(C_strloc(loc)); } else if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(-1)) { return C_bignum2(ptr, 0, 0, 1); /* Yet another annoying special case */ } else { return C_u_fixnum_divide(x, y); /* Inconsistent, too: missing _i_ */ } } C_inline C_word C_u_i_fixnum_remainder_checked_loc(C_word loc, C_word x, C_word y) { if (y == C_fix(0)) { C_div_by_zero_error(C_strloc( loc)); } else { x = C_unfix(x); y = C_unfix(y); return C_fix(x - ((x / y) * y)); } } /* 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_quotient_checked_loc(C_word **ptr, int c, C_word loc, C_word x, C_word y) { double dy = C_flonum_magnitude(y), r; if(dy == 0.0) { C_div_by_zero_error(C_strloc(loc)); } else if (!C_truep(C_u_i_fpintegerp(x))) { C_not_an_integer_error(C_strloc(loc), x); } else if (!C_truep(C_u_i_fpintegerp(y))) { C_not_an_integer_error(C_strloc(loc), y); } else { modf(C_flonum_magnitude(x) / dy, &r); return C_flonum(ptr, r); } } C_inline C_word C_a_i_flonum_remainder_checked_loc(C_word **ptr, int c, C_word loc, C_word x, C_word y) { double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), r; if(dy == 0.0) { C_div_by_zero_error(C_strloc(loc)); } else if (!C_truep(C_u_i_fpintegerp(x))) { C_not_an_integer_error(C_strloc(loc), x); } else if (!C_truep(C_u_i_fpintegerp(y))) { C_not_an_integer_error(C_strloc(loc), 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 C_word 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; }