source: project/release/4/numbers/trunk/numbers-c.h @ 31466

Last change on this file since 31466 was 31466, checked in by sjamaan, 6 years ago

numbers: Convert quotient to new style

File size: 10.6 KB
Line 
1/* numbers-c.h */
2
3#include <limits.h>
4
5#define FIX    0
6#define FLO    1
7#define BIG    2
8#define RAT    3
9#define COMP   4
10#define NONE   5
11
12#define BIG_TAG       0
13#define RAT_TAG       1
14#define COMP_TAG      2
15
16#define C_SIZEOF_STRUCTURE(n)           ((n)+1) /* missing from chicken.h */
17#define C_SIZEOF_CLOSURE(n)             ((n)+1) /* missing from chicken.h */
18/* The "internal"/"external" bignum distinction should die */
19#define C_SIZEOF_INTERNAL_BIGNUM(n)     (C_SIZEOF_VECTOR((n)+1))
20#define C_internal_bignum(b)            (C_block_item(b,1))
21
22#define C_SIZEOF_BIGNUM(n)              (C_SIZEOF_INTERNAL_BIGNUM(n)+C_SIZEOF_STRUCTURE(2))
23/* This is convenience so you won't forget a fixnum may need 2 digits! */
24#define C_SIZEOF_FIX_BIGNUM             C_SIZEOF_BIGNUM(2)
25
26/* CHAR_BIT is from <limits.h>, and it equals the number of bits in a char */
27#define C_bytestobits(n)           ((n) * CHAR_BIT)
28
29#ifdef C_SIXTY_FOUR
30# define C_BIGNUM_DIGIT_LENGTH      62
31# define C_BIGNUM_HEADER_SIGN_BIT   0x4000000000000000L
32# define C_BIGNUM_HEADER_SIZE_MASK  0x3fffffffffffffffL
33# define C_BIGNUM_DIGIT_MASK        0x3fffffffffffffffL
34# define C_BIGNUM_HALF_DIGIT_MASK   0x000000007fffffffL
35# define C_BIGNUM_HALF_DIGIT_LENGTH 31
36#else
37# define C_BIGNUM_DIGIT_LENGTH      30
38# define C_BIGNUM_HEADER_SIGN_BIT   0x40000000
39# define C_BIGNUM_HEADER_SIZE_MASK  0x3fffffff
40# define C_BIGNUM_DIGIT_MASK        0x3fffffff
41# define C_BIGNUM_HALF_DIGIT_MASK   0x00007fff
42# define C_BIGNUM_HALF_DIGIT_LENGTH 15
43#endif
44
45#define C_BIGNUM_BITS_TO_DIGITS(n) \
46        (((n) + (C_BIGNUM_DIGIT_LENGTH - 1)) / C_BIGNUM_DIGIT_LENGTH)
47
48#define C_BIGNUM_DIGIT_LO_HALF(d)       ((d) & C_BIGNUM_HALF_DIGIT_MASK)
49#define C_BIGNUM_DIGIT_HI_HALF(d)       ((d) >> C_BIGNUM_HALF_DIGIT_LENGTH)
50#define C_BIGNUM_DIGIT_COMBINE(h,l)     ((h) << C_BIGNUM_HALF_DIGIT_LENGTH|(l))
51
52/* This should be replaced by C_header_bits(x) == C_BIGNUM_TYPE in core */
53#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))
54
55#define C_fitsinbignumdigitp(n)         ((C_uword)(n) == ((C_uword)(n) & C_BIGNUM_DIGIT_MASK))
56#define C_fitsinbignumhalfdigitp(n)     ((C_uword)(n) == ((C_uword)(n) & C_BIGNUM_HALF_DIGIT_MASK))
57/* Only one bignum fits a fixnum when negated: (-C_MOST_NEGATIVE_FIXNUM) */
58#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)
59#define C_bignum_header(b)              (*(C_word *)C_data_pointer(C_internal_bignum(b)))
60#define C_bignum_digits(b)              (((C_word *)C_data_pointer(C_internal_bignum(b)))+1)
61#define C_bignum_negativep(b)           ((C_bignum_header(b) & C_BIGNUM_HEADER_SIGN_BIT) != 0)
62#define C_u_i_bignum_negativep(b)       C_mk_bool(C_bignum_negativep(b))
63#define C_u_i_bignum_oddp(b)            C_mk_bool(C_bignum_digits(b)[0] & 1)
64#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))
65/* The bytes->words conversion should be killed, but that can only be
66 * done when the representation is made part of core (otherwise the GC
67 * will trip on the vector's contents not being proper Scheme objects:
68 * it skips objects marked with C_BYTEBLOCK_BIT).  We could set
69 * SPECIALBLOCK_BIT, but that would disable the number-syntax hack.
70 * So, for now we'll live with back and forth byte<->word conversion.
71 */
72#define C_bignum_size(b)                (C_bytestowords(C_header_size(C_internal_bignum(b)))-1)
73/* Only use this for locations! (or at least, known short strings) */
74#define C_strloc(p,l)                   (C_alloc(C_header_size(l)+1), C_memcpy(p, C_c_string(l), C_header_size(l)), p[C_header_size(l)] = '\0', p)
75
76void C_ccall C_allocate_bignum(C_word c, C_word self, C_word k, C_word size, C_word negp, C_word initp);
77void C_ccall C_bignum_destructive_trim(C_word big);
78C_word C_ccall C_bignum_normalize(C_word big);
79
80C_word C_ccall C_u_i_2_fixnum_gcd(C_word x, C_word y);
81C_word C_ccall C_a_u_i_2_flonum_gcd(C_word **p, C_word n, C_word x, C_word y);
82
83void C_ccall C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
84C_regparm C_word C_fcall C_a_u_i_2_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y);
85void C_ccall C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
86void C_ccall C_u_2_bignum_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
87
88void C_ccall C_basic_abs(C_word c, C_word self, C_word k, C_word x);
89void C_ccall C_u_integer_abs(C_word c, C_word self, C_word k, C_word x);
90void C_ccall C_u_bignum_abs(C_word c, C_word self, C_word k, C_word x);
91
92void C_ccall C_basic_negate(C_word c, C_word self, C_word k, C_word x);
93void C_ccall C_u_integer_negate(C_word c, C_word self, C_word k, C_word x);
94C_regparm C_word C_fcall C_a_u_i_fixnum_negate(C_word **ptr, C_word n, C_word x);
95void C_ccall C_u_bignum_negate(C_word c, C_word self, C_word k, C_word x);
96
97void C_ccall C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y);
98C_regparm C_word C_fcall C_a_u_i_2_fixnum_minus(C_word **ptr, C_word n, C_word x, C_word y);
99void C_ccall C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y);
100void C_ccall C_u_2_bignum_minus(C_word c, C_word self, C_word k, C_word x, C_word y);
101
102void C_ccall C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y);
103C_regparm C_word C_fcall C_a_u_i_2_fixnum_times(C_word **ptr, C_word n, C_word x, C_word y);
104void C_ccall C_u_2_integer_times(C_word c, C_word self, C_word k, C_word x, C_word y);
105void C_ccall C_u_2_bignum_times(C_word c, C_word self, C_word k, C_word x, C_word y);
106
107void C_ccall C_basic_quotient(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
108void C_ccall C_u_integer_quotient(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
109void C_ccall C_u_bignum_quotient(C_word c, C_word self, C_word k, C_word x, C_word y);
110
111void C_ccall C_u_bignum_divrem_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y);
112void C_ccall C_u_bignum_divrem_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
113void C_ccall C_u_bignum_remainder_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y);
114void C_ccall C_u_bignum_remainder_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
115
116C_word C_u_i_bignum_cmp(C_word x, C_word y);
117void C_ccall C_u_bignum_abs(C_word c, C_word self, C_word k, C_word big);
118C_word C_ccall C_u_i_bignum_randomize(C_word bignum);
119void C_ccall C_u_bignum_random(C_word c, C_word self, C_word k, C_word max);
120
121void 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);
122void C_ccall C_u_bignum_to_digits(C_word c, C_word self, C_word k, C_word value, C_word radix);
123C_word C_a_u_i_big_to_flo(C_word **p, C_word n, C_word bignum);
124void C_ccall C_u_flo_to_int(C_word c, C_word self, C_word k, C_word x);
125C_word C_u_i_int_length(C_word x);
126
127void C_ccall C_u_int_shift_fix(C_word c, C_word self, C_word k, C_word x, C_word y);
128void C_ccall C_u_2_integer_bitwise_op(C_word c, C_word self, C_word k, C_word op, C_word x, C_word y);
129
130C_inline C_word C_i_bignump(C_word x)
131{
132  return C_mk_bool(!C_immediatep(x) && C_IS_BIGNUM_TYPE(x));
133}
134
135C_inline C_word C_i_basic_numberp(C_word x)
136{
137  return C_mk_bool((x & C_FIXNUM_BIT) ||
138                   (!C_immediatep(x) &&
139                    (C_block_header(x) == C_FLONUM_TAG ||
140                     C_IS_BIGNUM_TYPE(x))));
141}
142
143C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
144{
145  C_word *p = *ptr, p0 = (C_word)p;
146
147  /* TODO: Rewrite to fit into the bit representation, get rid of
148   * structure wrapper and tag vector.  Also, remove the unnecessary
149   * extra length slot if possible...
150   */
151  C_word tagvec = CHICKEN_gc_root_ref(tags);
152
153  /* Not using C_a_i_vector2, to make it easier to rewrite later */
154  *(p++) = C_STRING_TYPE | C_wordstobytes(2);
155  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 1 : 1;
156  *(p++) = d1;
157  *ptr = p;
158
159  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
160  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
161}
162
163/* Here d1, d2, ... are low to high (ie, little endian)! */
164C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
165{
166  C_word *p = *ptr, p0 = (C_word)p;
167
168  C_word tagvec = CHICKEN_gc_root_ref(tags);
169
170  /* Not using C_a_i_vector2, to make it easier to rewrite later */
171  *(p++) = C_STRING_TYPE | C_wordstobytes(3);
172  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 2 : 2;
173  *(p++) = d1;
174  *(p++) = d2;
175  *ptr = p;
176
177  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
178  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
179}
180
181C_inline C_word C_bignum3(C_word **ptr, int negp,
182                          C_uword d1, C_uword d2, C_word d3)
183{
184  C_word *p = *ptr, p0 = (C_word)p;
185
186  C_word tagvec = CHICKEN_gc_root_ref(tags);
187
188  /* Not using C_a_i_vector4, to make it easier to rewrite later */
189  *(p++) = C_STRING_TYPE | C_wordstobytes(4);
190  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 3 : 3;
191  *(p++) = d1;
192  *(p++) = d2;
193  *(p++) = d3;
194  *ptr = p;
195
196  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
197  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
198}
199
200C_inline C_word C_bignum4(C_word **ptr, int negp, C_uword d1, C_uword d2,
201                          C_word d3, C_word d4)
202{
203  C_word *p = *ptr, p0 = (C_word)p;
204
205  C_word tagvec = CHICKEN_gc_root_ref(tags);
206
207  /* Not using C_a_i_vector4, to make it easier to rewrite later */
208  *(p++) = C_STRING_TYPE | C_wordstobytes(5);
209  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 4 : 4;
210  *(p++) = d1;
211  *(p++) = d2;
212  *(p++) = d3;
213  *(p++) = d4;
214  *ptr = p;
215
216  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
217  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
218}
219
220C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
221{
222  x = C_unfix(x);
223  if (x == C_MOST_NEGATIVE_FIXNUM)
224    return C_bignum2(ptr, 1, 0, 1);
225  else if (x < 0)
226    return C_bignum1(ptr, 1, -x);
227  else
228    return C_bignum1(ptr, 0, x);
229}
230
231/* XXX: Naming convention is inconsistent!  Core has C_fixnum_divide()
232 * but also C_a_i_flonum_quotient_checked()
233 */
234C_inline C_word C_u_i_fixnum_quotient_checked_loc(C_word loc, C_word x, C_word y)
235{
236  char *a;
237  if (y == C_fix(0)) C_div_by_zero_error(C_strloc(a, loc));
238  else return C_u_fixnum_divide(x, y); /* Inconsistent, too: missing _i_ */
239}
240
241/* More weirdness: the other flonum_quotient macros and inline functions
242 * do not compute the quotient but the "plain" division!
243 */
244C_inline C_word
245C_a_i_flonum_quotient_checked_loc(C_word **ptr, int c, C_word loc, C_word x, C_word y)
246{
247  char *a; /* Can't use ptr, it may not be big enough */
248  double dy = C_flonum_magnitude(y), r;
249
250  if(dy == 0.0) {
251    C_div_by_zero_error(C_strloc(a, loc));
252  } else {
253    modf(C_flonum_magnitude(x) / dy, &r);
254    return C_flonum(ptr, r);
255  }
256}
Note: See TracBrowser for help on using the repository browser.