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

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

numbers: Convert "remainder" to new style

File size: 11.4 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_basic_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
112void C_ccall C_u_integer_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
113void C_ccall C_u_bignum_remainder(C_word c, C_word self, C_word k, C_word x, C_word y);
114
115void C_ccall C_u_bignum_divrem_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y);
116void C_ccall C_u_bignum_divrem_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
117
118C_word C_u_i_bignum_cmp(C_word x, C_word y);
119void C_ccall C_u_bignum_abs(C_word c, C_word self, C_word k, C_word big);
120C_word C_ccall C_u_i_bignum_randomize(C_word bignum);
121void C_ccall C_u_bignum_random(C_word c, C_word self, C_word k, C_word max);
122
123void 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);
124void C_ccall C_u_bignum_to_digits(C_word c, C_word self, C_word k, C_word value, C_word radix);
125C_word C_a_u_i_big_to_flo(C_word **p, C_word n, C_word bignum);
126void C_ccall C_u_flo_to_int(C_word c, C_word self, C_word k, C_word x);
127C_word C_u_i_int_length(C_word x);
128
129void C_ccall C_u_int_shift_fix(C_word c, C_word self, C_word k, C_word x, C_word y);
130void 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);
131
132C_inline C_word C_i_bignump(C_word x)
133{
134  return C_mk_bool(!C_immediatep(x) && C_IS_BIGNUM_TYPE(x));
135}
136
137C_inline C_word C_i_basic_numberp(C_word x)
138{
139  return C_mk_bool((x & C_FIXNUM_BIT) ||
140                   (!C_immediatep(x) &&
141                    (C_block_header(x) == C_FLONUM_TAG ||
142                     C_IS_BIGNUM_TYPE(x))));
143}
144
145C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
146{
147  C_word *p = *ptr, p0 = (C_word)p;
148
149  /* TODO: Rewrite to fit into the bit representation, get rid of
150   * structure wrapper and tag vector.  Also, remove the unnecessary
151   * extra length slot if possible...
152   */
153  C_word tagvec = CHICKEN_gc_root_ref(tags);
154
155  /* Not using C_a_i_vector2, to make it easier to rewrite later */
156  *(p++) = C_STRING_TYPE | C_wordstobytes(2);
157  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 1 : 1;
158  *(p++) = d1;
159  *ptr = p;
160
161  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
162  /* TODO: Those exist and are called C_a_i_recordN */
163  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
164}
165
166/* Here d1, d2, ... are low to high (ie, little endian)! */
167C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
168{
169  C_word *p = *ptr, p0 = (C_word)p;
170
171  C_word tagvec = CHICKEN_gc_root_ref(tags);
172
173  /* Not using C_a_i_vector2, to make it easier to rewrite later */
174  *(p++) = C_STRING_TYPE | C_wordstobytes(3);
175  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 2 : 2;
176  *(p++) = d1;
177  *(p++) = d2;
178  *ptr = p;
179
180  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
181  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
182}
183
184C_inline C_word C_bignum3(C_word **ptr, int negp,
185                          C_uword d1, C_uword d2, C_word d3)
186{
187  C_word *p = *ptr, p0 = (C_word)p;
188
189  C_word tagvec = CHICKEN_gc_root_ref(tags);
190
191  /* Not using C_a_i_vector4, to make it easier to rewrite later */
192  *(p++) = C_STRING_TYPE | C_wordstobytes(4);
193  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 3 : 3;
194  *(p++) = d1;
195  *(p++) = d2;
196  *(p++) = d3;
197  *ptr = p;
198
199  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
200  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
201}
202
203C_inline C_word C_bignum4(C_word **ptr, int negp, C_uword d1, C_uword d2,
204                          C_word d3, C_word d4)
205{
206  C_word *p = *ptr, p0 = (C_word)p;
207
208  C_word tagvec = CHICKEN_gc_root_ref(tags);
209
210  /* Not using C_a_i_vector4, to make it easier to rewrite later */
211  *(p++) = C_STRING_TYPE | C_wordstobytes(5);
212  *(p++) = negp ? C_BIGNUM_HEADER_SIGN_BIT | 4 : 4;
213  *(p++) = d1;
214  *(p++) = d2;
215  *(p++) = d3;
216  *(p++) = d4;
217  *ptr = p;
218
219  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
220  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
221}
222
223C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
224{
225  x = C_unfix(x);
226  if (x == C_MOST_NEGATIVE_FIXNUM)
227    return C_bignum2(ptr, 1, 0, 1);
228  else if (x < 0)
229    return C_bignum1(ptr, 1, -x);
230  else
231    return C_bignum1(ptr, 0, x);
232}
233
234/* XXX: Naming convention is inconsistent!  Core has C_fixnum_divide()
235 * but also C_a_i_flonum_quotient_checked()
236 */
237C_inline C_word C_u_i_fixnum_quotient_checked_loc(C_word loc, C_word x, C_word y)
238{
239  char *a;
240  if (y == C_fix(0)) C_div_by_zero_error(C_strloc(a, loc));
241  else return C_u_fixnum_divide(x, y); /* Inconsistent, too: missing _i_ */
242}
243
244C_inline C_word C_u_i_fixnum_remainder_checked_loc(C_word loc, C_word x, C_word y)
245{
246  char *a;
247  if (y == C_fix(0)) {
248    C_div_by_zero_error(C_strloc(a, loc));
249  } else {
250    x = C_unfix(x);
251    y = C_unfix(y);
252    return C_fix(x - ((x / y) * y));
253  }
254}
255
256/* More weirdness: the other flonum_quotient macros and inline functions
257 * do not compute the quotient but the "plain" division!
258 */
259C_inline C_word
260C_a_i_flonum_quotient_checked_loc(C_word **ptr, int c, C_word loc, C_word x, C_word y)
261{
262  char *a; /* Can't use ptr, it may not be big enough */
263  double dy = C_flonum_magnitude(y), r;
264
265  if(dy == 0.0) {
266    C_div_by_zero_error(C_strloc(a, loc));
267  } else {
268    modf(C_flonum_magnitude(x) / dy, &r);
269    return C_flonum(ptr, r);
270  }
271}
272
273C_inline C_word
274C_a_i_flonum_remainder_checked_loc(C_word **ptr, int c, C_word loc, C_word x, C_word y)
275{
276  char *a; /* Can't use ptr, it may not be big enough */
277  double dx = C_flonum_magnitude(x),
278         dy = C_flonum_magnitude(y), r;
279
280  if(dy == 0.0) {
281    C_div_by_zero_error(C_strloc(a, loc));
282  } else {
283    modf(dx / dy, &r);
284    return C_flonum(ptr, dx - r * dy);
285  }
286}
Note: See TracBrowser for help on using the repository browser.