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

Last change on this file since 33148 was 33148, checked in by sjamaan, 3 years ago

numbers: Remove yet another pathological case in Burnikel/Ziegler?. We can now revert to the original implementation; reason behind the original slowness was that you shouldn't divide recursively if Y is too small

File size: 18.0 KB
Line 
1/* numbers-c.h */
2
3/* C_cpsproc is only defined for argvector chickens */
4#ifdef C_cpsproc
5# define ARGVECTOR_CHICKEN
6#endif
7
8/* Compat helpers for extracting procedure args in a common way */
9#ifdef ARGVECTOR_CHICKEN
10# define C_kontinue2(k, r1, r2)                                         \
11  do {                                                                  \
12    C_word avk[ 4 ];                                                    \
13    avk[ 0 ] = C_SCHEME_UNDEFINED;                                      \
14    avk[ 1 ] = (k);                                                     \
15    avk[ 2 ] = (r1);                                                    \
16    avk[ 3 ] = (r2);                                                    \
17    C_values(4, avk);                                                   \
18  } while(0)
19/* "Allocation continuation" closures/functions; these don't receive a
20 * continuation, but they get called through an allocating function.
21 * The function that calls the allocation function needs to save the
22 * continuation in the closure, the "self" argument.
23 */
24# define CONT_BODY(s, a1) C_word s = __av[0]; C_word a1 = __av[1];
25# define CONT_PROC(name, c, s, a1)   name(C_word c, C_word *__av)
26# define CONT_BODYN(c, s) C_word s = __av[0];
27# define CONT_PROCN(name, c, s)   name(C_word c, C_word *__av)
28/* cpsproc() can't easily be used in prototype and definition */
29# define CPS_PROC1(name, c, s, k, a1) name(C_word c, C_word *__av)
30# define CPS_PROC2(name, c, s, k, a1, a2) name(C_word c, C_word *__av)
31# define CPS_PROC3(name, c, s, k, a1, a2, a3) name(C_word c, C_word *__av)
32# define CPS_PROC4(name, c, s, k, a1, a2, a3, a4) name(C_word c, C_word *__av)
33# define CPS_PROC5(name, c, s, k, a1, a2, a3, a4, a5) name(C_word c, C_word *__av)
34# define CPS_PROCN(name, c, s, k) name(C_word c, C_word *__av)
35# define CPS_PROCNPLUS1(name, c, s, k, a1) name(C_word c, C_word *__av)
36/* Excuse the mess */
37# define CPS_BODY1(c, s, k, a1) C_word s = __av[0]; C_word k = __av[1]; C_word a1 = c >= 1 ? __av[2] : 0;
38# define CPS_BODY2(c, s, k, a1, a2) C_word s = __av[0]; C_word k = __av[1]; C_word a1 = c >= 1 ? __av[2] : 0; C_word a2 = c >= 2 ? __av[3] : 0;
39# define CPS_BODY3(c, s, k, a1, a2, a3) C_word s = __av[0]; C_word k = __av[1]; C_word a1 = c >= 1 ? __av[2] : 0; C_word a2 = c >= 2 ? __av[3] : 0; C_word a3 = c >= 3 ? __av[4] : 0;
40# define CPS_BODY4(c, s, k, a1, a2, a3, a4) C_word s = __av[0]; C_word k = __av[1]; C_word a1 = c >= 1 ? __av[2] : 0; C_word a2 = c >= 2 ? __av[3] : 0; C_word a3 = c >= 3 ? __av[4] : 0; C_word a4 = c >= 4 ? __av[5] : 0;
41# define CPS_BODY5(c, s, k, a1, a2, a3, a4, a5) C_word s = __av[0]; C_word k = __av[1]; C_word a1 = c >= 1 ? __av[2] : 0; C_word a2 = c >= 2 ? __av[3] : 0; C_word a3 = c >= 3 ? __av[4] : 0; C_word a4 = c >= 4 ? __av[5] : 0; C_word a5 = c >= 5 ? __av[6] : 0;
42# define CPS_BODYNPLUS1(c, s, k, a1) C_word s = __av[0]; C_word k = __av[1]; C_word a1 = c >= 1 ? __av[2] : 0;
43# define CPS_BODYN(c, s, k) C_word s = __av[0]; C_word k = __av[1];
44# define CPS_CALL(fn, c, s, k, ...) do { C_word avk[] = {s,k,__VA_ARGS__}; fn(c, avk); } while(0)
45
46#else
47
48# define C_kontinue2(k, r1, r2) C_values(4,C_SCHEME_UNDEFINED,k,r1,r2)
49# define CONT_BODY(s, a1) /* Nothing */
50# define CONT_PROC(name, c, s, a1)   name(C_word c, C_word s, C_word a1)
51# define CONT_BODYN(c, s) /* Nothing */
52# define CONT_PROCN(name, c, s)   name(C_word c, C_word s, ...)
53# define CPS_PROC1(name, c, s, k, a1) name(C_word c, C_word s, C_word k, C_word a1)
54# define CPS_PROC2(name, c, s, k, a1, a2) name(C_word c, C_word s, C_word k, C_word a1, C_word a2)
55# define CPS_PROC3(name, c, s, k, a1, a2, a3) name(C_word c, C_word s, C_word k, C_word a1, C_word a2, C_word a3)
56# define CPS_PROC4(name, c, s, k, a1, a2, a3, a4) name(C_word c, C_word s, C_word k, C_word a1, C_word a2, C_word a3, C_word a4, C_word a5)
57# define CPS_PROC5(name, c, s, k, a1, a2, a3, a4, a5) name(C_word c, C_word s, C_word k, C_word a1, C_word a2, C_word a3, C_word a4, C_word a5)
58# define CPS_PROCN(name, c, s, k) name(C_word c, C_word s, C_word k, ...)
59# define CPS_PROCNPLUS1(name, c, s, k, a1) name(C_word c, C_word s, C_word k, C_word a1, ...)
60# define CPS_BODY1(c, s, k, a1) /* Nothing */
61# define CPS_BODY2(c, s, k, a1, a2) /* Nothing */
62# define CPS_BODY3(c, s, k, a1, a2, a3) /* Nothing */
63# define CPS_BODY4(c, s, k, a1, a2, a3, a4) /* Nothing */
64# define CPS_BODY5(c, s, k, a1, a2, a3, a4, a5) /* Nothing */
65# define CPS_BODYN(c, s, k) /* Nothing */
66# define CPS_BODYNPLUS1(c, s, k, a1) /* Nothing */
67# define CPS_CALL(fn, c, s, k, ...)  fn(c, s, k, __VA_ARGS__);
68#endif
69
70#define BIG_TAG       0
71#define RAT_TAG       1
72#define COMP_TAG      2
73
74#ifdef C_SIXTY_FOUR
75# define C_HALF_WORD_SIZE           32
76# define C_hword                    int
77#else
78# define C_HALF_WORD_SIZE           16
79# define C_hword                    short
80#endif
81#define C_uhword                    unsigned C_hword
82
83#define C_SIZEOF_STRUCTURE(n)           ((n)+1) /* missing from chicken.h */
84#define C_SIZEOF_CLOSURE(n)             ((n)+1) /* missing from chicken.h */
85/* The "internal"/"external" bignum distinction should die */
86#define C_SIZEOF_INTERNAL_BIGNUM(n)     (C_SIZEOF_VECTOR((n)+1))
87#define C_internal_bignum(b)            (C_block_item(b,1))
88
89#define C_SIZEOF_BIGNUM(n)              (C_SIZEOF_INTERNAL_BIGNUM(n)+C_SIZEOF_STRUCTURE(2))
90/* This is for convenience and allows flexibility in representation */
91#define C_SIZEOF_FIX_BIGNUM             C_SIZEOF_BIGNUM(1)
92#define C_BIGNUM_DIGIT_LENGTH           C_WORD_SIZE
93#define C_BIGNUM_HALF_DIGIT_LENGTH      C_HALF_WORD_SIZE
94
95/* This defines when we'll switch from schoolbook to Karatsuba
96 * multiplication.  The smallest of the two numbers determines the
97 * switch.  It is pretty high right now because it generates a bit
98 * more garbage and GC overhead dominates the algorithmic performance
99 * gains.  If the GC is improved, this can be readjusted.
100 */
101#define C_KARATSUBA_THRESHOLD        70
102/* This defines when to switch from schoolbook to Burnikel-Ziegler
103 * division.  It creates even more garbage than Karatsuba :(
104 */
105#define C_BURNIKEL_ZIEGLER_THRESHOLD 300
106/* This threshold is in terms of the expected string length.  It
107 * depends on division speed: if you change the above, change this too.
108 */
109#define C_RECURSIVE_TO_STRING_THRESHOLD 750
110
111#define C_BIGNUM_BITS_TO_DIGITS(n) \
112        (((n) + (C_BIGNUM_DIGIT_LENGTH - 1)) / C_BIGNUM_DIGIT_LENGTH)
113
114#define C_BIGNUM_DIGIT_LO_HALF(d)       (C_uhword)(d)
115#define C_BIGNUM_DIGIT_HI_HALF(d)       (C_uhword)((d) >> C_BIGNUM_HALF_DIGIT_LENGTH)
116#define C_BIGNUM_DIGIT_COMBINE(h,l)     ((C_uword)(h) << C_BIGNUM_HALF_DIGIT_LENGTH|(C_uhword)(l))
117
118/* Compatibility for CHICKEN < 4.9.0 */
119#ifndef C_block_header_init
120#define C_block_header_init(b, v)       C_block_header(b) = (v)
121#endif
122
123/* This should be replaced by C_header_bits(x) == C_BIGNUM_TYPE in core */
124#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))
125
126#define C_i_bignump(x)                  C_mk_bool(!C_immediatep(x) && C_IS_BIGNUM_TYPE(x))
127#define C_fitsinbignumhalfdigitp(n)     (C_BIGNUM_DIGIT_HI_HALF(n) == 0)
128#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))))
129#define C_bignum_header(b)              (*(C_word *)C_data_pointer(C_internal_bignum(b)))
130#define C_bignum_digits(b)              (((C_uword *)C_data_pointer(C_internal_bignum(b)))+1)
131#define C_bignum_negativep(b)           (C_bignum_header(b) != 0)
132#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))
133#define C_u_i_fixnum_signum(x)          ((x) == C_fix(0) ? x : (((x) & C_INT_SIGN_BIT) ? C_fix(-1) : C_fix(1)))
134#define C_u_i_fixnum_negativep(x)       C_mk_bool((x) & C_INT_SIGN_BIT)
135#define C_u_i_fixnum_positivep(x)       C_mk_bool(!((x) & C_INT_SIGN_BIT) && (x) != C_fix(0))
136#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)))
137#define C_a_u_i_big_to_flo(p, n, b)     C_flonum(p, C_bignum_to_double(b))
138#define C_u_i_fixnum_length(x)          C_fix(C_ilen(((x) & C_INT_SIGN_BIT) ? ~C_unfix(x) : C_unfix(x)))
139#define C_u_i_flonum_nanp(x)            C_mk_bool(C_isnan(C_flonum_magnitude(x)))
140#define C_u_i_flonum_infinitep(x)       C_mk_bool(C_isinf(C_flonum_magnitude(x)))
141
142#define C_isfinite                      isfinite
143#define C_u_i_flonum_finitep(x)         C_mk_bool(C_isfinite(C_flonum_magnitude(x)))
144
145/* The bytes->words conversion should be killed, but that can only be
146 * done when the representation is made part of core (otherwise the GC
147 * will trip on the vector's contents not being proper Scheme objects:
148 * it skips objects marked with C_BYTEBLOCK_BIT).  We could set
149 * SPECIALBLOCK_BIT, but that would disable the number-syntax hack.
150 * So, for now we'll live with back and forth byte<->word conversion.
151 */
152#define C_bignum_size(b)                (C_bytestowords(C_header_size(C_internal_bignum(b)))-1)
153#define C_bignum_mutate_size(b, s)      (C_block_header(C_internal_bignum(b)) = (C_STRING_TYPE | C_wordstobytes((s)+1)))
154#define C_u_i_bignum_size(b)            C_fix(C_bignum_size(b))
155
156void C_not_an_integer_error(char *loc, C_word x) C_noret;
157void numbers_div_by_zero_error(char *loc) C_noret;
158
159/* XXX: When moving to core, these all need "fctexport" */
160void 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;
161void C_ccall C_bignum_destructive_trim(C_word big);
162C_word C_ccall C_bignum_simplify(C_word big);
163void C_ccall CPS_PROC3(C_u_bignum_extract_digits, c, self, k, x, start, end) C_noret;
164
165C_regparm double C_bignum_to_double(C_word bignum);
166C_regparm C_word C_fcall C_i_numbers_numberp(C_word x);
167C_regparm C_word C_fcall C_i_numbers_integerp(C_word x);
168C_regparm C_word C_fcall C_i_numbers_eqvp(C_word x, C_word y);
169C_regparm C_word C_fcall C_i_nanp(C_word x);
170C_regparm C_word C_fcall C_i_numbers_finitep(C_word x);
171C_regparm C_word C_fcall C_i_numbers_infinitep(C_word x);
172C_regparm C_word C_ccall C_i_numbers_zerop(C_word x);
173
174C_word C_ccall C_u_i_2_fixnum_gcd(C_word x, C_word y);
175C_word C_ccall C_a_u_i_2_flonum_gcd(C_word **p, C_word n, C_word x, C_word y);
176
177void C_ccall CPS_PROC1(C_basic_abs, c, self, k, x) C_noret;
178void C_ccall CPS_PROC1(C_u_integer_abs, c, self, k, x) C_noret;
179
180void C_ccall CPS_PROC1(C_basic_signum, c, self, k, x) C_noret;
181C_regparm C_word C_fcall C_u_i_integer_signum(C_word x);
182
183void C_ccall CPS_PROC1(C_basic_negate, c, self, k, x) C_noret;
184void C_ccall CPS_PROC1(C_u_integer_negate, c, self, k, x) C_noret;
185C_regparm C_word C_fcall C_a_u_i_fixnum_negate(C_word **ptr, C_word n, C_word x);
186
187void C_ccall CPS_PROC2(C_2_basic_plus, c, self, k, x, y) C_noret;
188C_regparm C_word C_fcall C_a_u_i_2_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y);
189void C_ccall CPS_PROC2(C_u_2_integer_plus, c, self, k, x, y) C_noret;
190
191void C_ccall CPS_PROC2(C_2_basic_minus, c, self, k, x, y) C_noret;
192C_regparm C_word C_fcall C_a_u_i_2_fixnum_minus(C_word **ptr, C_word n, C_word x, C_word y);
193void C_ccall CPS_PROC2(C_u_2_integer_minus, c, self, k, x, y) C_noret;
194
195void C_ccall CPS_PROC2(C_2_basic_times, c, self, k, x, y) C_noret;
196C_regparm C_word C_fcall C_a_u_i_2_fixnum_times(C_word **ptr, C_word n, C_word x, C_word y);
197void C_ccall CPS_PROC2(C_u_2_integer_times, c, self, k, x, y) C_noret;
198
199void C_ccall CPS_PROC2(C_basic_quotient, c, self, k, x, y) C_noret;
200void C_ccall CPS_PROC2(C_u_integer_quotient, c, self, k, x, y) C_noret;
201
202void C_ccall CPS_PROC2(C_basic_remainder, c, self, k, x, y) C_noret;
203void C_ccall CPS_PROC2(C_u_integer_remainder, c, self, k, x, y) C_noret;
204
205void C_ccall CPS_PROC2(C_basic_divrem, c, self, k, x, y) C_noret;
206void C_ccall CPS_PROC2(C_u_integer_divrem, c, self, k, x, y) C_noret;
207
208void C_ccall CPS_PROCN(C_numbers_nequalp, c, self, k) C_noret;
209C_regparm C_word C_fcall C_i_2_basic_equalp(C_word x, C_word y);
210C_word C_ccall C_u_i_2_integer_equalp(C_word x, C_word y);
211void C_ccall CPS_PROCN(C_numbers_lessp, c, self, k) C_noret;
212C_regparm C_word C_fcall C_i_2_basic_lessp(C_word x, C_word y);
213C_word C_ccall C_u_i_2_integer_lessp(C_word x, C_word y);
214void C_ccall CPS_PROCN(C_numbers_less_or_equalp, c, self, k) C_noret;
215C_regparm C_word C_fcall C_i_2_basic_less_or_equalp(C_word x, C_word y);
216C_word C_ccall C_u_i_2_integer_or_equal_p(C_word x, C_word y);
217void C_ccall CPS_PROCN(C_numbers_greaterp, c, self, k) C_noret;
218C_regparm C_word C_fcall C_i_2_basic_greaterp(C_word x, C_word y);
219C_word C_ccall C_u_i_2_integer_greaterp(C_word x, C_word y);
220void C_ccall CPS_PROCN(C_numbers_greater_or_equal_p, c, self, k) C_noret;
221C_regparm C_word C_fcall C_i_2_basic_greater_or_equalp(C_word x, C_word y);
222C_word C_ccall C_u_i_2_integer_or_equalp(C_word x, C_word y);
223
224C_word C_u_i_bignum_cmp(C_word x, C_word y);
225
226/** TODO: rename to C_i_evenp/C_i_oddp, or is this fine? */
227C_regparm C_word C_fcall C_i_basic_evenp(C_word x);
228C_regparm C_word C_fcall C_u_i_integer_evenp(C_word x);
229C_regparm C_word C_fcall C_i_basic_oddp(C_word x);
230C_regparm C_word C_fcall C_u_i_integer_oddp(C_word x);
231C_regparm C_word C_fcall C_i_basic_positivep(C_word x);
232C_regparm C_word C_fcall C_u_i_integer_positivep(C_word x);
233C_regparm C_word C_fcall C_i_basic_negativep(C_word x);
234C_regparm C_word C_fcall C_u_i_integer_negativep(C_word x);
235
236C_regparm C_word C_ccall C_u_i_integer_randomize(C_word seed);
237void C_ccall CPS_PROC1(C_u_integer_random, c, self, k, max) C_noret;
238
239void C_ccall CPS_PROC5(C_digits_to_integer, c, self, k, n, start, end, radix, negp) C_noret;
240void C_ccall CPS_PROCNPLUS1(C_basic_number_to_string, c, closure, k, num) C_noret;
241void C_ccall CPS_PROC2(C_u_fixnum_to_string, c, self, k, num, radix) C_noret;
242void C_ccall CPS_PROC2(C_u_flonum_to_string, c, self, k, num, radix) C_noret;
243void C_ccall CPS_PROC2(C_u_integer_to_string, c, self, k, num, radix) C_noret;
244void C_ccall CPS_PROC1(C_u_flo_to_int, c, self, k, x) C_noret;
245C_word C_ccall C_u_i_integer_bit_setp(C_word n, C_word i);
246C_word C_ccall C_u_i_integer_length(C_word x);
247
248void C_ccall CPS_PROC2(C_u_integer_shift, c, self, k, x, y) C_noret;
249void C_ccall CPS_PROC2(C_u_2_integer_bitwise_and, c, self, k, x, y) C_noret;
250void C_ccall CPS_PROC2(C_u_2_integer_bitwise_ior, c, self, k, x, y) C_noret;
251void C_ccall CPS_PROC2(C_u_2_integer_bitwise_xor, c, self, k, x, y) C_noret;
252
253/* Silly but in some cases needed */
254C_inline C_word C_bignum0(C_word **ptr)
255{
256  C_word *p = *ptr, p0 = (C_word)p;
257
258  C_word tagvec = CHICKEN_gc_root_ref(tags);
259
260  /* Not using C_a_i_vector4, to make it easier to rewrite later */
261  *(p++) = C_STRING_TYPE | C_wordstobytes(1);
262  *(p++) = 0; /* zero is always positive */
263  *ptr = p;
264
265  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
266}
267
268C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
269{
270  C_word *p = *ptr, p0 = (C_word)p;
271
272  /* TODO: Get rid of structure wrapper and tag vector. */
273  C_word tagvec = CHICKEN_gc_root_ref(tags);
274
275  /* Not using C_a_i_vector2, to make it easier to rewrite later */
276  *(p++) = C_STRING_TYPE | C_wordstobytes(2);
277  *(p++) = negp;
278  *(p++) = d1;
279  *ptr = p;
280
281  return C_a_i_record2(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
282}
283
284/* Here d1, d2, ... are low to high (ie, little endian)! */
285C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
286{
287  C_word *p = *ptr, p0 = (C_word)p;
288
289  C_word tagvec = CHICKEN_gc_root_ref(tags);
290
291  /* Not using C_a_i_vector3, to make it easier to rewrite later */
292  *(p++) = C_STRING_TYPE | C_wordstobytes(3);
293  *(p++) = negp;
294  *(p++) = d1;
295  *(p++) = d2;
296  *ptr = p;
297
298  return C_a_i_record2(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
299}
300
301/* TODO: Is this correctly named?  Shouldn't it accept an argcount? */
302C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
303{
304  x = C_unfix(x);
305  if (x < 0)
306    return C_bignum1(ptr, 1, -x);
307  else if (x == 0)
308    return C_bignum0(ptr);
309  else
310    return C_bignum1(ptr, 0, x);
311}
312
313/* XXX: Naming convention is inconsistent!  Core has C_fixnum_divide()
314 * but also C_a_i_flonum_quotient_checked()
315 */
316C_inline C_word C_a_u_i_fixnum_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
317{
318  if (y == C_fix(0)) {
319    numbers_div_by_zero_error("fx/");
320  } else if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(-1)) {
321    return C_bignum1(ptr, 0, -C_MOST_NEGATIVE_FIXNUM); /* Special case */
322  } else {
323    return C_u_fixnum_divide(x, y); /* Inconsistent, too: missing _i_ */
324  }
325}
326
327C_inline C_word C_u_i_fixnum_remainder_checked(C_word x, C_word y)
328{
329  if (y == C_fix(0)) {
330    numbers_div_by_zero_error("remainder");
331  } else {
332    x = C_unfix(x);
333    y = C_unfix(y);
334    return C_fix(x - ((x / y) * y));
335  }
336}
337
338/* Workaround for CHICKENs < 4.9.0, which contain broken fpintegerp */
339C_inline C_word C_u_i_fpintegerp_fixed(C_word x)
340{
341  double dummy, val;
342
343  val = C_flonum_magnitude(x);
344
345  if(C_isnan(val) || C_isinf(val)) return C_SCHEME_FALSE;
346
347  return C_mk_bool(C_modf(val, &dummy) == 0.0);
348}
349
350
351/* More weirdness: the other flonum_quotient macros and inline functions
352 * do not compute the quotient but the "plain" division!
353 */
354C_inline C_word
355C_a_i_flonum_actual_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
356{
357  double dy = C_flonum_magnitude(y), r;
358
359  if(dy == 0.0) {
360    numbers_div_by_zero_error("quotient");
361  } else if (!C_truep(C_u_i_fpintegerp_fixed(x))) {
362    C_not_an_integer_error("quotient", x);
363  } else if (!C_truep(C_u_i_fpintegerp_fixed(y))) {
364    C_not_an_integer_error("quotient", y);
365  } else {
366    modf(C_flonum_magnitude(x) / dy, &r);
367    return C_flonum(ptr, r);
368  }
369}
370
371C_inline C_word
372C_a_i_flonum_remainder_checked(C_word **ptr, int c, C_word x, C_word y)
373{
374  double dx = C_flonum_magnitude(x),
375         dy = C_flonum_magnitude(y), r;
376
377  if(dy == 0.0) {
378    numbers_div_by_zero_error("remainder");
379  } else if (!C_truep(C_u_i_fpintegerp_fixed(x))) {
380    C_not_an_integer_error("remainder", x);
381  } else if (!C_truep(C_u_i_fpintegerp_fixed(y))) {
382    C_not_an_integer_error("remainder", y);
383  } else {
384    modf(dx / dy, &r);
385    return C_flonum(ptr, dx - r * dy);
386  }
387}
388
389/*
390 * From Hacker's Delight by Henry S. Warren
391 * based on a modified nlz() from section 5-3 (fig. 5-7)
392 */
393C_inline int C_ilen(C_uword x)
394{
395  C_uword y;
396  C_word n = 0;
397
398#ifdef C_SIXTY_FOUR
399  y = x >> 32; if (y != 0) { n += 32; x = y; }
400#endif
401  y = x >> 16; if (y != 0) { n += 16; x = y; }
402  y = x >>  8; if (y != 0) { n +=  8; x = y; }
403  y = x >>  4; if (y != 0) { n +=  4; x = y; }
404  y = x >>  2; if (y != 0) { n +=  2; x = y; }
405  y = x >>  1; if (y != 0) return n + 2;
406  return n + x;
407}
Note: See TracBrowser for help on using the repository browser.