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

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

numbers: Another attempt at fixing the strlcat compat code

File size: 119.5 KB
Line 
1/* numbers-c.c
2 *
3 * Copyright 2010-2014 The CHICKEN Team
4 *
5 * This contains a barely recognizable version of c/bignum.c from Scheme48 1.8:
6 * Copyright (c) 1993-2008 Richard Kelsey and Jonathan Rees
7 * Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
8 * Copyright 1992,1993,1994,2004 Massachusetts Institute of Technology
9 *
10 * Redistribution and use in source and binary forms, with or without
11 * modification, are permitted provided that the following conditions are
12 * met:
13 *
14 *    1. Redistributions of source code must retain the above copyright
15 *       notice, this list of conditions and the following disclaimer.
16 *
17 *    2. Redistributions in binary form must reproduce the above
18 *       copyright notice, this list of conditions and the following
19 *       disclaimer in the documentation and/or other materials provided
20 *       with the distribution.
21 *
22 *    3. The name of the author may not be used to endorse or promote
23 *       products derived from this software without specific prior
24 *       written permission.
25 *
26 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
27 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
28 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
29 * DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
30 * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
31 * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
32 * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
33 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
34 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
35 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
36 * POSSIBILITY OF SUCH DAMAGE.
37 */
38
39#include <assert.h>
40#include <errno.h>
41#include <math.h> /* frexp() */
42
43#define nmax(x, y)     ((x) > (y) ? (x) : (y)) /* From runtime.c */
44
45static void *tags;
46
47#include "numbers-c.h"
48
49static C_word init_tags(___scheme_value tagvec);
50static void bignum_negate_2(C_word c, C_word self, C_word new_big) C_noret;
51static void allocate_bignum_2(C_word c, C_word self, C_word bigvec) C_noret;
52static C_word bignum_digits_destructive_scale_up_with_carry(C_word *start, C_word *end, C_word fix_factor, C_word carry);
53static void bignum_plus_unsigned(C_word k, C_word x, C_word y, C_word negp) C_noret;
54static void bignum_plus_unsigned_2(C_word c, C_word self, C_word result) C_noret;
55static void cmp_intflo(C_word c, C_word self, C_word x);
56static int bignum_cmp_unsigned(C_word x, C_word y);
57static void bignum_minus_unsigned(C_word k, C_word x, C_word y) C_noret;
58static void bignum_minus_unsigned_2(C_word c, C_word self, C_word result) C_noret;
59static void gcd_intflo(C_word c, C_word self, C_word intnum) C_noret;
60static void gcd_intflo_2(C_word c, C_word self, C_word result) C_noret;
61static void integer_gcd_2(C_word c, C_word self, C_word new_y) C_noret;
62static void integer_gcd_3(void *dummy) C_noret;
63static void bignum_gcd_loop(C_word c, C_word self, C_word tmp_x) C_noret;
64static void bignum_gcd_loop_2(C_word c, C_word self, C_word tmp_y) C_noret;
65static void integer_times_2(C_word c, C_word self, C_word new_big) C_noret;
66static C_regparm void bignum_digits_multiply(C_word x, C_word y, C_word result);
67static void bignum_times_bignum_unsigned(C_word k, C_word x, C_word y, C_word negp) C_noret;
68static void bignum_times_bignum_unsigned_2(C_word c, C_word self, C_word result) C_noret;
69static void digits_to_integer_2(C_word c, C_word self, C_word result) C_noret;
70static void bignum_to_digits_2(C_word c, C_word self, C_word working_copy) C_noret;
71static void bignum_to_digits_3(C_word c, C_word self, C_word string) C_noret;
72static void flo_to_int_2(C_word c, C_word self, C_word result) C_noret;
73static void bignum_allocate_for_shift(C_word c, C_word self, C_word x) C_noret;
74static void bignum_negate_after_shift(C_word c, C_word self, C_word result) C_noret;
75static void bignum_actual_shift(C_word c, C_word self, C_word result) C_noret;
76static void bignum_random_2(C_word c, C_word self, C_word result) C_noret;
77static void bignum_maybe_negate_magnitude(C_word k, C_word result) C_noret;
78static void divrem_intflo(C_word c, C_word self, C_word intnum) C_noret;
79static void divrem_intflo_2(C_word c, C_word self, C_word x, C_word y) C_noret;
80static void bignum_divrem_fixnum_2(C_word c, C_word self, C_word negated_big) C_noret;
81static void bignum_negneg_bitwise_op(C_word c, C_word self, C_word result) C_noret;
82static void bignum_posneg_bitwise_op(C_word c, C_word self, C_word result) C_noret;
83static void bignum_pospos_bitwise_op(C_word c, C_word self, C_word result) C_noret;
84static void quotient_intflo(C_word c, C_word self, C_word intnum) C_noret;
85static void quotient_intflo_2(C_word c, C_word self, C_word x) C_noret;
86static void remainder_intflo(C_word c, C_word self, C_word intnum) C_noret;
87static void remainder_intflo_2(C_word c, C_word self, C_word x) C_noret;
88static void bignum_destructive_normalize(C_word target, C_word source, C_word shift_left);
89static C_word bignum_remainder_unsigned_halfdigit(C_word num, C_word den);
90static void bignum_destructive_divide_unsigned_halfdigit(C_word c, C_word self, C_word quotient);
91static C_word bignum_divide_digit(C_word uh, C_word ul, C_word v, C_word *q);
92static C_word bignum_divide_and_subtract_digit(C_word v1, C_word v2, C_word guess, C_word *u);
93static void bignum_divide_2_unsigned(C_word c, C_word self, C_word quotient) C_noret;
94static void bignum_divide_2_unsigned_2(C_word c, C_word self, C_word remainder) C_noret;
95static void bignum_divide_2_unsigned_3(C_word c, C_word self, C_word tmp_big) C_noret;
96static void bignum_destructive_divide_normalized(C_word u, C_word v, C_word q);
97static C_word bignum_divide_and_subtract(C_word *v_start, C_word *v_end, C_word guess, C_word *u_start);
98static C_word bignum_simplify_shifted(C_word bignum, C_word shift_right);
99
100static void barf(int code, char *loc, ...) C_noret;
101static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...) C_noret;
102
103/* XXX THIS IS DUPLICATED HERE FROM runtime.c, but should be ripped out */
104static void barf(int code, char *loc, ...)
105{
106  char *msg;
107  int c, i;
108  va_list v;
109  /* Just take a random size that will "always" fit... */
110  C_word err, ab[C_SIZEOF_STRING(64)], *a = ab;
111
112  err = C_lookup_symbol(C_intern2(&a, C_text("\003syserror-hook")));
113
114  switch(code) {
115  case C_BAD_ARGUMENT_COUNT_ERROR:
116    msg = C_text("bad argument count");
117    c = 3;
118    break;
119
120  case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:
121    msg = C_text("too few arguments");
122    c = 3;
123    break;
124 
125  case C_BAD_ARGUMENT_TYPE_ERROR:
126    msg = C_text("bad argument type");
127    c = 1;
128    break;
129
130  case C_DIVISION_BY_ZERO_ERROR:
131    msg = C_text("division by zero");
132    c = 0;
133    break;
134
135  case C_OUT_OF_RANGE_ERROR:
136    msg = C_text("out of range");
137    c = 2;
138    break;
139
140  case C_CANT_REPRESENT_INEXACT_ERROR:
141    msg = C_text("inexact number cannot be represented as an exact number");
142    c = 1;
143    break;
144
145  case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:
146    msg = C_text("bad argument type - not a fixnum");
147    c = 1;
148    break;
149
150  case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:
151    msg = C_text("bad argument type - not a number");
152    c = 1;
153    break;
154
155  case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:
156    msg = C_text("bad argument type - not an integer");
157    c = 1;
158    break;
159
160  case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:
161    msg = C_text("bad argument type - not an unsigned integer");
162    c = 1;
163    break;
164
165  case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:
166    msg = C_text("bad argument type - not a flonum");
167    c = 1;
168    break;
169
170  case C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR:
171    msg = C_text("bad argument type - invalid base");
172    c = 1;
173    break;
174
175  default:
176    fprintf(stderr, "Unknown error");
177    abort();
178  }
179 
180  if(!C_immediatep(err)) {
181    C_save(C_fix(code));
182   
183    C_save(C_intern2(&a, loc));
184   
185    va_start(v, loc);
186    i = c;
187
188    while(i--)
189      C_save(va_arg(v, C_word));
190
191    va_end(v);
192    /* No continuation is passed: '##sys#error-hook' may not return: */
193    C_do_apply(c + 2, C_block_item(err, 0), C_SCHEME_UNDEFINED); 
194  } else {
195    fprintf(stderr, "No error hook!");
196    abort();
197  }
198}
199
200void C_not_an_integer_error(char *loc, C_word x)
201{
202  barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);
203}
204
205/* Never use extended number hook procedure names longer than this! */
206/* Current longest name: numbers#@extended-quotient&remainder */
207#define MAX_EXTNUM_HOOK_NAME 64
208
209/* This exists so that we don't have to create any extra closures */
210static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...)
211{
212  static C_word ab[C_SIZEOF_STRING(MAX_EXTNUM_HOOK_NAME)];
213  int i;
214  va_list v;
215  C_word ext_proc_sym, ext_proc = C_SCHEME_FALSE, *a = ab;
216
217  ext_proc_sym = C_lookup_symbol(C_intern2(&a, ext_proc_name));
218
219  if(!C_immediatep(ext_proc_sym))
220    ext_proc = C_block_item(ext_proc_sym, 0);
221
222  if (!C_immediatep(ext_proc) && C_closurep(ext_proc)) {
223    va_start(v, k);
224    i = c - 1;
225
226    while(i--)
227      C_save(va_arg(v, C_word));
228
229    va_end(v);
230    C_do_apply(c - 1, ext_proc, k);
231  } else {
232    /* TODO: Convert to barf(), add new error code */
233    fprintf(stderr, "No extended number hook for %s!\n", ext_proc_name);
234    abort();
235  }
236}
237
238static C_word
239init_tags(___scheme_value tagvec)
240{
241  tags = CHICKEN_new_gc_root();
242  CHICKEN_gc_root_set(tags, tagvec);
243  return C_SCHEME_UNDEFINED;
244}
245
246#define ratnum_type_tag C_block_item(CHICKEN_gc_root_ref(tags), RAT_TAG)
247#define compnum_type_tag C_block_item(CHICKEN_gc_root_ref(tags), COMP_TAG)
248
249C_inline C_word basic_eqvp(C_word x, C_word y)
250{
251  return (x == y ||
252
253          (!C_immediatep(x) && !C_immediatep(y) &&
254           C_block_header(x) == C_block_header(y) &&
255           
256           ((C_block_header(x) == C_FLONUM_TAG &&
257             C_flonum_magnitude(x) == C_flonum_magnitude(y)) ||
258           
259            (C_IS_BIGNUM_TYPE(x) && C_u_i_bignum_cmp(x, y) == C_fix(0)))));
260}
261
262/* TODO: Rename to C_i_eqvp */
263C_regparm C_word C_fcall
264C_i_numbers_eqvp(C_word x, C_word y)
265{
266  return
267    C_mk_bool(basic_eqvp(x, y) ||
268              (!C_immediatep(x) && !C_immediatep(y) &&
269               (C_block_header(x) == C_block_header(y) &&
270                C_header_bits(x) == C_STRUCTURE_TYPE &&
271                C_block_item(x, 0) == C_block_item(y, 0) &&
272                (C_block_item(x, 0) == ratnum_type_tag ||
273                 C_block_item(x, 0) == compnum_type_tag) &&
274                basic_eqvp(C_block_item(x, 1), C_block_item(y, 1)) &&
275                basic_eqvp(C_block_item(x, 2), C_block_item(y, 2)))));
276}
277
278C_regparm C_word C_fcall C_i_nanp(C_word x)
279{
280  if (x & C_FIXNUM_BIT) {
281    return C_SCHEME_FALSE;
282  } else if (C_immediatep(x)) {
283    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
284  } else if (C_block_header(x) == C_FLONUM_TAG) {
285    return C_u_i_flonum_nanp(x);
286  } else if (C_IS_BIGNUM_TYPE(x)) {
287    return C_SCHEME_FALSE;
288  } else if (C_header_bits(x) == C_STRUCTURE_TYPE) {
289    /* To make this inlineable we don't call try_extended_number */
290    if (C_block_item(x, 0) == ratnum_type_tag)
291      return C_SCHEME_FALSE;
292    else if (C_block_item(x, 0) == compnum_type_tag)
293      return C_mk_bool(C_truep(C_i_nanp(C_block_item(x, 1))) ||
294                       C_truep(C_i_nanp(C_block_item(x, 2))));
295    else
296      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
297  } else {
298    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
299  }
300}
301
302/* TODO: Rename to C_i_finitep */
303C_regparm C_word C_fcall C_i_numbers_finitep(C_word x)
304{
305  if (x & C_FIXNUM_BIT) {
306    return C_SCHEME_TRUE;
307  } else if (C_immediatep(x)) {
308    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
309  } else if (C_block_header(x) == C_FLONUM_TAG) {
310    return C_u_i_flonum_finitep(x);
311  } else if (C_IS_BIGNUM_TYPE(x)) {
312    return C_SCHEME_TRUE;
313  } else if (C_header_bits(x) == C_STRUCTURE_TYPE) {
314    /* To make this inlineable we don't use try_extended_number */
315    if (C_block_item(x, 0) == ratnum_type_tag)
316      return C_SCHEME_TRUE;
317    else if (C_block_item(x, 0) == compnum_type_tag)
318      return C_and(C_i_numbers_finitep(C_block_item(x, 1)),
319                   C_i_numbers_finitep(C_block_item(x, 2)));
320    else
321      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
322  } else {
323    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
324  }
325}
326
327/* TODO: Rename to C_i_infinitep */
328C_regparm C_word C_fcall C_i_numbers_infinitep(C_word x)
329{
330  if (x & C_FIXNUM_BIT) {
331    return C_SCHEME_FALSE;
332  } else if (C_immediatep(x)) {
333    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
334  } else if (C_block_header(x) == C_FLONUM_TAG) {
335    return C_u_i_flonum_infinitep(x);
336  } else if (C_IS_BIGNUM_TYPE(x)) {
337    return C_SCHEME_FALSE;
338  } else if (C_header_bits(x) == C_STRUCTURE_TYPE) {
339    /* To make this inlineable we don't use try_extended_number */
340    if (C_block_item(x, 0) == ratnum_type_tag)
341      return C_SCHEME_FALSE;
342    else if (C_block_item(x, 0) == compnum_type_tag)
343      return C_mk_bool(C_truep(C_i_numbers_infinitep(C_block_item(x, 1))) ||
344                       C_truep(C_i_numbers_infinitep(C_block_item(x, 2))));
345    else
346      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
347  } else {
348    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
349  }
350}
351
352/* Copy all the digits from source to target, obliterating what was
353 * there.  If target is larger than source, the most significant
354 * digits will remain untouched.
355 */
356C_inline void bignum_digits_destructive_copy(C_word target, C_word source)
357{
358  C_memcpy(C_bignum_digits(target), C_bignum_digits(source),
359           /* TODO: This is currently in bytes.  If we change the
360            * representation that needs to change!
361            * We subtract the size of the header, too.
362            */
363           C_header_size(C_internal_bignum(source))-C_wordstobytes(1));
364}
365
366void C_ccall
367C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
368{
369  C_word ab[nmax(C_SIZEOF_FIX_BIGNUM, C_SIZEOF_FLONUM*2)], *a = ab;
370
371  if (x & C_FIXNUM_BIT) {
372    if (y & C_FIXNUM_BIT) {
373      C_kontinue(k, C_a_u_i_2_fixnum_plus(&a, 2, x, y));
374    } else if (C_immediatep(y)) {
375      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
376    } else if (C_block_header(y) == C_FLONUM_TAG) {
377      C_kontinue(k, C_flonum(&a, (double)C_unfix(x) + C_flonum_magnitude(y)));
378    } else if (C_IS_BIGNUM_TYPE(y)) {
379      C_u_2_bignum_plus(4, (C_word)NULL, k, C_a_u_i_fix_to_big(&a, x), y);
380    } else {
381      try_extended_number("numbers#@extended-2-plus", 3, k, x, y);
382    }
383  } else if (C_immediatep(x)) {
384    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);
385  } else if (C_block_header(x) == C_FLONUM_TAG) {
386    if (y & C_FIXNUM_BIT) {
387      C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) + (double)C_unfix(y)));
388    } else if (C_immediatep(y)) {
389      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
390    } else if (C_block_header(y) == C_FLONUM_TAG) {
391      C_kontinue(k, C_a_i_flonum_plus(&a, 2, x, y));
392    } else if (C_IS_BIGNUM_TYPE(y)) {
393      C_kontinue(k, C_a_i_flonum_plus(&a, 2, x, C_a_u_i_big_to_flo(&a, 1, y)));
394    } else {
395      try_extended_number("numbers#@extended-2-plus", 3, k, x, y);
396    }
397  } else if (C_IS_BIGNUM_TYPE(x)) {
398    if (y & C_FIXNUM_BIT) {
399      C_u_2_bignum_plus(4, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y));
400    } else if (C_immediatep(y)) {
401      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
402    } else if (C_block_header(y) == C_FLONUM_TAG) {
403      C_kontinue(k, C_a_i_flonum_plus(&a, 2, C_a_u_i_big_to_flo(&a, 1, x), y));
404    } else if (C_IS_BIGNUM_TYPE(y)) {
405      C_u_2_bignum_plus(4, (C_word)NULL, k, x, y);
406    } else {
407      try_extended_number("numbers#@extended-2-plus", 3, k, x, y);
408    }
409  } else {
410    try_extended_number("numbers#@extended-2-plus", 3, k, x, y);
411  }
412}
413
414void C_ccall
415C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
416{
417  C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab;
418
419  if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT)
420    C_kontinue(k, C_a_u_i_2_fixnum_plus(&a, 2, x, y));
421
422  if (x & C_FIXNUM_BIT)
423    x = C_a_u_i_fix_to_big(&a, x);
424  if (y & C_FIXNUM_BIT)
425    y = C_a_u_i_fix_to_big(&a, y);
426
427  C_u_2_bignum_plus(4, (C_word)NULL, k, x, y);
428}
429
430/* Needs C_SIZEOF_FIX_BIGNUM */
431C_regparm C_word C_fcall
432C_a_u_i_2_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y)
433{
434  /* Exceptional situation: this will cause a real overflow */
435  if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(C_MOST_NEGATIVE_FIXNUM)) {
436    return C_bignum2(ptr, 1, 0, 2);
437  } else {
438    C_word z = C_unfix(x) + C_unfix(y);
439
440    if(!C_fitsinfixnump(z)) {
441      /* TODO: function/macro returning either fixnum or bignum from a C int */
442      /* This should help with the C API/FFI too. */
443      return C_bignum2(ptr, (z < 0), labs(z) & (C_uword)C_BIGNUM_DIGIT_MASK, 1);
444    } else {
445      return C_fix(z);
446    }
447  }
448}
449
450void C_ccall
451C_u_2_bignum_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
452{
453  if (C_bignum_negativep(x)) {
454    if (C_bignum_negativep(y)) {
455      bignum_plus_unsigned(k, x, y, C_SCHEME_TRUE);
456    } else {
457      bignum_minus_unsigned(k, y, x);
458    }
459  } else {
460    if (C_bignum_negativep(y)) {
461      bignum_minus_unsigned(k, x, y);
462    } else {
463      bignum_plus_unsigned(k, x, y, C_SCHEME_FALSE);
464    }
465  }
466}
467
468void C_ccall
469C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
470{
471  C_word ab[nmax(C_SIZEOF_FIX_BIGNUM, C_SIZEOF_FLONUM*2)], *a = ab;
472
473  if (x & C_FIXNUM_BIT) {
474    if (y & C_FIXNUM_BIT) {
475      C_kontinue(k, C_a_u_i_2_fixnum_minus(&a, 2, x, y));
476    } else if (C_immediatep(y)) {
477      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
478    } else if (C_block_header(y) == C_FLONUM_TAG) {
479      C_kontinue(k, C_flonum(&a, (double)C_unfix(x) - C_flonum_magnitude(y)));
480    } else if (C_IS_BIGNUM_TYPE(y)) {
481      C_u_2_bignum_minus(4, (C_word)NULL, k, C_a_u_i_fix_to_big(&a, x), y);
482    } else {
483      try_extended_number("numbers#@extended-2-minus", 3, k, x, y);
484    }
485  } else if (C_immediatep(x)) {
486    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
487  } else if (C_block_header(x) == C_FLONUM_TAG) {
488    if (y & C_FIXNUM_BIT) {
489      C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) - (double)C_unfix(y)));
490    } else if (C_immediatep(y)) {
491      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
492    } else if (C_block_header(y) == C_FLONUM_TAG) {
493      C_kontinue(k, C_a_i_flonum_difference(&a, 2, x, y)); /* XXX NAMING! */
494    } else if (C_IS_BIGNUM_TYPE(y)) {
495      C_kontinue(k, C_a_i_flonum_difference(&a, 2, x, C_a_u_i_big_to_flo(&a, 1, y)));
496    } else {
497      try_extended_number("numbers#@extended-2-minus", 3, k, x, y);
498    }
499  } else if (C_IS_BIGNUM_TYPE(x)) {
500    if (y & C_FIXNUM_BIT) {
501      C_u_2_bignum_minus(4, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y));
502    } else if (C_immediatep(y)) {
503      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
504    } else if (C_block_header(y) == C_FLONUM_TAG) {
505      C_kontinue(k, C_a_i_flonum_difference(&a, 2, C_a_u_i_big_to_flo(&a, 1, x), y));
506    } else if (C_IS_BIGNUM_TYPE(y)) {
507      C_u_2_bignum_minus(4, (C_word)NULL, k, x, y);
508    } else {
509      try_extended_number("numbers#@extended-2-minus", 3, k, x, y);
510    }
511  } else {
512    try_extended_number("numbers#@extended-2-minus", 3, k, x, y);
513  }
514}
515
516void C_ccall
517C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
518{
519  C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab;
520
521  if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT)
522    C_kontinue(k, C_a_u_i_2_fixnum_minus(&a, 2, x, y));
523
524  if (x & C_FIXNUM_BIT)
525    x = C_a_u_i_fix_to_big(&a, x);
526  if (y & C_FIXNUM_BIT)
527    y = C_a_u_i_fix_to_big(&a, y);
528
529  C_u_2_bignum_minus(4, (C_word)NULL, k, x, y);
530}
531
532/* Needs C_SIZEOF_FIX_BIGNUM */
533C_regparm C_word C_fcall
534C_a_u_i_2_fixnum_minus(C_word **ptr, C_word n, C_word x, C_word y)
535{
536  C_word z = C_unfix(x) - C_unfix(y);
537
538  if(!C_fitsinfixnump(z)) {
539    /* TODO: function/macro returning either fixnum or bignum from a C int */
540    /* This should help with the C API/FFI too. */
541    return C_bignum2(ptr, (z < 0), labs(z) & (C_uword)C_BIGNUM_DIGIT_MASK, 1);
542  } else {
543    return C_fix(z);
544  }
545}
546
547void C_ccall
548C_u_2_bignum_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
549{
550  if (C_bignum_negativep(x)) {
551    if (C_bignum_negativep(y)) {
552      bignum_minus_unsigned(k, y, x);
553    } else {
554      bignum_plus_unsigned(k, x, y, C_SCHEME_TRUE);
555    }
556  } else {
557    if (C_bignum_negativep(y)) {
558      bignum_plus_unsigned(k, x, y, C_SCHEME_FALSE);
559    } else {
560      bignum_minus_unsigned(k, x, y);
561    }
562  }
563}
564
565static void
566bignum_plus_unsigned(C_word k, C_word x, C_word y, C_word negp)
567{
568  C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, k2, size;
569
570  if (C_bignum_size(y) > C_bignum_size(x)) {
571    C_word z = x;
572    x = y;
573    y = z;
574  }
575
576  k2 = C_closure(&ka, 4, (C_word)bignum_plus_unsigned_2, k, x, y);
577 
578  size = C_fix(C_bignum_size(x) + 1); /* One more digit, for possible carry. */
579  C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
580}
581
582static void
583bignum_plus_unsigned_2(C_word c, C_word self, C_word result)
584{
585  C_word k = C_block_item(self, 1),
586         x = C_block_item(self, 2),
587         y = C_block_item(self, 3),
588         *scan_x = C_bignum_digits(x),
589         *end_x = scan_x + C_bignum_size(x),
590         *scan_y = C_bignum_digits(y),
591         *end_y = scan_y + C_bignum_size(y),
592         *scan_r = C_bignum_digits(result),
593         *end_r = scan_r + C_bignum_size(result),
594         sum, carry = 0;
595
596  /* Move over the two numbers simultaneously, adding digits w/ carry. */
597  while (scan_y < end_y) {
598    sum = (*scan_x++) + (*scan_y++) + carry;
599    if (C_fitsinbignumdigitp(sum)) {
600      (*scan_r++) = sum;
601      carry = 0;
602    } else {
603      (*scan_r++) = sum & C_BIGNUM_DIGIT_MASK;
604      carry = 1;
605    }
606  }
607 
608  /* The end of y, the smaller number.  Propagate carry into the rest of x. */
609  if (carry) {
610    while (scan_x < end_x) {
611      sum = (*scan_x++) + 1;
612      if (C_fitsinbignumdigitp(sum)) {
613        (*scan_r++) = sum;
614        carry = 0;
615        break;
616      } else {
617        (*scan_r++) = sum & C_BIGNUM_DIGIT_MASK;
618      }
619    }
620  }
621
622  if (carry) { /* We must've reached the end of x, with still a carry. */
623    (*scan_r) = 1; /* No need to trim: we're now using the extra digit. */
624    /* No need to normalize: We started with a bignum and it only grew. */
625    C_kontinue(k, result);
626  } else {
627    /* No more carry.  Copy remaining part of x (if any) to result. */
628    while (scan_x < end_x)
629      (*scan_r++) = (*scan_x++);
630
631    assert(scan_r == end_r - 1);
632
633    *scan_r = 0; /* Ensure trimming works.  TODO: set length directly? */
634    C_kontinue(k, C_bignum_simplify(result));
635  }
636}
637
638static int
639bignum_cmp_unsigned(C_word x, C_word y)
640{
641  C_word xlen = C_bignum_size(x), ylen = C_bignum_size(y);
642
643  if (xlen < ylen) {
644    return -1;
645  } else if (xlen > ylen) {
646    return 1;
647  } else if (x == y) {
648    return 0;
649  } else {
650    C_word *startx = C_bignum_digits(x);
651    C_word *scanx = startx + xlen;
652    C_word *scany = C_bignum_digits(y) + ylen;
653
654    while (startx < scanx) {
655      C_word xdigit = (*--scanx);
656      C_word ydigit = (*--scany);
657      if (xdigit < ydigit)
658        return -1;
659      if (xdigit > ydigit)
660        return 1;
661    }
662    return 0;
663  }
664}
665
666static void
667bignum_minus_unsigned(C_word k, C_word x, C_word y)
668{
669  C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, k2, size, negp;
670
671  switch(bignum_cmp_unsigned(x, y)) {
672  case 0:             /* x = y, return 0 */
673    C_kontinue(k, C_fix(0));
674  case -1:            /* abs(x) < abs(y), return -(abs(y) - abs(x)) */
675    k2 = C_closure(&ka, 4, (C_word)bignum_minus_unsigned_2, k, y, x);
676   
677    size = C_fix(C_bignum_size(y)); /* Maximum size of result is length of y. */
678    C_allocate_bignum(5, (C_word)NULL, k2, size, C_SCHEME_TRUE, C_SCHEME_FALSE);
679  case 1:             /* abs(x) > abs(y), return abs(x) - abs(y) */
680  default:
681    k2 = C_closure(&ka, 4, (C_word)bignum_minus_unsigned_2, k, x, y);
682   
683    size = C_fix(C_bignum_size(x)); /* Maximum size of result is length of x. */
684    C_allocate_bignum(5, (C_word)NULL, k2, size, C_SCHEME_FALSE, C_SCHEME_FALSE);
685    break;
686  }
687}
688
689static void
690bignum_minus_unsigned_2(C_word c, C_word self, C_word result)
691{
692  C_word k = C_block_item(self, 1),
693         x = C_block_item(self, 2),
694         y = C_block_item(self, 3),
695         *scan_x = C_bignum_digits(x),
696         *end_x = scan_x + C_bignum_size(x),
697         *scan_r = C_bignum_digits(result),
698         *scan_y = C_bignum_digits(y),
699         *end_y = scan_y + C_bignum_size(y),
700         difference, borrow = 0;
701
702  /* Move over the two numbers simultaneously, subtracting digits w/ borrow. */
703  while (scan_y < end_y) {
704    difference = (((*scan_x++) - (*scan_y++)) - borrow);
705    if (difference < 0) {
706      (*scan_r++) = ((C_word)1 << C_BIGNUM_DIGIT_LENGTH) + difference;
707      borrow = 1;
708    } else {
709      (*scan_r++) = difference;
710      borrow = 0;
711    }
712  }
713
714  /* The end of y, the smaller number.  Propagate borrow into the rest of x. */
715  if (borrow != 0) {
716    while (scan_x < end_x) {
717      difference = ((*scan_x++) - borrow);
718      if (difference < 0) {
719        (*scan_r++) = ((C_word)1 << C_BIGNUM_DIGIT_LENGTH) + difference;
720      } else {
721        (*scan_r++) = difference;
722        borrow = 0;
723        break;
724      }
725    }
726  }
727
728  assert(borrow == 0);
729
730  /* Finishing up: Copy remaining part of x (if any) into result. */
731  while (scan_x < end_x)
732    (*scan_r++) = (*scan_x++);
733
734  C_kontinue(k, C_bignum_simplify(result));
735}
736
737void C_ccall
738C_2_basic_gcd(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
739{
740  C_word ab[C_SIZEOF_FLONUM*2+C_SIZEOF_CLOSURE(4)], *a = ab, k2;
741
742  if (x & C_FIXNUM_BIT) {
743    if (y & C_FIXNUM_BIT) {
744      C_kontinue(k, C_u_i_2_fixnum_gcd(x, y));
745    } else if (C_immediatep(y)) {
746      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
747    } else if (C_block_header(y) == C_FLONUM_TAG) {
748      C_kontinue(k, C_a_u_i_2_flonum_gcd(&a, 1, C_a_i_fix_to_flo(&a, 1, x), y));
749    } else if (C_IS_BIGNUM_TYPE(y)) {
750      C_u_2_integer_gcd(4, (C_word)NULL, k, x, y);
751    } else {
752      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
753    }
754  } else if (C_immediatep(x)) {
755    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), x);
756  } else if (C_block_header(x) == C_FLONUM_TAG) {
757    if (y & C_FIXNUM_BIT) {
758      C_kontinue(k, C_a_u_i_2_flonum_gcd(&a, 1, x, C_a_i_fix_to_flo(&a, 1, y)));
759    } else if (C_immediatep(y)) {
760      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
761    } else if (C_block_header(y) == C_FLONUM_TAG) {
762      C_kontinue(k, C_a_u_i_2_flonum_gcd(&a, 1, x, y));
763    } else if (C_IS_BIGNUM_TYPE(y)) {
764      k2 = C_closure(&a, 4, (C_word)gcd_intflo, k, C_SCHEME_TRUE, y);
765      C_u_flo_to_int(4, (C_word)NULL, k2, loc, x);
766    } else {
767      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
768    }
769  } else if (C_IS_BIGNUM_TYPE(x)) {
770    if (y & C_FIXNUM_BIT) {
771      C_u_2_integer_gcd(4, (C_word)NULL, k, x, y);
772    } else if (C_immediatep(y)) {
773      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
774    } else if (C_block_header(y) == C_FLONUM_TAG) {
775      k2 = C_closure(&a, 4, (C_word)gcd_intflo, k, C_SCHEME_FALSE, x);
776      C_u_flo_to_int(4, (C_word)NULL, k2, loc, y);
777    } else if (C_IS_BIGNUM_TYPE(y)) {
778      C_u_2_bignum_gcd(4, (C_word)NULL, k, x, y);
779    } else {
780      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
781    }
782  } else {
783    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), x);
784  }
785}
786
787static void gcd_intflo(C_word c, C_word self, C_word intnum)
788{
789  C_word k = C_block_item(self, 1),
790         intnum_is_x =  C_block_item(self, 2),
791         other_arg = C_block_item(self, 3),
792         kab[C_SIZEOF_CLOSURE(2)], *ka = kab, k2;
793 
794  k2 = C_closure(&ka, 2, (C_word)gcd_intflo_2, k);
795  if (C_truep(intnum_is_x))
796    C_u_2_integer_gcd(4, (C_word)NULL, k2, intnum, other_arg);
797  else
798    C_u_2_integer_gcd(4, (C_word)NULL, k2, other_arg, intnum);
799}
800
801static void gcd_intflo_2(C_word c, C_word self, C_word result)
802{
803   C_word k = C_block_item(self, 1), ab[C_SIZEOF_FLONUM], *a = ab;
804   if (result & C_FIXNUM_BIT)
805     C_kontinue(k, C_a_i_fix_to_flo(&a, 1, result));
806   else
807     C_kontinue(k, C_a_u_i_big_to_flo(&a, 1, result));
808}
809
810C_word C_ccall
811C_u_i_2_fixnum_gcd(C_word x, C_word y)
812{
813   C_word r;
814   
815   x = C_unfix(x);
816   y = C_unfix(y);
817   
818   if (x < 0) x = -x;
819   if (y < 0) y = -y;
820   
821   while(y != 0) {
822     r = x % y;
823     x = y;
824     y = r;
825   }
826   return C_fix(x);
827}
828
829C_word C_ccall
830C_a_u_i_2_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)
831{
832   double xub, yub, r;
833
834   if (!C_truep(C_u_i_fpintegerp(x)))
835     barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", x);
836   if (!C_truep(C_u_i_fpintegerp(y)))
837     barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", y);
838
839   xub = C_flonum_magnitude(x);
840   yub = C_flonum_magnitude(y);
841
842   if (xub < 0.0) xub = -xub;
843   if (yub < 0.0) yub = -yub;
844   
845   while(yub != 0.0) {
846     r = fmod(xub, yub);
847     xub = yub;
848     yub = r;
849   }
850   return C_flonum(p, xub);
851}
852
853void C_ccall
854C_u_2_integer_gcd(C_word c, C_word self, C_word k, C_word x, C_word y)
855{
856  if (y == C_fix(0)) {
857    C_u_integer_abs(3, (C_word)NULL, k, x);
858  } else if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT) {
859    C_kontinue(k, C_u_i_2_fixnum_gcd(x, y));
860  } else if (!(x & C_FIXNUM_BIT) && !(y & C_FIXNUM_BIT)) {
861    C_u_2_bignum_gcd(4, (C_word)NULL, k, x, y);
862  } else {
863    /* Choose the slow and simple path: recursive call.  This should
864     * be invoked only a handful of times until we hit fixnums.
865     * TODO: This could be made faster still with a bignum/fixnum gcd.
866     */
867    C_word kab[C_SIZEOF_CLOSURE(3)], *ka = kab, k2;
868
869    k2 = C_closure(&ka, 3, (C_word)integer_gcd_2, k, y);
870    /* Pass #f for "loc", we know we won't divide by zero */
871    C_u_integer_remainder(5, (C_word)NULL, k2, C_SCHEME_FALSE, x, y);
872  }
873}
874
875void C_ccall
876C_u_2_bignum_gcd(C_word c, C_word self, C_word k, C_word x, C_word y)
877{
878  C_word kab[C_SIZEOF_CLOSURE(5)], *ka = kab, k2, size;
879
880  switch(bignum_cmp_unsigned(x, y)) {
881  case 0:
882    C_kontinue(k, x);
883  case -1:
884    /* Swap to avoid extra step (division algorithm also requires this) */
885    k2 = x;
886    x = y;
887    y = k2;
888  case 1:
889  default:
890    /* Instead of recursively calling integer_gcd, it is much faster
891     * to allocate two bignums and then just loop, destructively
892     * updating them, until we reach a fixnum.
893     */
894    size = C_fix(C_bignum_size(x)+1); /* May need to be normalized */
895    k2 = C_closure(&ka, 5, (C_word)bignum_gcd_loop, k, x, y, C_SCHEME_UNDEFINED);
896    C_allocate_bignum(5, (C_word)NULL, k2, size, C_SCHEME_FALSE, C_SCHEME_FALSE);
897  }
898}
899
900static void
901integer_gcd_2(C_word c, C_word self, C_word new_y)
902{
903  if (!C_demand(5 + C_SIZEOF_CLOSURE(3))) { /* XXX */
904    C_save_and_reclaim((void *)integer_gcd_3, (void *)integer_gcd_2,
905                       2, new_y, self);
906  } else {
907    C_word k = C_block_item(self, 1),
908           x = C_block_item(self, 2); /* Old y = new x */
909    C_u_2_integer_gcd(4, (C_word)NULL, k, x, new_y);
910  }
911}
912
913static void
914integer_gcd_3(void *dummy)
915{
916   C_word self = C_restore,
917          new_y = C_restore;
918   ((C_proc2)(void*)(*((C_word*)self+1)))(2, self, new_y);
919}
920
921static void
922bignum_gcd_loop(C_word c, C_word self, C_word tmp_x)
923{
924  C_word x = C_block_item(self, 2),
925         size = C_fix(C_bignum_size(x)+1); /* Will be swapped, so use x-len! */
926
927  /* Nice: We can recycle the current closure */
928  C_set_block_item(self, 0, (C_word)bignum_gcd_loop_2);
929  C_set_block_item(self, 4, tmp_x);
930  C_allocate_bignum(5, (C_word)NULL, self, size, C_SCHEME_FALSE, C_SCHEME_FALSE);
931}
932
933static void
934bignum_gcd_loop_2(C_word c, C_word self, C_word tmp_y)
935{
936  C_word k = C_block_item(self, 1),
937         x = C_block_item(self, 2),
938         length_x = C_bignum_size(x),
939         y = C_block_item(self, 3),
940         length_y = C_bignum_size(y),
941         tmp_x = C_block_item(self, 4), d1, shift;
942
943  assert(length_x >= length_y);
944  /* Because tmp_y is allocated as size(x)+1, we need to reset its length. */
945  /* Mutate vector size of internal bignum vector for tmp_y */
946  C_block_header(C_internal_bignum(tmp_y)) = (C_STRING_TYPE | C_wordstobytes(length_y+1));
947  /* Set internal header. */
948  C_bignum_header(tmp_y) = (C_bignum_header(tmp_y) & C_BIGNUM_HEADER_SIGN_BIT) | length_y;
949   
950  for(;;) {
951    d1 = *(C_bignum_digits(y) + length_y - 1);
952    shift = 0;
953
954    /* TODO: Would it be possible to pull this out of the loop? */
955    while (d1 < ((C_word)1 << (C_BIGNUM_DIGIT_LENGTH-1))) {
956      d1 <<= 1;
957      shift++;
958    }
959    /* The code below stores the remainder into tmp_x */
960    if (shift == 0) { /* Already normalized? */
961      if (tmp_x != x) { /* Avoid needless copying after first loop step. */
962        bignum_digits_destructive_copy(tmp_x, x);
963        *(C_bignum_digits(tmp_x) + length_x) = 0;
964        /* This simplifies the swap below */
965        bignum_digits_destructive_copy(tmp_y, y);
966        *(C_bignum_digits(tmp_y) + length_y) = 0;
967      }
968      bignum_destructive_divide_normalized(tmp_x, y, C_SCHEME_UNDEFINED);
969      tmp_x = C_bignum_simplify(tmp_x);
970    } else {
971      bignum_destructive_normalize(tmp_x, x, shift); /* OK even if tmp_x = x! */
972      bignum_destructive_normalize(tmp_y, y, shift); /* OK even if tmp_y = y! */
973      bignum_destructive_divide_normalized(tmp_x, tmp_y, C_SCHEME_UNDEFINED);
974      tmp_x = bignum_simplify_shifted(tmp_x, shift);
975      tmp_y = bignum_simplify_shifted(tmp_y, shift);
976      assert(C_block_item(k, 0) != 0);
977    }
978    if (tmp_x & C_FIXNUM_BIT) {
979      /* Finish up: Calculate fixnum/fixnum, bignum/fixnum, or just return x */
980      C_u_2_integer_gcd(4, (C_word)NULL, k, tmp_y, tmp_x);
981    } else {
982      /* Update lengths to match the new values, so that we can stretch them */
983      length_x = C_bignum_size(tmp_y);
984      length_y = C_bignum_size(tmp_x);
985
986      x = tmp_y;
987      y = tmp_x;
988      tmp_y = tmp_x;
989      tmp_x = x;
990      /* x and y are now their new values, sharing data with tmp_x and tmp_y! */
991
992      /* Ensure that tmp_x is again 1 larger than x */
993      /* Mutate vector size of internal bignum vector. */
994      C_block_header(C_internal_bignum(tmp_x)) = (C_STRING_TYPE | C_wordstobytes(length_x+2));
995      /* Set internal header. */
996      C_bignum_header(tmp_x) = (C_bignum_header(tmp_x) & C_BIGNUM_HEADER_SIGN_BIT) | (length_x+1);
997      *(C_bignum_digits(tmp_x) + length_x) = 0;
998    }
999  }
1000}
1001
1002void C_ccall
1003C_basic_abs(C_word c, C_word self, C_word k, C_word x)
1004{
1005  C_word ab[nmax(C_SIZEOF_FIX_BIGNUM, C_SIZEOF_FLONUM)], *a = ab;
1006
1007  if (x & C_FIXNUM_BIT)
1008    C_kontinue(k, C_a_u_i_fixnum_abs(&a, 1, x));
1009  else if (C_immediatep(x))
1010    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);
1011  else if (C_block_header(x) == C_FLONUM_TAG)
1012    C_kontinue(k, C_a_i_flonum_abs(&a, 1, x));
1013  else if (C_IS_BIGNUM_TYPE(x))
1014    C_u_bignum_abs(3, (C_word)NULL, k, x);
1015  else
1016    try_extended_number("numbers#@extended-abs", 2, k, x);
1017}
1018
1019void C_ccall
1020C_u_integer_abs(C_word c, C_word self, C_word k, C_word x)
1021{
1022  C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
1023
1024  if (x & C_FIXNUM_BIT)
1025    C_kontinue(k, C_a_u_i_fixnum_abs(&a, 1, x));
1026  else
1027    C_u_bignum_abs(3, (C_word)NULL, k, x);
1028}
1029
1030void C_ccall
1031C_u_bignum_abs(C_word c, C_word self, C_word k, C_word x)
1032{
1033  if (C_bignum_negativep(x))
1034    C_u_bignum_negate(3, (C_word)NULL, k, x);
1035  else
1036    C_kontinue(k, x);
1037}
1038
1039void C_ccall
1040C_basic_signum(C_word c, C_word self, C_word k, C_word x)
1041{
1042  C_word ab[C_SIZEOF_FLONUM], *a = ab;
1043
1044  if (x & C_FIXNUM_BIT)
1045    C_kontinue(k, C_u_i_fixnum_signum(x));
1046  else if (C_immediatep(x))
1047    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x);
1048  else if (C_block_header(x) == C_FLONUM_TAG)
1049    C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x));
1050  else if (C_IS_BIGNUM_TYPE(x))
1051    C_kontinue(k, C_u_i_bignum_signum(x));
1052  else
1053    try_extended_number("numbers#@extended-signum", 2, k, x);
1054}
1055
1056C_regparm C_word C_fcall C_u_i_integer_signum(C_word x)
1057{
1058  if (x & C_FIXNUM_BIT) return C_u_i_fixnum_signum(x);
1059  else return C_u_i_bignum_signum(x);
1060}
1061
1062C_regparm C_word C_fcall C_i_basic_evenp(C_word x)
1063{
1064  double val, dummy;
1065  if(x & C_FIXNUM_BIT) {
1066    return C_mk_nbool(x & 0x02);
1067  } else if(C_immediatep(x)) {
1068    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
1069  } else if (C_block_header(x) == C_FLONUM_TAG) {
1070    val = C_flonum_magnitude(x);
1071    if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
1072      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
1073    else
1074      return C_mk_bool(fmod(val, 2.0) == 0.0);
1075  } else if (C_IS_BIGNUM_TYPE(x)) {
1076    return C_u_i_bignum_evenp(x);
1077  } else { /* No need to try extended number */
1078    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
1079  }
1080}
1081
1082C_regparm C_word C_fcall C_u_i_integer_evenp(C_word x)
1083{
1084  if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
1085  return C_u_i_bignum_evenp(x);
1086}
1087
1088C_regparm C_word C_fcall C_i_basic_oddp(C_word x)
1089{
1090  double val, dummy;
1091  if(x & C_FIXNUM_BIT) {
1092    return C_mk_bool(x & 0x02);
1093  } else if(C_immediatep(x)) {
1094    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
1095  } else if(C_block_header(x) == C_FLONUM_TAG) {
1096    val = C_flonum_magnitude(x);
1097    if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
1098      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
1099    else
1100      return C_mk_bool(fmod(val, 2.0) != 0.0);
1101  } else if (C_IS_BIGNUM_TYPE(x)) {
1102    return C_u_i_bignum_oddp(x);
1103  } else {
1104    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
1105  }
1106}
1107
1108C_regparm C_word C_fcall C_u_i_integer_oddp(C_word x)
1109{
1110  if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
1111  return C_u_i_bignum_oddp(x);
1112}
1113
1114void C_ccall
1115C_basic_negate(C_word c, C_word self, C_word k, C_word x)
1116{
1117  C_word ab[nmax(C_SIZEOF_FIX_BIGNUM, C_SIZEOF_FLONUM)], *a = ab;
1118
1119  if (x & C_FIXNUM_BIT)
1120    C_kontinue(k, C_a_u_i_fixnum_negate(&a, 1, x));
1121  else if (C_immediatep(x))
1122    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
1123  else if (C_block_header(x) == C_FLONUM_TAG)
1124    C_kontinue(k, C_a_i_flonum_negate(&a, 1, x));
1125  else if (C_IS_BIGNUM_TYPE(x))
1126    C_u_bignum_negate(3, (C_word)NULL, k, x);
1127  else
1128    try_extended_number("numbers#@extended-negate", 2, k, x);
1129}
1130
1131void C_ccall
1132C_u_integer_negate(C_word c, C_word self, C_word k, C_word x)
1133{
1134  C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
1135
1136  if (x & C_FIXNUM_BIT)
1137    C_kontinue(k, C_a_u_i_fixnum_negate(&a, 1, x));
1138  else
1139    C_u_bignum_negate(3, (C_word)NULL, k, x);
1140}
1141
1142C_regparm C_word C_fcall
1143C_a_u_i_fixnum_negate(C_word **ptr, C_word n, C_word x)
1144{
1145  /* Exceptional situation: this will cause an overflow to itself */
1146  if (x == C_fix(C_MOST_NEGATIVE_FIXNUM)) /* C_fitsinfixnump(x) */
1147    return C_bignum2(ptr, 0, 0, 1);
1148  else
1149    return C_fix(-C_unfix(x));
1150}
1151
1152void C_ccall
1153C_u_bignum_negate(C_word c, C_word self, C_word k, C_word x)
1154{
1155  if (C_bignum_negated_fitsinfixnump(x)) {
1156    C_kontinue(k, C_fix(C_MOST_NEGATIVE_FIXNUM));
1157  } else {
1158    C_word kab[C_SIZEOF_CLOSURE(3)], *ka = kab, k2,
1159           negp = C_mk_nbool(C_bignum_negativep(x)),
1160           size = C_fix(C_bignum_size(x));
1161    k2 = C_closure(&ka, 3, (C_word)bignum_negate_2, k, x);
1162    C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
1163  }
1164}
1165
1166static void
1167bignum_negate_2(C_word c, C_word self, C_word new_big)
1168{
1169  C_word k = C_block_item(self, 1),
1170         old_big = C_block_item(self, 2);
1171  bignum_digits_destructive_copy(new_big, old_big);
1172  C_kontinue(k, C_bignum_simplify(new_big));
1173}
1174
1175void C_ccall
1176C_2_basic_equalp(C_word c, C_word self, C_word k, C_word x, C_word y)
1177{
1178  C_word ab[C_SIZEOF_CLOSURE(5)+C_SIZEOF_FIX_BIGNUM], *a = ab, k2;
1179
1180  if (x & C_FIXNUM_BIT) {
1181    if (y & C_FIXNUM_BIT) {
1182      C_kontinue(k, C_mk_bool(x == y));
1183    } else if (C_immediatep(y)) {
1184      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
1185    } else if (C_block_header(y) == C_FLONUM_TAG) {
1186      x = C_a_u_i_fix_to_big(&a, x); /* Continue below(1) */
1187    } else if (C_IS_BIGNUM_TYPE(y)) {
1188      C_kontinue(k, C_SCHEME_FALSE);
1189    } else {
1190      try_extended_number("numbers#@extended-2-=", 3, k, x, y);
1191    }
1192  } else if (C_immediatep(x)) {
1193    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);
1194  } else if (C_block_header(x) == C_FLONUM_TAG) {
1195    if (y & C_FIXNUM_BIT) {
1196      y = C_a_u_i_fix_to_big(&a, y); /* Continue below(2) */
1197    } else if (C_immediatep(y)) {
1198      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
1199    } else if (C_block_header(y) == C_FLONUM_TAG) {
1200      C_kontinue(k, C_flonum_equalp(x, y));
1201    }
1202
1203    if (C_IS_BIGNUM_TYPE(y)) { /* (2) */
1204      if (!C_truep(C_u_i_fpintegerp(x))) {
1205        C_kontinue(k, C_SCHEME_FALSE);
1206      } else {
1207        k2 = C_closure(&a, 5, (C_word)cmp_intflo, k, C_fix(0), y, C_fix(0));
1208        C_u_flo_to_int(4, (C_word)NULL, k2, C_SCHEME_FALSE, x);
1209      }
1210    } else {
1211      try_extended_number("numbers#@extended-2-=", 3, k, x, y);
1212    }
1213  }
1214
1215  if (C_IS_BIGNUM_TYPE(x)) { /* (1) */
1216    if (y & C_FIXNUM_BIT) {
1217      C_kontinue(k, C_SCHEME_FALSE);
1218    } else if (C_immediatep(y)) {
1219      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
1220    } else if (C_block_header(y) == C_FLONUM_TAG) {
1221      if (!C_truep(C_u_i_fpintegerp(y))) {
1222        C_kontinue(k, C_SCHEME_FALSE);
1223      } else {
1224        k2 = C_closure(&a, 5, (C_word)cmp_intflo, k, C_fix(0), x, C_fix(0));
1225        C_u_flo_to_int(4, (C_word)NULL, k2, C_SCHEME_FALSE, y);
1226      }
1227    } else if (C_IS_BIGNUM_TYPE(y)) {
1228      C_kontinue(k, C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(0)));
1229    } else {
1230      try_extended_number("numbers#@extended-2-=", 3, k, x, y);
1231    }
1232  } else {
1233    try_extended_number("numbers#@extended-2-=", 3, k, x, y);
1234  }
1235}
1236
1237C_word C_ccall
1238C_u_i_2_integer_equalp(C_word x, C_word y)
1239{
1240  if (x & C_FIXNUM_BIT)
1241    return C_mk_bool(x == y);
1242  else if (y & C_FIXNUM_BIT)
1243    return C_SCHEME_FALSE;
1244  else
1245    return C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(0));
1246}
1247
1248void C_ccall
1249C_2_basic_lessp(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
1250{
1251  C_word ab[C_SIZEOF_CLOSURE(5)+C_SIZEOF_FIX_BIGNUM+C_SIZEOF_FLONUM], *a = ab, k2;
1252  double f, i;
1253
1254  if (x & C_FIXNUM_BIT) {
1255    if (y & C_FIXNUM_BIT) {
1256      C_kontinue(k, C_mk_bool(C_unfix(x) < C_unfix(y)));
1257    } else if (C_immediatep(y)) {
1258      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
1259    } else if (C_block_header(y) == C_FLONUM_TAG) {
1260      x = C_a_u_i_fix_to_big(&a, x); /* Continue below(1) */
1261    } else if (C_IS_BIGNUM_TYPE(y)) {
1262      /* A fixnum can only be smaller than a positive bignum */
1263      C_kontinue(k, C_mk_nbool(C_bignum_negativep(y)));
1264    } else {
1265      try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
1266    }
1267  } else if (C_immediatep(x)) {
1268    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), x);
1269  } else if (C_block_header(x) == C_FLONUM_TAG) {
1270    if (y & C_FIXNUM_BIT) {
1271      y = C_a_u_i_fix_to_big(&a, y); /* Continue below(2) */
1272    } else if (C_immediatep(y)) {
1273       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
1274    } else if (C_block_header(y) == C_FLONUM_TAG) {
1275      C_kontinue(k, C_flonum_lessp(x, y));
1276    }
1277
1278    if (C_IS_BIGNUM_TYPE(y)) { /* (2) */
1279      f = C_flonum_magnitude(x);
1280      if (C_isnan(f)) {
1281        C_kontinue(k, C_SCHEME_FALSE);
1282      } else if (C_isinf(f)) {
1283        C_kontinue(k, C_mk_bool(f < 0.0));
1284      } else {
1285        C_word diff;
1286        f = modf(f, &i);
1287        if (f < 0.0) diff = C_fix(-1);
1288        else if (f > 0.0) diff = C_fix(1);
1289        else diff = C_fix(0);
1290        k2 = C_closure(&a, 5, (C_word)cmp_intflo, k, C_fix(-1), y, diff);
1291        C_u_flo_to_int(4, (C_word)NULL, k2, C_SCHEME_FALSE, C_flonum(&a, i));
1292      }
1293    } else {
1294      try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
1295    }
1296  }
1297
1298  if (C_IS_BIGNUM_TYPE(x)) { /* (1) */
1299    if (y & C_FIXNUM_BIT) {
1300      /* Only a negative bignum is smaller than any fixnum */
1301      C_kontinue(k, C_mk_bool(C_bignum_negativep(x)));
1302    } else if (C_immediatep(y)) {
1303       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
1304    } else if (C_block_header(y) == C_FLONUM_TAG) {
1305      f = C_flonum_magnitude(y);
1306      if (C_isnan(f)) {
1307        C_kontinue(k, C_SCHEME_FALSE);
1308      } else if (C_isinf(f)) {
1309        C_kontinue(k, C_mk_bool(f > 0.0));
1310      } else {
1311        C_word diff;
1312        f = modf(f, &i);
1313        if (f < 0.0) diff = C_fix(-1);
1314        else if (f > 0.0) diff = C_fix(1);
1315        else diff = C_fix(0);
1316        k2 = C_closure(&a, 5, (C_word)cmp_intflo, k, C_fix(1), x, diff);
1317        C_u_flo_to_int(4, (C_word)NULL, k2, C_SCHEME_FALSE, C_flonum(&a, i));
1318      }
1319    } else if (C_IS_BIGNUM_TYPE(y)) {
1320      C_kontinue(k, C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(-1)));
1321    } else {
1322      try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
1323    }
1324  } else {
1325    try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
1326  }
1327}
1328
1329C_word C_ccall
1330C_u_i_2_integer_lessp(C_word x, C_word y)
1331{
1332  if (x & C_FIXNUM_BIT) {
1333    if (y & C_FIXNUM_BIT) {
1334      return C_mk_bool(C_unfix(x) < C_unfix(y));
1335    } else {
1336      return C_mk_nbool(C_bignum_negativep(y));
1337    }
1338  } else if (y & C_FIXNUM_BIT) {
1339    return C_mk_bool(C_bignum_negativep(x));
1340  } else {
1341    return C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(-1));
1342  }
1343}
1344
1345void C_ccall
1346C_2_basic_greaterp(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
1347{
1348  C_word ab[C_SIZEOF_CLOSURE(5)+C_SIZEOF_FIX_BIGNUM+C_SIZEOF_FLONUM], *a = ab, k2;
1349  double f, i;
1350
1351  if (x & C_FIXNUM_BIT) {
1352    if (y & C_FIXNUM_BIT) {
1353      C_kontinue(k, C_mk_bool(C_unfix(x) > C_unfix(y)));
1354    } else if (C_immediatep(y)) {
1355      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
1356    } else if (C_block_header(y) == C_FLONUM_TAG) {
1357      x = C_a_u_i_fix_to_big(&a, x); /* Continue below(1) */
1358    } else if (C_IS_BIGNUM_TYPE(y)) {
1359      /* A fixnum can only be larger than a negative bignum */
1360      C_kontinue(k, C_mk_bool(C_bignum_negativep(y)));
1361    } else {
1362      try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
1363    }
1364  } else if (C_immediatep(x)) {
1365    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), x);
1366  } else if (C_block_header(x) == C_FLONUM_TAG) {
1367    if (y & C_FIXNUM_BIT) {
1368      y = C_a_u_i_fix_to_big(&a, y); /* Continue below(2) */
1369    } else if (C_immediatep(y)) {
1370      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
1371    } else if (C_block_header(y) == C_FLONUM_TAG) {
1372      C_kontinue(k, C_flonum_greaterp(x, y));
1373    }
1374
1375    if (C_IS_BIGNUM_TYPE(y)) { /* (2) */
1376      f = C_flonum_magnitude(x);
1377      if (C_isnan(f)) {
1378        C_kontinue(k, C_SCHEME_FALSE);
1379      } else if (C_isinf(f)) {
1380        C_kontinue(k, C_mk_bool(f > 0.0));
1381      } else {
1382        C_word diff;
1383        f = modf(f, &i);
1384        if (f < 0.0) diff = C_fix(-1);
1385        else if (f > 0.0) diff = C_fix(1);
1386        else diff = C_fix(0);
1387        k2 = C_closure(&a, 5, (C_word)cmp_intflo, k, C_fix(1), y, diff);
1388        C_u_flo_to_int(4, (C_word)NULL, k2, C_SCHEME_FALSE, C_flonum(&a, i));
1389      }
1390    } else {
1391      try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
1392    }
1393  }
1394
1395  if (C_IS_BIGNUM_TYPE(x)) { /* (1) */
1396    if (y & C_FIXNUM_BIT) {
1397      /* Only a positive bignum is greater than any fixnum */
1398      C_kontinue(k, C_mk_nbool(C_bignum_negativep(x)));
1399    } else if (C_immediatep(y)) {
1400      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
1401    } else if (C_block_header(y) == C_FLONUM_TAG) {
1402      f = C_flonum_magnitude(y);
1403      if (C_isnan(f)) {
1404        C_kontinue(k, C_SCHEME_FALSE);
1405      } else if (C_isinf(f)) {
1406        C_kontinue(k, C_mk_bool(f < 0.0));
1407      } else {
1408        C_word diff;
1409        f = modf(f, &i);
1410        if (f < 0.0) diff = C_fix(-1);
1411        else if (f > 0.0) diff = C_fix(1);
1412        else diff = C_fix(0);
1413        k2 = C_closure(&a, 5, (C_word)cmp_intflo, k, C_fix(-1), x, diff);
1414        C_u_flo_to_int(4, (C_word)NULL, k2, C_SCHEME_FALSE, C_flonum(&a, i));
1415      }
1416    } else if (C_IS_BIGNUM_TYPE(y)) {
1417      C_kontinue(k, C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(1)));
1418    } else {
1419      try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
1420    }
1421  } else {
1422      try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
1423  }
1424}
1425
1426C_word C_ccall
1427C_u_i_2_integer_greaterp(C_word x, C_word y)
1428{
1429  if (x & C_FIXNUM_BIT) {
1430    if (y & C_FIXNUM_BIT) {
1431      return C_mk_bool(C_unfix(x) > C_unfix(y));
1432    } else {
1433      return C_mk_bool(C_bignum_negativep(y));
1434    }
1435  } else if (y & C_FIXNUM_BIT) {
1436    return C_mk_nbool(C_bignum_negativep(x));
1437  } else {
1438    return C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(1));
1439  }
1440}
1441
1442/* This is a bit weird: We have to compare flonums as bignums due to
1443 * precision loss on 64-bit platforms.  For simplicity, we convert
1444 * fixnums to bignums here.
1445 */
1446static void cmp_intflo(C_word c, C_word self, C_word x)
1447{
1448  C_word k = C_block_item(self, 1),
1449         comparator = C_block_item(self, 2),
1450         y = C_block_item(self, 3),
1451         diff = C_block_item(self, 4),
1452         ab[C_SIZEOF_FIX_BIGNUM], *a = ab, res;
1453
1454  if (x & C_FIXNUM_BIT) /* Enforce a bignum again (may have been normalized) */
1455    x = C_a_u_i_fix_to_big(&a, x);
1456
1457  res = C_u_i_bignum_cmp(x, y);
1458  if (res == C_fix(0)) /* Use diff to break ties */
1459    C_kontinue(k, C_mk_bool(diff == comparator));
1460  else
1461    C_kontinue(k, C_mk_bool(res == comparator));
1462}
1463
1464C_word
1465C_u_i_bignum_cmp(C_word x, C_word y)
1466{
1467  if (C_bignum_negativep(x)) {
1468    if (C_bignum_negativep(y)) { /* Largest negative number is smallest */
1469      return C_fix(bignum_cmp_unsigned(y, x));
1470    } else {
1471      return C_fix(-1);
1472    }
1473  } else {
1474    if (C_bignum_negativep(y)) {
1475      return C_fix(1);
1476    } else {
1477      return C_fix(bignum_cmp_unsigned(x, y));
1478    }
1479  }
1480}
1481
1482/* XXX TODO: Maybe pass true/false/bignum as initp, to allow copying data? */
1483void C_ccall
1484C_allocate_bignum(C_word c, C_word self, C_word k, C_word size, C_word negp, C_word initp)
1485{
1486  C_word kab[C_SIZEOF_CLOSURE(3)], *ka = kab, k2, init;
1487  k2 = C_closure(&ka, 3, (C_word)allocate_bignum_2, k, negp);
1488
1489  init = C_and(initp, C_make_character('\0'));
1490  C_allocate_vector(6, (C_word)NULL, k2,
1491                    C_bytes(C_fixnum_plus(size, C_fix(1))), /* Add header */
1492                    /* Byte vec, initialization, align at 8 bytes */
1493                    C_SCHEME_TRUE, init, C_SCHEME_FALSE);
1494}
1495
1496static void
1497allocate_bignum_2(C_word c, C_word self, C_word bigvec)
1498{
1499  C_word ab[C_SIZEOF_STRUCTURE(2)], *a = ab, bignum,
1500         k = C_block_item(self, 1),
1501         negp = C_truep(C_block_item(self, 2)),
1502         size = C_bytestowords(C_header_size(bigvec))-1;
1503
1504  C_word tagvec = CHICKEN_gc_root_ref(tags);
1505
1506  C_set_block_item(bigvec, 0, negp ? C_BIGNUM_HEADER_SIGN_BIT | size : size);
1507
1508  bignum = C_structure(&a, 2, C_block_item(tagvec, BIG_TAG), bigvec);
1509  C_kontinue(k, bignum);
1510}
1511
1512/* Simplification: scan trailing zeroes, then return a fixnum if the
1513 * value fits, or trim the bignum's length. */
1514C_word C_ccall
1515C_bignum_simplify(C_word big)
1516{
1517  C_word *start = C_bignum_digits(big);
1518  C_word *last_digit = start + C_bignum_size(big) - 1;
1519  C_word *scan = last_digit, length;
1520
1521  while (scan >= start && *scan == 0)
1522    scan--;
1523  length = scan - start + 1;
1524 
1525  switch(length) {
1526  case 0:
1527    return C_fix(0);
1528  case 1:
1529    return C_fix(C_bignum_negativep(big) ? -*start : *start);
1530  case 2:
1531    if (C_bignum_negativep(big) && *scan == 1 && *start == 0)
1532      return C_fix(C_MOST_NEGATIVE_FIXNUM);
1533    /* FALLTHROUGH */
1534  default:
1535    if (scan < last_digit) {
1536      /* Mutate vector size of internal bignum vector. */
1537      C_block_header(C_internal_bignum(big)) = (C_STRING_TYPE | C_wordstobytes(length+1));
1538      /* Set internal header. */
1539      C_bignum_header(big) = (C_bignum_header(big) & C_BIGNUM_HEADER_SIGN_BIT) | length;
1540    }
1541    return big;
1542  }
1543}
1544
1545static C_word
1546bignum_digits_destructive_scale_up_with_carry(C_word *start, C_word *end, C_word factor, C_word carry)
1547{
1548  C_word digit, product_hi, product_lo, *scan = start;
1549
1550  assert(C_fitsinbignumhalfdigitp(carry));
1551
1552  while (scan < end) {
1553    digit = (*scan);
1554    product_lo = factor * C_BIGNUM_DIGIT_LO_HALF(digit) + carry;
1555    product_hi = factor * C_BIGNUM_DIGIT_HI_HALF(digit) +
1556            C_BIGNUM_DIGIT_HI_HALF(product_lo);
1557    (*scan++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(product_hi),
1558                                       C_BIGNUM_DIGIT_LO_HALF(product_lo));
1559    carry = C_BIGNUM_DIGIT_HI_HALF(product_hi);
1560  }
1561  return carry;
1562}
1563
1564/* Given (denominator > 1), it is fairly easy to show that
1565   quotient_high fits a bignum halfdigit, after which it is easy to
1566   see that all digits fit a bignum full digit.
1567   
1568   This works because denominator is known to fit a halfdigit, which
1569   means that the remainder modulo denominator will also fit a halfdigit. */
1570static C_word
1571bignum_digits_destructive_scale_down(C_word *start, C_word *end, C_word denominator)
1572{
1573  C_word numerator, remainder = 0, digit, quotient_high, *scan = end;
1574
1575  assert((denominator > 1) && C_fitsinbignumhalfdigitp(denominator));
1576  while (start <= scan) {
1577    digit = *scan;
1578    numerator = C_BIGNUM_DIGIT_COMBINE(remainder, C_BIGNUM_DIGIT_HI_HALF(digit));
1579    quotient_high = (numerator / denominator);
1580    numerator = C_BIGNUM_DIGIT_COMBINE(numerator % denominator,
1581                                       C_BIGNUM_DIGIT_LO_HALF(digit));
1582    (*scan--) = C_BIGNUM_DIGIT_COMBINE(quotient_high, numerator / denominator);
1583    remainder = numerator % denominator;
1584  }
1585  return remainder;
1586}
1587
1588void C_ccall
1589C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y)
1590{
1591  C_word ab[nmax(/*C_SIZEOF_FIX_BIGNUM, */ C_SIZEOF_FLONUM * 2,
1592                 C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM(4))],
1593         *a = ab;
1594
1595  if (x & C_FIXNUM_BIT) {
1596    if (y & C_FIXNUM_BIT) {
1597      C_kontinue(k, C_a_u_i_2_fixnum_times(&a, 2, x, y));
1598    } else if (C_immediatep(y)) {
1599      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
1600    } else if (C_block_header(y) == C_FLONUM_TAG) {
1601      C_kontinue(k, C_flonum(&a, (double)C_unfix(x) * C_flonum_magnitude(y)));
1602    } else if (C_IS_BIGNUM_TYPE(y)) {
1603      C_u_2_integer_times(4, (C_word)NULL, k, x, y);
1604    } else {
1605      try_extended_number("numbers#@extended-2-times", 3, k, x, y);
1606    }
1607  } else if (C_immediatep(x)) {
1608    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);
1609  } else if (C_block_header(x) == C_FLONUM_TAG) {
1610    if (y & C_FIXNUM_BIT) {
1611      C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) * (double)C_unfix(y)));
1612    } else if (C_immediatep(y)) {
1613      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
1614    } else if (C_block_header(y) == C_FLONUM_TAG) {
1615      C_kontinue(k, C_a_i_flonum_times(&a, 2, x, y));
1616    } else if (C_IS_BIGNUM_TYPE(y)) {
1617      C_kontinue(k, C_a_i_flonum_times(&a, 2, x, C_a_u_i_big_to_flo(&a, 1, y)));
1618    } else {
1619      try_extended_number("numbers#@extended-2-times", 3, k, x, y);
1620    }
1621  } else if (C_IS_BIGNUM_TYPE(x)) {
1622    if (y & C_FIXNUM_BIT) {
1623      C_u_2_integer_times(4, (C_word)NULL, k, x, y);
1624    } else if (C_immediatep(y)) {
1625      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);
1626    } else if (C_block_header(y) == C_FLONUM_TAG) {
1627      C_kontinue(k, C_a_i_flonum_times(&a, 2, C_a_u_i_big_to_flo(&a, 1, x), y));
1628    } else if (C_IS_BIGNUM_TYPE(y)) {
1629      C_u_2_bignum_times(4, (C_word)NULL, k, x, y);
1630    } else {
1631      try_extended_number("numbers#@extended-2-times", 3, k, x, y);
1632    }
1633  } else {
1634    try_extended_number("numbers#@extended-2-times", 3, k, x, y);
1635  }
1636}
1637
1638/* XXX TODO: Rework to allocate C_SIZEOF_BIGNUM(4)?  Not worth the hassle? */
1639/* Needs at most 2 * SIZEOF_FIX_BIGNUM + SIZEOF_BIGNUM(4) */
1640C_regparm C_word C_fcall
1641C_a_u_i_2_fixnum_times(C_word **ptr, C_word n, C_word x, C_word y)
1642{
1643  C_word absx, absy, negp, *d, r;
1644
1645  /* We don't strictly need the abses in all branches... */
1646  absx = C_unfix(x);
1647  absx = absx < 0 ? -absx : absx;
1648  absy = C_unfix(y);
1649  absy = absy < 0 ? -absy : absy;
1650  negp = ((x & C_INT_SIGN_BIT) ? !(y & C_INT_SIGN_BIT) : (y & C_INT_SIGN_BIT));
1651
1652  if (C_fitsinbignumhalfdigitp(absx)) {
1653     if (x == C_fix(0) || x == C_fix(1) || C_fitsinbignumhalfdigitp(absy)) {
1654       return C_fix(negp ? -(absx * absy) : (absx * absy));
1655     } else {
1656       if (y == C_fix(C_MOST_NEGATIVE_FIXNUM)) {
1657         y = C_bignum2(ptr, negp != 0, 0, 1); /* Two is always enough */
1658       } else {
1659         y = C_bignum2(ptr, negp != 0, absy, 0); /* May need one for carry */
1660       }
1661       d = C_bignum_digits(y);
1662       r = bignum_digits_destructive_scale_up_with_carry(d, d+2, absx, 0);
1663       assert(r == 0); /* Should never result in a carry; y is big enough */
1664       return C_bignum_simplify(y);
1665     }
1666  } else if (C_fitsinbignumhalfdigitp(absy)) {
1667     if (absy == 0 || y == C_fix(1) /*|| C_fitsinbignumhalfdigitp(absx) */) {
1668       return C_fix(negp ? -(absx * absy) : (absx * absy));
1669     } else {
1670       if (x == C_fix(C_MOST_NEGATIVE_FIXNUM)) {
1671         x = C_bignum2(ptr, negp != 0, 0, 1); /* Two is always enough */
1672       } else {
1673         x = C_bignum2(ptr, negp != 0, absx, 0); /* May need one for carry */
1674       }
1675       d = C_bignum_digits(x);
1676       r = bignum_digits_destructive_scale_up_with_carry(d, d+2, absy, 0);
1677       assert(r == 0); /* Should never result in a carry; x is big enough */
1678       return C_bignum_simplify(x);
1679     }
1680  } else {
1681    x = C_a_u_i_fix_to_big(ptr, x);
1682    y = C_a_u_i_fix_to_big(ptr, y);
1683    r = C_bignum4(ptr, negp != 0, 0, 0, 0, 0);
1684    bignum_digits_multiply(x, y, r);
1685    return C_bignum_simplify(r);
1686  }
1687}
1688
1689void C_ccall
1690C_u_2_integer_times(C_word c, C_word self, C_word k, C_word x, C_word y)
1691{
1692  C_word ab[nmax(/* C_SIZEOF_FIX_BIGNUM, */ C_SIZEOF_CLOSURE(4),
1693                 C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM(4))],
1694         *a = ab, absy, negp, size, k2;
1695
1696  if (x & C_FIXNUM_BIT) {
1697    if (y & C_FIXNUM_BIT) {
1698      C_kontinue(k, C_a_u_i_2_fixnum_times(&a, 2, x, y));
1699    } else {
1700      absy = x; /* swap to ensure x is a bignum and y a fixnum */
1701      x = y;
1702      y = absy;
1703    }
1704  }
1705  /* Here, we know for sure that X is a bignum */
1706  if (y & C_FIXNUM_BIT) {
1707    absy = C_unfix(y);
1708    absy = absy < 0 ? -absy : absy;
1709    negp = C_mk_bool((y & C_INT_SIGN_BIT) ?
1710                     !C_bignum_negativep(x) :
1711                     C_bignum_negativep(x));
1712 
1713    if (C_fitsinbignumhalfdigitp(absy)) {
1714      k2 = C_closure(&a, 4, (C_word)integer_times_2, k, x, C_fix(absy));
1715      size = C_fix(C_bignum_size(x) + 1); /* Needs _at most_ one more digit */
1716      C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
1717    } else {
1718      y = C_a_u_i_fix_to_big(&a, y);
1719      bignum_times_bignum_unsigned(k, x, y, negp);
1720    }
1721  } else {
1722    C_u_2_bignum_times(4, (C_word)NULL, k, x, y);
1723  }
1724}
1725
1726static void
1727integer_times_2(C_word c, C_word self, C_word new_big)
1728{
1729  C_word k = C_block_item(self, 1),
1730         old_bigx = C_block_item(self, 2),
1731         fixy = C_block_item(self, 3),
1732         *digits = C_bignum_digits(new_big),
1733         *end_digit = digits + C_bignum_size(old_bigx);
1734
1735  bignum_digits_destructive_copy(new_big, old_bigx);
1736
1737  /* Scale up, and sanitise the result. */
1738  *end_digit = bignum_digits_destructive_scale_up_with_carry(digits, end_digit,
1739                                                             C_unfix(fixy), 0);
1740  C_kontinue(k, C_bignum_simplify(new_big));
1741}
1742
1743void C_ccall
1744C_u_2_bignum_times(C_word c, C_word self, C_word k, C_word x, C_word y)
1745{
1746  C_word negp = C_bignum_negativep(x) ?
1747                !C_bignum_negativep(y) :
1748                C_bignum_negativep(y);
1749  bignum_times_bignum_unsigned(k, x, y, C_mk_bool(negp));
1750}
1751
1752/* Multiplication
1753   Maximum value for product_lo or product_hi:
1754        ((R * R) + (R * (R - 2)) + (R - 1))
1755   Maximum value for carry: ((R * (R - 1)) + (R - 1))
1756        where R == 2^HALF_DIGIT_LENGTH */
1757static void
1758bignum_times_bignum_unsigned(C_word k, C_word x, C_word y, C_word negp)
1759{
1760  C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, k2, size;
1761 
1762  if (C_bignum_size(y) > C_bignum_size(x)) { /* Ensure size(x) <= size(y) */
1763    C_word z = x;
1764    x = y;
1765    y = z;
1766  }
1767
1768  k2 = C_closure(&ka, 4, (C_word)bignum_times_bignum_unsigned_2, k, x, y);
1769
1770  size = C_fix(C_bignum_size(x) + C_bignum_size(y));
1771  C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_TRUE);
1772}
1773
1774static C_regparm void
1775bignum_digits_multiply(C_word x, C_word y, C_word result)
1776{
1777  C_word carry, y_digit_lo, y_digit_hi, x_digit_lo,
1778         x_digit_hi, product_lo, *scan_r, *scan_y,
1779         x_digit, y_digit, product_hi,
1780         *scan_x = C_bignum_digits(x),
1781         *end_x = scan_x + C_bignum_size(x),
1782         *start_y = C_bignum_digits(y),
1783         *end_y = start_y + C_bignum_size(y),
1784         *start_r = C_bignum_digits(result);
1785
1786  while (scan_x < end_x) {
1787    x_digit = (*scan_x++);
1788    x_digit_lo = C_BIGNUM_DIGIT_LO_HALF(x_digit);
1789    x_digit_hi = C_BIGNUM_DIGIT_HI_HALF(x_digit);
1790    carry = 0;
1791    scan_y = start_y;
1792    scan_r = (start_r++);
1793
1794    while (scan_y < end_y) {
1795      y_digit = (*scan_y++);
1796      y_digit_lo = C_BIGNUM_DIGIT_LO_HALF(y_digit);
1797      y_digit_hi = C_BIGNUM_DIGIT_HI_HALF(y_digit);
1798
1799      product_lo = (*scan_r) +
1800                   x_digit_lo * y_digit_lo +
1801                   C_BIGNUM_DIGIT_LO_HALF(carry);
1802
1803      product_hi = x_digit_hi * y_digit_lo +
1804                   x_digit_lo * y_digit_hi +
1805                   C_BIGNUM_DIGIT_HI_HALF(product_lo) +
1806                   C_BIGNUM_DIGIT_HI_HALF(carry);
1807
1808      (*scan_r++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(product_hi),
1809                                           C_BIGNUM_DIGIT_LO_HALF(product_lo));
1810
1811      carry = x_digit_hi * y_digit_hi + C_BIGNUM_DIGIT_HI_HALF(product_hi);
1812    }
1813    (*scan_r) += carry;
1814  }
1815}
1816
1817static void
1818bignum_times_bignum_unsigned_2(C_word c, C_word self, C_word result)
1819{
1820  C_word k = C_block_item(self, 1),
1821         x = C_block_item(self, 2),
1822         y = C_block_item(self, 3);
1823
1824  bignum_digits_multiply(x, y, result);
1825  C_kontinue(k, C_bignum_simplify(result));
1826}
1827
1828void C_ccall
1829C_digits_to_integer(C_word c, C_word self, C_word k, C_word str,
1830                    C_word start, C_word end, C_word radix, C_word negp)
1831{
1832  C_word kab[C_SIZEOF_CLOSURE(6)], *ka = kab, k2, size;
1833  size_t nbits;
1834
1835  assert((C_unfix(radix) > 1) && C_fitsinbignumhalfdigitp(C_unfix(radix)));
1836 
1837  if (start == end) {
1838    C_kontinue(k, C_SCHEME_FALSE);
1839  } else {
1840    k2 = C_closure(&ka, 6, (C_word)digits_to_integer_2, k, str, start, end, radix);
1841 
1842    nbits = (C_unfix(end) - C_unfix(start)) * C_ilen(C_unfix(radix));
1843    size = C_fix(C_BIGNUM_BITS_TO_DIGITS(nbits));
1844    /* XXX: Why initialize? */
1845    C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_TRUE);
1846  }
1847}
1848
1849/* XXX TODO: This should be faster, dammit! */
1850static void
1851digits_to_integer_2(C_word c, C_word self, C_word result)
1852{
1853  C_word k = C_block_item(self, 1),
1854         str = C_block_item(self, 2),
1855         start = C_unfix(C_block_item(self, 3)),
1856         end = C_unfix(C_block_item(self, 4)),
1857         radix = C_unfix(C_block_item(self, 5)),
1858         *digits = C_bignum_digits(result),
1859         *last_digit = digits, /* Initially, bignum is all zeroes */
1860         big_digit = 0, factor = radix,
1861         next_big_digit, next_factor,
1862         carry, str_digit;
1863  char *str_scan = C_c_string(str) + start,
1864       *str_end = C_c_string(str) + end;
1865
1866  /* Hash characters in numbers are mapped to 0 */
1867# define HEXDIGIT_CHAR_TO_INT(x)                                        \
1868    (((x) == '#') ? 0 :                                                 \
1869     (((x) >= (int)'a') ? ((x) - (int)'a' + 10) : ((x) - (int)'0')))
1870
1871  /* This tries to save up as much as possible in the local C_word
1872   * big_digit, and only when it exceeds what we would be able to
1873   * multiply easily, we scale up the bignum and add what we saved up.
1874   */
1875  while (str_scan < str_end) {
1876    str_digit = HEXDIGIT_CHAR_TO_INT(C_tolower((int)*str_scan));
1877    str_scan++;
1878
1879    next_big_digit = big_digit * radix;
1880    next_big_digit += str_digit;
1881    next_factor = factor * radix;
1882
1883    if (str_digit >= radix || str_digit < 0) {
1884      C_kontinue(k, C_SCHEME_FALSE);
1885    } else if (C_fitsinbignumhalfdigitp(next_big_digit) &&
1886               C_fitsinbignumhalfdigitp(next_factor)) {
1887      factor = next_factor;
1888      big_digit = next_big_digit;
1889    } else {
1890      carry = bignum_digits_destructive_scale_up_with_carry(
1891              digits, last_digit, factor, big_digit);
1892
1893      if (carry) (*last_digit++) = carry; /* Move end */
1894
1895      big_digit = str_digit;
1896      factor = radix;
1897    }
1898  }
1899# undef HEXDIGIT_CHAR_TO_INT
1900
1901  /* Final step.  We always must do this, because the loop never
1902   * processes the "current" character into the bignum (lookahead 1).
1903   */
1904  carry = bignum_digits_destructive_scale_up_with_carry(
1905          digits, last_digit, factor, big_digit);
1906  if (carry) (*last_digit++) = carry; /* Move end */
1907
1908  C_kontinue(k, C_bignum_simplify(result));
1909}
1910
1911/* TODO: Copied from runtime.c */
1912# define STRING_BUFFER_SIZE   4096
1913
1914static C_TLS C_char buffer[ STRING_BUFFER_SIZE ];
1915static char *to_n_nary(C_uword num, C_uword base)
1916{
1917  static char *digits = "0123456789ABCDEF";
1918  char *p;
1919  buffer [ 66 ] = '\0';
1920  p = buffer + 66;
1921
1922  do {
1923    *(--p) = digits [ num % base ];
1924    num /= base;
1925  } while (num);
1926
1927  return p;
1928}
1929
1930void C_ccall C_basic_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...)
1931{
1932  C_word radix;
1933
1934  if(c == 3) {
1935    radix = C_fix(10);
1936  } else if(c == 4) {
1937    va_list v;
1938
1939    va_start(v, num);
1940    radix = va_arg(v, C_word);
1941    va_end(v);
1942   
1943    if(!(radix & C_FIXNUM_BIT))
1944      barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);
1945  } else {
1946    C_bad_argc(c, 3);
1947  }
1948
1949  if(num & C_FIXNUM_BIT) {
1950    C_u_fixnum_to_string(4, (C_word)NULL, k, num, radix);
1951  } else if (C_immediatep(num)) {
1952    barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);
1953  } else if(C_block_header(num) == C_FLONUM_TAG) {
1954    C_u_flonum_to_string(4, (C_word)NULL, k, num, radix);
1955  } else if (C_IS_BIGNUM_TYPE(num)) {
1956    C_u_bignum_to_string(4, (C_word)NULL, k, num, radix);
1957  } else {
1958    try_extended_number("numbers#@extended-number->string", 3, k, num, radix);
1959  }
1960}
1961
1962/* Naming is a little inconsistent, but looks saner.  We're not R-O-B-O-T-S! */
1963void C_ccall
1964C_u_integer_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix)
1965{
1966  /* Trivial to the point of stupidity? */
1967  if (num & C_FIXNUM_BIT)
1968    C_u_fixnum_to_string(4, (C_word)NULL, k, num, radix);
1969  else
1970    C_u_bignum_to_string(4, (C_word)NULL, k, num, radix);
1971}
1972
1973/* Should we get rid of C_fixnum_to_string? */
1974void C_ccall
1975C_u_fixnum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix)
1976{
1977  C_word *a, neg = 0;
1978  C_char *p;
1979
1980  num = C_unfix(num);
1981  radix = C_unfix(radix);
1982
1983  if((radix < 2) || (radix > 16)){
1984    barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
1985  }
1986
1987  if(num < 0) {
1988    neg = 1;
1989    num = -num; /* snprintf's %x and %o always interpret number as unsigned */
1990  }
1991
1992  switch(radix) {
1993#ifdef C_SIXTY_FOUR
1994  case 8: C_snprintf(p = buffer + 1, sizeof(buffer) -1 , C_text("%llo"), (long long)num); break;
1995  case 10: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%lld"), (long long)num); break;
1996  case 16: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%llx"), (long long)num); break;
1997#else
1998  case 8: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%o"), num); break;
1999  case 10: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%d"), num); break;
2000  case 16: C_snprintf(p = buffer + 1, sizeof(buffer) - 1, C_text("%x"), num); break;
2001#endif
2002  default: 
2003    p = to_n_nary(num, radix);
2004  }
2005
2006  if(neg) *(--p) = '-';
2007
2008  radix = C_strlen(p);
2009  a = C_alloc((C_bytestowords(radix) + 1));
2010  radix = C_string(&a, radix, p);
2011  C_kontinue(k, radix);
2012}
2013
2014void C_ccall
2015C_u_flonum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix)
2016{
2017  C_word *a, neg = 0;
2018  C_char *p;
2019  double f;
2020
2021  radix = C_unfix(radix);
2022  f = C_flonum_magnitude(num);
2023
2024  /* XXX TODO: Should inexacts be printable in other bases than 10?
2025   * Perhaps output a string starting with #i?
2026   * Right now something like (number->string 1e40 16) results in
2027   * a string that can't be read back using string->number.
2028   */
2029  if((radix < 2) || (radix > 16)){
2030    barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
2031  }
2032
2033  if(C_fits_in_unsigned_int_p(num) == C_SCHEME_TRUE) {
2034    if(f < 0) {
2035      neg = 1;
2036      f = -f;
2037    }
2038
2039    switch(radix) {
2040    case 8:
2041      C_snprintf(p = buffer, sizeof(buffer), "%o", (unsigned int)f);
2042      goto fini;
2043
2044    case 16:
2045      C_snprintf(p = buffer, sizeof(buffer), "%x", (unsigned int)f);
2046      goto fini;
2047
2048    case 10: break;           /* force output of decimal point to retain
2049                                 read/write invariance (the little we support) */
2050
2051    default:
2052      p = to_n_nary((unsigned int)f, radix);
2053      goto fini;
2054    }
2055  } 
2056
2057  if(C_isnan(f)) {
2058    /* XXX Back-compat support for CHICKENS older than 4.9.0 */
2059#if defined(HAVE_STRLCPY) || !defined(C_strcpy)
2060    C_strlcpy(buffer, C_text("+nan.0"), sizeof(buffer));
2061#else
2062    C_strcpy(p = buffer, "+nan.0");
2063#endif
2064    p = buffer;
2065    goto fini;
2066  } else if(C_isinf(f)) {
2067    C_snprintf(buffer, sizeof(buffer), "%cinf.0", f > 0 ? '+' : '-');
2068    p = buffer;
2069    goto fini;
2070  }
2071
2072  C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("%.*g"),
2073             /* XXX: flonum_print_precision */
2074               (int)C_unfix(C_get_print_precision()), f);
2075  buffer[STRING_BUFFER_SIZE-1] = '\0';
2076
2077  if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {
2078    if(*buffer == 'i' || *buffer == 'n') { /* inf or nan */
2079        C_memmove(buffer + 1, buffer, C_strlen(buffer) + 1);
2080        *buffer = '+';
2081    }
2082#if defined(HAVE_STRLCAT) || !defined(C_strcat)
2083    else if(buffer[ 1 ] != 'i') C_strlcat(buffer, C_text(".0"), sizeof(buffer)); /* negative infinity? */
2084#else
2085    else if(buffer[ 1 ] != 'i') C_strcat(buffer, C_text(".0")); /* negative infinity? */
2086#endif
2087  }
2088
2089  p = buffer;
2090
2091 fini:
2092  if(neg) *(--p) = '-';
2093
2094  radix = C_strlen(p);
2095  a = C_alloc((C_bytestowords(radix) + 1));
2096  radix = C_string(&a, radix, p);
2097  C_kontinue(k, radix);
2098}
2099
2100void C_ccall
2101C_u_bignum_to_string(C_word c, C_word self, C_word k, C_word num, C_word radix)
2102{
2103  /* This copies the bignum over into a working copy that can be mutated. */
2104  C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, k2, size,
2105         negp = C_mk_bool(C_bignum_negativep(num));
2106
2107  if((C_unfix(radix) < 2) || (C_unfix(radix) > 16)){
2108    barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);
2109  }
2110
2111  k2 = C_closure(&ka, 4, (C_word)bignum_to_digits_2, k, num, radix);
2112
2113  size = C_fix(C_bignum_size(num));
2114  C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
2115}
2116
2117static void
2118bignum_to_digits_2(C_word c, C_word self, C_word working_copy)
2119{
2120  C_word k = C_block_item(self, 1),
2121         old_big = C_block_item(self, 2),
2122         radix = C_unfix(C_block_item(self, 3)),
2123         len;
2124
2125  bignum_digits_destructive_copy(working_copy, old_big);
2126
2127  /* Approximation of the number of radix digits we'll need.  We try
2128   * to be as precise as possible to avoid memmove overhead at the end
2129   * of the conversion procedure, which we may need to do because we
2130   * write strings back-to-front, and pointers must be aligned (even
2131   * for byte blocks).
2132   */
2133  len = C_ilen(radix)-1; /* Is this right? */
2134  len = (C_unfix(C_u_i_bignum_length(old_big)) + len/2) / len
2135          + (C_bignum_negativep(old_big) ? 1 : 0);
2136
2137  /* Nice: We can recycle the current closure */
2138  C_set_block_item(self, 0, (C_word)bignum_to_digits_3);
2139  /* item 1 is still the same continuation */
2140  C_set_block_item(self, 2, working_copy);
2141
2142  C_allocate_vector(6, (C_word)NULL, self, C_fix(len),
2143                    /* Byte vec, no initialization, align at 8 bytes */
2144                    C_SCHEME_TRUE, C_SCHEME_FALSE, C_SCHEME_FALSE);
2145}
2146
2147/* XXX TODO: This should be MUCH faster, dammit! */
2148static void
2149bignum_to_digits_3(C_word c, C_word self, C_word string)
2150{
2151  static char *characters = "0123456789abcdef";
2152  C_word k = C_block_item(self, 1),
2153         working_copy = C_block_item(self, 2),
2154         radix = C_unfix(C_block_item(self, 3)),
2155         *start = C_bignum_digits(working_copy),
2156         *scan = start + C_bignum_size(working_copy) - 1,
2157         len = C_header_size(string)+(C_bignum_negativep(working_copy) ? 1 : 0),
2158         digit, steps, i, base;
2159  char *buf = C_c_string(string), *index = buf + C_header_size(string) - 1;
2160
2161  /* Calculate the largest power of radix that fits a halfdigit:
2162   * steps = log10(2^halfdigit_bits), base = 10^steps
2163   */
2164  for(steps = 0, base = radix; C_fitsinbignumhalfdigitp(base); base *= radix)
2165    steps++;
2166
2167  base /= radix; /* Back down: we overshot in the loop */
2168
2169  while (start <= scan) {
2170    digit = bignum_digits_destructive_scale_down(start, scan, base);
2171
2172    if (*scan == 0) scan--; /* Adjust if we exhausted the highest digit */
2173
2174    for(i = 0; i < steps && index >= buf; ++i) {
2175      *index-- = characters[digit % radix];
2176      digit /= radix;
2177    }
2178  }
2179  assert(index >= buf-1);
2180
2181  /* Move index onto first nonzero digit.  We're writing a bignum
2182     here: it can't consist of only zeroes. */
2183  while(*++index == '0');
2184
2185  if (C_bignum_negativep(working_copy))
2186    *--index = '-';
2187
2188  /* Shorten with distance between start and index. */
2189  len = C_header_size(string) - (index - buf);
2190  if (buf != index) {
2191    C_memmove(buf, index, len); /* Move start of number to begin of string. */
2192    C_block_header(string) = C_STRING_TYPE | len; /* Mutate string length. */
2193  }
2194  C_kontinue(k, string);
2195}
2196
2197C_regparm double C_bignum_to_double(C_word bignum)
2198{
2199  double accumulator = 0;
2200  C_word *start = C_bignum_digits(bignum);
2201  C_word *scan = start + C_bignum_size(bignum);
2202  while (start < scan) {
2203    accumulator *= (C_word)1 << C_BIGNUM_DIGIT_LENGTH;
2204    accumulator += (*--scan);
2205  }
2206  return(C_bignum_negativep(bignum) ? -accumulator : accumulator);
2207}
2208
2209void C_ccall
2210C_u_flo_to_int(C_word c, C_word self, C_word k, C_word loc, C_word x)
2211{
2212  int exponent;
2213  double significand = frexp(C_flonum_magnitude(x), &exponent);
2214
2215  if (!C_truep(C_u_i_fpintegerp(x))) { /* Calling frexp first is okay */
2216    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), x);
2217  } else if (exponent <= 0) {
2218    C_kontinue(k, C_fix(0));
2219  } else if (exponent == 1) { /* TODO: check significand * 2^exp fits fixnum? */
2220    C_kontinue(k, significand < 0.0 ? C_fix(-1) : C_fix(1));
2221  } else {
2222    C_word kab[C_SIZEOF_CLOSURE(4) + C_SIZEOF_FLONUM], *ka = kab, k2, size,
2223           negp = C_mk_bool(C_flonum_magnitude(x) < 0.0),
2224           sign = C_flonum(&ka, fabs(significand));
2225
2226    k2 = C_closure(&ka, 4, (C_word)flo_to_int_2, k, C_fix(exponent), sign);
2227
2228    size = C_fix(C_BIGNUM_BITS_TO_DIGITS(exponent));
2229    C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
2230  }
2231}
2232
2233static void
2234flo_to_int_2(C_word c, C_word self, C_word result)
2235{
2236  C_word digit, k = C_block_item(self, 1),
2237         exponent = C_unfix(C_block_item(self, 2)),
2238         odd_bits = exponent % C_BIGNUM_DIGIT_LENGTH,
2239         *start = C_bignum_digits(result),
2240         *scan = start + C_bignum_size(result);
2241  /* It's always true that 0.5 <= s < 1 */
2242  double significand = C_flonum_magnitude(C_block_item(self, 3));
2243
2244  if (odd_bits > 0) { /* Handle most significant digit first */
2245    significand *= (C_word)1 << odd_bits;
2246    digit = (C_word)significand;
2247    (*--scan) = digit;
2248    significand -= (double)digit;
2249  }
2250
2251  while (start < scan && significand > 0) {
2252    significand *= (C_word)1 << C_BIGNUM_DIGIT_LENGTH;
2253    digit = (C_word)significand;
2254    (*--scan) = digit;
2255    significand -= (double)digit;
2256  }
2257
2258  /* Finish up by clearing any remaining, lower, digits */
2259  while (start < scan)
2260    (*--scan) = 0;
2261
2262  C_kontinue(k, C_bignum_simplify(result));
2263}
2264
2265C_word C_ccall
2266C_u_i_integer_length(C_word x)
2267{
2268  if (x & C_FIXNUM_BIT) return C_u_i_fixnum_length(x);
2269  else return C_u_i_bignum_length(x);
2270}
2271
2272C_word C_ccall
2273C_u_i_bignum_length(C_word x)
2274{
2275    C_word len_1 = C_bignum_size(x) - 1,
2276           result = len_1 * C_BIGNUM_DIGIT_LENGTH,
2277           *startx = C_bignum_digits(x),
2278           *last_digit = C_bignum_digits(x) + len_1,
2279           last_digit_length = C_ilen(*last_digit);
2280
2281    /* If *only* the highest bit is set, negating results in one less bit */
2282    if (C_bignum_negativep(x) && *last_digit == (1 << (last_digit_length-1))) {
2283      while(startx < last_digit && *startx == 0) ++startx;
2284      if (startx == last_digit) result--;
2285    }
2286    return C_fix(result + last_digit_length);
2287}
2288
2289void C_ccall /* x is any exact integer but y is _always_ a fixnum */
2290C_u_integer_shift(C_word c, C_word self, C_word k, C_word x, C_word y)
2291{
2292  C_word kab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_CLOSURE(3) + C_SIZEOF_CLOSURE(2)],
2293         *ka = kab, k2, k3, minus1;
2294
2295  if (y == C_fix(0) || x == C_fix(0)) { /* Done (no shift) */
2296    C_kontinue(k, x);
2297  } else if (x & C_FIXNUM_BIT) {
2298    if (C_unfix(y) < 0) {
2299      /* Don't shift more than a word's length (that's undefined in C!) */
2300      if (-C_unfix(y) < C_WORD_SIZE) {
2301        C_kontinue(k, C_fix(C_unfix(x) >> -C_unfix(y)));
2302      } else {
2303        C_kontinue(k, (x & C_INT_SIGN_BIT) ? C_fix(-1) : C_fix(0));
2304      }
2305    } else if (C_unfix(y) > 0 && C_unfix(y) < C_WORD_SIZE-2 &&
2306               /* After shifting, the length should still fit a fixnum */
2307               (C_ilen(C_unfix(x)) + C_unfix(y)) < C_WORD_SIZE-2) {
2308      C_kontinue(k, C_fix(C_unfix(x) << C_unfix(y)));
2309    } else {
2310      x = C_a_u_i_fix_to_big(&ka, x);
2311    }
2312  }
2313
2314  /* Invert all the bits before shifting right a negative value */
2315  if (C_bignum_negativep(x) && C_unfix(y) < 0) {
2316    /* When done shifting, invert again */
2317    k3 = C_closure(&ka, 2, (C_word)bignum_negate_after_shift, k);
2318    /* Before shifting, allocate the bignum */
2319    k2 = C_closure(&ka, 3, (C_word)bignum_allocate_for_shift, k3, y);
2320    /* Actually invert by subtracting: -1 - x */
2321    minus1 = C_a_u_i_fix_to_big(&ka, C_fix(-1));
2322    C_u_2_bignum_minus(4, (C_word)NULL, k2, minus1, x);
2323  } else {
2324    k2 = C_closure(&ka, 3, (C_word)bignum_allocate_for_shift, k, y);
2325    C_kontinue(k2, x);
2326  }
2327}
2328
2329static void
2330bignum_allocate_for_shift(C_word c, C_word self, C_word x)
2331{
2332  C_word k = C_block_item(self, 1),
2333         y = C_block_item(self, 2),
2334         uy = C_unfix(y),
2335         negp, digit_offset, bit_offset,
2336         ab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_CLOSURE(6)], *a = ab, k2, size;
2337
2338  if (x & C_FIXNUM_BIT) /* Normalisation may happen after negation */
2339    x = C_a_u_i_fix_to_big(&a, x);
2340
2341  negp = C_mk_bool(C_bignum_negativep(x));
2342 
2343  /* uy is guaranteed not to be 0 here */
2344  if (uy > 0) {
2345    digit_offset = uy / C_BIGNUM_DIGIT_LENGTH;
2346    bit_offset =   uy % C_BIGNUM_DIGIT_LENGTH;
2347
2348    k2 = C_closure(&a, 6, (C_word)bignum_actual_shift, k,
2349                   x, C_SCHEME_TRUE, C_fix(digit_offset), C_fix(bit_offset));
2350    size = C_fix(C_bignum_size(x) + digit_offset + 1);
2351    C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_TRUE);
2352  } else if (-uy >= C_bignum_size(x) * (C_word)C_BIGNUM_DIGIT_LENGTH) {
2353    /* All bits are shifted out, just return 0 */
2354    C_kontinue(k, C_fix(0));
2355  } else {
2356    digit_offset = -uy / C_BIGNUM_DIGIT_LENGTH;
2357    bit_offset =   -uy % C_BIGNUM_DIGIT_LENGTH;
2358   
2359    k2 = C_closure(&a, 6, (C_word)bignum_actual_shift, k,
2360                   x, C_SCHEME_FALSE, C_fix(digit_offset), C_fix(bit_offset));
2361    size = C_fix(C_bignum_size(x) - digit_offset);
2362    C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_TRUE);
2363  }
2364}
2365
2366static void
2367bignum_negate_after_shift(C_word c, C_word self, C_word result)
2368{
2369  C_word k = C_block_item(self, 1);
2370  if (result & C_FIXNUM_BIT) { /* Normalisation may happen after shift */
2371    C_kontinue(k, C_fix(-1 - C_unfix(result)));
2372  } else {
2373    C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, minus1;
2374    minus1 = C_a_u_i_fix_to_big(&a, C_fix(-1));
2375    C_u_2_bignum_minus(4, (C_word)NULL, k, minus1, result);
2376  }
2377}
2378
2379static void
2380bignum_actual_shift(C_word c, C_word self, C_word result)
2381{
2382  C_word k = C_block_item(self, 1),
2383         x = C_block_item(self, 2),
2384         shift_left = C_truep(C_block_item(self, 3)),
2385         digit_offset = C_unfix(C_block_item(self, 4)),
2386         bit_offset = C_unfix(C_block_item(self, 5)),
2387         *scanx, *scanr, *end;
2388
2389  if (shift_left) {
2390    scanr = C_bignum_digits(result) + digit_offset;
2391    scanx = C_bignum_digits(x);
2392    end = scanx + C_bignum_size(x);
2393   
2394    while (scanx < end) {
2395      *scanr = *scanr | (*scanx & C_BIGNUM_DIGIT_MASK) << bit_offset;
2396      *scanr = *scanr & C_BIGNUM_DIGIT_MASK;
2397      scanr++;
2398      *scanr = *scanx++ >> (C_BIGNUM_DIGIT_LENGTH - bit_offset);
2399      *scanr = *scanr & C_BIGNUM_DIGIT_MASK;
2400    }
2401  } else {
2402    scanr = C_bignum_digits(result);
2403    scanx = C_bignum_digits(x) + digit_offset;
2404    end = scanr + C_bignum_size(result) - 1;
2405   
2406    while (scanr < end) {
2407      *scanr =  (*scanx++ & C_BIGNUM_DIGIT_MASK) >> bit_offset;
2408      *scanr = (*scanr | 
2409        *scanx << (C_BIGNUM_DIGIT_LENGTH - bit_offset)) & C_BIGNUM_DIGIT_MASK;
2410      scanr++;
2411    }
2412    *scanr =  (*scanx++ & C_BIGNUM_DIGIT_MASK) >> bit_offset;
2413  }
2414  C_kontinue(k, C_bignum_simplify(result));
2415}
2416
2417C_regparm C_word C_ccall C_u_i_integer_randomize(C_word seed)
2418{
2419  /* TODO: Rename C_randomize to C_u_i_fixnum_randomize */
2420  if (seed & C_FIXNUM_BIT) return C_randomize(seed);
2421  else return C_u_i_bignum_randomize(seed);
2422}
2423
2424/*
2425 * This random number generator is very simple. Probably too simple...
2426 */
2427C_word C_ccall
2428C_u_i_bignum_randomize(C_word bignum)
2429{
2430  C_word seed = 0,
2431         *scan = C_bignum_digits(bignum),
2432         *end = scan + C_bignum_size(bignum);
2433
2434  /* What a cheap way to initialize the random generator. I feel dirty! */
2435  while (scan < end)
2436    seed ^= *scan++;
2437
2438  srand(seed);
2439  return C_SCHEME_UNDEFINED;
2440}
2441
2442void C_ccall
2443C_u_integer_random(C_word c, C_word self, C_word k, C_word max)
2444{
2445  /* TODO: for consistency C_random_fixnum should be called C_u_i_fixnum_random */
2446  if (max & C_FIXNUM_BIT) C_kontinue(k, C_random_fixnum(max));
2447  else C_u_bignum_random(3, (C_word)NULL, k, max);
2448}
2449
2450void C_ccall
2451C_u_bignum_random(C_word c, C_word self, C_word k, C_word max)
2452{
2453  C_word k2, kab[C_SIZEOF_CLOSURE(4)], *ka = kab, size,
2454         max_len, max_bits, max_top_digit, d, negp;
2455
2456  max_len = C_bignum_size(max);
2457  max_top_digit = d = C_bignum_digits(max)[max_len - 1];
2458 
2459  max_bits = (max_len - 1) * C_BIGNUM_DIGIT_LENGTH;
2460  while(d) {
2461    max_bits++;
2462    d >>= 1;
2463  }
2464  /* Subtract/add one because we don't want zero to be over-represented */
2465  size = ((double)rand())/(RAND_MAX + 1.0) * (double)(max_bits - 1);
2466  size = C_fix(C_BIGNUM_BITS_TO_DIGITS(size + 1));
2467
2468  negp = C_mk_bool(C_bignum_negativep(max));
2469  k2 = C_closure(&ka, 4, (C_word)bignum_random_2, k, C_fix(max_top_digit), C_fix(max_len));
2470  C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
2471}
2472
2473static void
2474bignum_random_2(C_word c, C_word self, C_word result)
2475{
2476  C_word k = C_block_item(self, 1),
2477         max_top_digit = C_unfix(C_block_item(self, 2)),
2478         max_len = C_unfix(C_block_item(self, 3)),
2479         *scan = C_bignum_digits(result),
2480         *end = scan + C_bignum_size(result); /* Go to just before the end. */
2481
2482  while(scan < end)
2483    *scan++ = ((double)rand())/(RAND_MAX + 1.0) * (double)((C_word)1 << C_BIGNUM_DIGIT_LENGTH);
2484  /*
2485   * Last word is special when length is max_len: It must be less than
2486   * max's most significant digit, instead of BIGNUM_RADIX.
2487   */
2488  if (max_len == C_bignum_size(result))
2489    *scan = ((double)rand())/(RAND_MAX + 1.0) * (double)max_top_digit;
2490  else
2491    *scan = ((double)rand())/(RAND_MAX + 1.0) * (double)((C_word)1 << C_BIGNUM_DIGIT_LENGTH);
2492
2493  C_kontinue(k, C_bignum_simplify(result));
2494}
2495
2496void C_ccall
2497C_u_2_integer_bitwise_and(C_word c, C_word self, C_word k, C_word x, C_word y)
2498{
2499  C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab;
2500  if (x & C_FIXNUM_BIT) {
2501    if (y & C_FIXNUM_BIT) {
2502      C_kontinue(k, C_u_fixnum_and(x, y));
2503    } else {
2504      x = C_a_u_i_fix_to_big(&a, x);
2505    }
2506  }
2507  if (y & C_FIXNUM_BIT)
2508    y = C_a_u_i_fix_to_big(&a, y);
2509
2510  C_u_2_bignum_bitwise_op(5, (C_word)NULL, k, C_fix(0), x, y);
2511}
2512
2513void C_ccall
2514C_u_2_integer_bitwise_ior(C_word c, C_word self, C_word k, C_word x, C_word y)
2515{
2516  C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab;
2517  if (x & C_FIXNUM_BIT) {
2518    if (y & C_FIXNUM_BIT) {
2519      C_kontinue(k, C_u_fixnum_or(x, y));
2520    } else {
2521      x = C_a_u_i_fix_to_big(&a, x);
2522    }
2523  }
2524  if (y & C_FIXNUM_BIT)
2525    y = C_a_u_i_fix_to_big(&a, y);
2526
2527  C_u_2_bignum_bitwise_op(5, (C_word)NULL, k, C_fix(1), x, y);
2528}
2529
2530void C_ccall
2531C_u_2_integer_bitwise_xor(C_word c, C_word self, C_word k, C_word x, C_word y)
2532{
2533  C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab;
2534  if (x & C_FIXNUM_BIT) {
2535    if (y & C_FIXNUM_BIT) {
2536      C_kontinue(k, C_fixnum_xor(x, y));
2537    } else {
2538      x = C_a_u_i_fix_to_big(&a, x);
2539    }
2540  }
2541  if (y & C_FIXNUM_BIT)
2542    y = C_a_u_i_fix_to_big(&a, y);
2543
2544  C_u_2_bignum_bitwise_op(5, (C_word)NULL, k, C_fix(2), x, y);
2545}
2546
2547/* op identifies the operator: 0 means AND, 1 means IOR, 2 means XOR */
2548void C_ccall
2549C_u_2_bignum_bitwise_op(C_word c, C_word self, C_word k, C_word op, C_word x, C_word y)
2550{
2551  C_word kab[C_SIZEOF_CLOSURE(5)], *ka = kab, k2,
2552         size, negp;
2553 
2554  if (C_bignum_negativep(x)) {
2555    if (C_bignum_negativep(y)) {
2556      negp = C_mk_bool(op == C_fix(0) || op == C_fix(1)); /* and / ior */
2557      size = C_fix(nmax(C_bignum_size(x) + 1, C_bignum_size(y) + 1));
2558      k2 = C_closure(&ka, 5, (C_word)bignum_negneg_bitwise_op, k, op, x, y);
2559    } else {
2560      negp = C_mk_bool(op == C_fix(1) || op == C_fix(2)); /* ior / xor */
2561      size = C_fix(nmax(C_bignum_size(y), C_bignum_size(x) + 1)); /*!*/
2562      k2 = C_closure(&ka, 5, (C_word)bignum_posneg_bitwise_op, k, op, y, x);
2563    }
2564  } else {
2565    if (C_bignum_negativep(y)) {
2566      negp = C_mk_bool(op == C_fix(1) || op == C_fix(2)); /* ior / xor */
2567      size = C_fix(nmax(C_bignum_size(x), C_bignum_size(y) + 1));
2568      k2 = C_closure(&ka, 5, (C_word)bignum_posneg_bitwise_op, k, op, x, y);
2569    } else {
2570      negp = C_SCHEME_FALSE;
2571      size = C_fix(nmax(C_bignum_size(x), C_bignum_size(y)));
2572      k2 = C_closure(&ka, 5, (C_word)bignum_pospos_bitwise_op, k, op, x, y);
2573    }
2574  }
2575
2576  C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
2577}
2578
2579static void
2580bignum_pospos_bitwise_op(C_word c, C_word self, C_word result)
2581{
2582  C_word k = C_block_item(self, 1),
2583         op = C_block_item(self, 2),
2584         arg1 = C_block_item(self, 3),
2585         arg2 = C_block_item(self, 4),
2586         *scanr = C_bignum_digits(result),
2587         *endr = scanr + C_bignum_size(result),
2588         *scan1 = C_bignum_digits(arg1),
2589         *end1 = scan1 + C_bignum_size(arg1),
2590         *scan2 = C_bignum_digits(arg2),
2591         *end2 = scan2 + C_bignum_size(arg2),
2592         digit1, digit2;
2593
2594  while (scanr < endr) {
2595    digit1 = (scan1 < end1) ? *scan1++ : 0;
2596    digit2 = (scan2 < end2) ? *scan2++ : 0;
2597    *scanr++ = (op == C_fix(0)) ? digit1 & digit2 :
2598               (op == C_fix(1)) ? digit1 | digit2 :
2599                                  digit1 ^ digit2;
2600  }
2601  C_kontinue(k, C_bignum_simplify(result));
2602}
2603
2604static void
2605bignum_posneg_bitwise_op(C_word c, C_word self, C_word result)
2606{
2607  C_word k = C_block_item(self, 1),
2608         op = C_block_item(self, 2),
2609         arg1 = C_block_item(self, 3),
2610         arg2 = C_block_item(self, 4),
2611         *scanr = C_bignum_digits(result),
2612         *endr = scanr + C_bignum_size(result),
2613         *scan1 = C_bignum_digits(arg1),
2614         *end1 = scan1 + C_bignum_size(arg1),
2615         *scan2 = C_bignum_digits(arg2),
2616         *end2 = scan2 + C_bignum_size(arg2),
2617         digit1, digit2, carry2 = 1;
2618
2619  while (scanr < endr) {
2620    digit1 = (scan1 < end1) ? *scan1++ : 0;
2621    digit2 = (~((scan2 < end2) ? *scan2++ : 0) & C_BIGNUM_DIGIT_MASK) + carry2;
2622
2623    if (C_fitsinbignumdigitp(digit2)) {
2624      carry2 = 0;
2625    } else {
2626      digit2 &= C_BIGNUM_DIGIT_MASK;
2627      carry2 = 1;
2628    }
2629   
2630    *scanr++ = (op == C_fix(0)) ? digit1 & digit2 :
2631               (op == C_fix(1)) ? digit1 | digit2 :
2632                                  digit1 ^ digit2;
2633  }
2634
2635  bignum_maybe_negate_magnitude(k, result);
2636}
2637
2638static void
2639bignum_negneg_bitwise_op(C_word c, C_word self, C_word result)
2640{
2641  C_word k = C_block_item(self, 1),
2642         op = C_block_item(self, 2),
2643         arg1 = C_block_item(self, 3),
2644         arg2 = C_block_item(self, 4),
2645         *scanr = C_bignum_digits(result),
2646         *endr = scanr + C_bignum_size(result),
2647         *scan1 = C_bignum_digits(arg1),
2648         *end1 = scan1 + C_bignum_size(arg1),
2649         *scan2 = C_bignum_digits(arg2),
2650         *end2 = scan2 + C_bignum_size(arg2),
2651         digit1, digit2, carry1 = 1, carry2 = 1;
2652
2653  while (scanr < endr) {
2654    digit1 = (~((scan1 < end1) ? *scan1++ : 0) & C_BIGNUM_DIGIT_MASK) + carry1;
2655    digit2 = (~((scan2 < end2) ? *scan2++ : 0) & C_BIGNUM_DIGIT_MASK) + carry2;
2656
2657    if (C_fitsinbignumdigitp(digit1)) {
2658      carry1 = 0;
2659    } else {
2660      digit1 &= C_BIGNUM_DIGIT_MASK;
2661      carry1 = 1;
2662    }
2663    if (C_fitsinbignumdigitp(digit2)) {
2664      carry2 = 0;
2665    } else {
2666      digit2 &= C_BIGNUM_DIGIT_MASK;
2667      carry2 = 1;
2668    }
2669   
2670    *scanr++ = (op == C_fix(0)) ? digit1 & digit2 :
2671               (op == C_fix(1)) ? digit1 | digit2 :
2672                                  digit1 ^ digit2;
2673  }
2674
2675  bignum_maybe_negate_magnitude(k, result);
2676}
2677
2678static void
2679bignum_maybe_negate_magnitude(C_word k, C_word result)
2680{
2681  if (C_bignum_negativep(result)) {
2682    C_word *scan, *end, digit, carry;
2683
2684    scan = C_bignum_digits(result);
2685    end = scan + C_bignum_size(result);
2686    carry = 1;
2687
2688    while (scan < end) {
2689      digit = (~*scan & C_BIGNUM_DIGIT_MASK) + carry;
2690
2691      if (C_fitsinbignumdigitp(digit)) {
2692        carry = 0;
2693      } else {
2694        digit &= C_BIGNUM_DIGIT_MASK;
2695        carry = 1;
2696      }
2697   
2698      *scan++ = digit;
2699    }
2700  }
2701  C_kontinue(k, C_bignum_simplify(result));
2702}
2703
2704/* XXX Figure out if maybe we can get rid of _quotient and _remainder.
2705 * The divrem operation is more fundamental.
2706 */
2707void C_ccall
2708C_basic_divrem(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
2709{
2710  C_word ab[nmax(/* C_SIZEOF_FIX_BIGNUM, */ C_SIZEOF_FLONUM * 3,
2711                 C_SIZEOF_CLOSURE(5))], *a = ab, k2, q, r;
2712
2713  /* We could calculate the remainder from the quotient inline to
2714   * speed things up a tiny bit, but that's less readable.
2715   */
2716  if (x & C_FIXNUM_BIT) {
2717    if (y & C_FIXNUM_BIT) {
2718      r = C_u_i_fixnum_remainder_checked_loc(loc, x, y);
2719      q = C_a_u_i_fixnum_quotient_checked_loc(&a, 3, loc, x, y);
2720      C_values(4, C_SCHEME_UNDEFINED, k, q, r);
2721    } else if (C_immediatep(y)) {
2722      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2723    } else if (C_block_header(y) == C_FLONUM_TAG) {
2724      x = C_a_i_fix_to_flo(&a, 1, x);
2725      r = C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y);
2726      q = C_a_i_flonum_quotient_checked_loc(&a, 3, loc, x, y);
2727      C_values(4, C_SCHEME_UNDEFINED, k, q, r);
2728    } else if (C_IS_BIGNUM_TYPE(y)) {
2729      C_u_integer_divrem(5, (C_word)NULL, k, loc, x, y);
2730    } else {
2731      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2732    }
2733  } else if (C_immediatep(x)) {
2734    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), x);
2735  } else if (C_block_header(x) == C_FLONUM_TAG) {
2736    if (y & C_FIXNUM_BIT) {
2737      y = C_a_i_fix_to_flo(&a, 1, y);
2738      r = C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y);
2739      q = C_a_i_flonum_quotient_checked_loc(&a, 3, loc, x, y);
2740      C_values(4, C_SCHEME_UNDEFINED, k, q, r);
2741    } else if (C_immediatep(y)) {
2742      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
2743    } else if (C_block_header(y) == C_FLONUM_TAG) {
2744      r = C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y);
2745      q = C_a_i_flonum_quotient_checked_loc(&a, 3, loc, x, y);
2746      C_values(4, C_SCHEME_UNDEFINED, k, q, r);
2747    } else if (C_IS_BIGNUM_TYPE(y)) {
2748      k2 = C_closure(&a, 5, (C_word)divrem_intflo,
2749                     k, loc, C_SCHEME_TRUE, y);
2750      C_u_flo_to_int(4, (C_word)NULL, k2, loc, x);
2751    } else {
2752      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2753    }
2754  } else if (C_IS_BIGNUM_TYPE(x)) {
2755    if (y & C_FIXNUM_BIT) {
2756      C_u_integer_divrem(5, (C_word)NULL, k, loc, x, y);
2757    } else if (C_immediatep(y)) {
2758      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
2759    } else if (C_block_header(y) == C_FLONUM_TAG) {
2760      k2 = C_closure(&a, 5, (C_word)divrem_intflo,
2761                     k, loc, C_SCHEME_FALSE, x);
2762      C_u_flo_to_int(4, (C_word)NULL, k2, loc, y);
2763    } else if (C_IS_BIGNUM_TYPE(y)) {
2764      C_u_bignum_remainder(4, (C_word)NULL, k, x, y);
2765    } else {
2766      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2767    }
2768  } else {
2769    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), x);
2770  }
2771}
2772
2773/* TODO: We can get rid of the first *_intflo by rolling it into one and
2774 * creating the closure at the call site.
2775 */
2776static void divrem_intflo(C_word c, C_word self, C_word intnum)
2777{
2778  C_word k = C_block_item(self, 1),
2779         loc = C_block_item(self, 2),
2780         intnum_is_x =  C_block_item(self, 3),
2781         other_arg = C_block_item(self, 4),
2782         kab[C_SIZEOF_CLOSURE(2)], *ka = kab, k2;
2783 
2784  k2 = C_closure(&ka, 2, (C_word)divrem_intflo_2, k);
2785  if (C_truep(intnum_is_x))
2786    C_u_integer_divrem(5, (C_word)NULL, k2, loc, intnum, other_arg);
2787  else
2788    C_u_integer_divrem(5, (C_word)NULL, k2, loc, other_arg, intnum);
2789}
2790
2791static void divrem_intflo_2(C_word c, C_word self, C_word x, C_word y)
2792{
2793   C_word k = C_block_item(self, 1),
2794          ab[C_SIZEOF_FLONUM * 2], *a = ab;
2795   if (x & C_FIXNUM_BIT) x = C_a_i_fix_to_flo(&a, 1, x);
2796   else x = C_a_u_i_big_to_flo(&a, 1, x);
2797   if (y & C_FIXNUM_BIT) y = C_a_i_fix_to_flo(&a, 1, y);
2798   else y = C_a_u_i_big_to_flo(&a, 1, y);
2799   C_values(4, C_SCHEME_UNDEFINED, k, x, y);
2800}
2801
2802void C_ccall
2803C_u_integer_divrem(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
2804{
2805  if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */
2806    if (x & C_FIXNUM_BIT) {
2807      /* abs(x) < abs(y), so it will always be [0, x] except for this case: */
2808      if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&
2809          C_bignum_negated_fitsinfixnump(y)) {
2810        C_values(4, C_SCHEME_UNDEFINED, k, C_fix(-1), C_fix(0));
2811      } else {
2812        C_values(4, C_SCHEME_UNDEFINED, k, C_fix(0), x);
2813      }
2814    } else {
2815      C_u_bignum_divrem(4, (C_word)NULL, k, x, y);
2816    }
2817  } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */
2818    C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
2819    C_values(4, C_SCHEME_UNDEFINED, k,
2820             C_a_u_i_fixnum_quotient_checked_loc(&a, 3, loc, x, y),
2821             C_u_i_fixnum_remainder_checked_loc(loc, x, y));
2822  } else { /* x is bignum, y is fixnum. */
2823    C_word absy = (y < 0) ? -C_unfix(y) : C_unfix(y);
2824
2825    if (y == C_fix(1)) {
2826      C_values(4, C_SCHEME_UNDEFINED, k, x, C_fix(0));
2827    } else if (y == C_fix(0)) {
2828      C_div_by_zero_error(C_strloc(loc));
2829    } else if (y == C_fix(-1)) {
2830      C_word kab[C_SIZEOF_CLOSURE(2)], *ka = kab, k2;
2831      k2 = C_closure(&ka, 2, (C_word)bignum_divrem_fixnum_2, k);
2832      C_u_bignum_negate(3, (C_word)NULL, k2, x);
2833    } else if (C_fitsinbignumhalfdigitp(absy)) { /* Fast: div by halfdigit */
2834      C_word q_negp = C_mk_bool((y < 0) ?
2835                              !(C_bignum_negativep(x)) :
2836                              C_bignum_negativep(x)),
2837             r_negp = C_mk_bool(C_bignum_negativep(x)),
2838             kab[C_SIZEOF_BIGNUM(2)+C_SIZEOF_CLOSURE(9)], *ka = kab, k2, size;
2839 
2840      size = C_fix(C_bignum_size(x));
2841      k2 = C_closure(&ka, 7,
2842                     (C_word)bignum_destructive_divide_unsigned_halfdigit,
2843                     k, x, C_fix(absy), /* Return quotient *and* remainder */
2844                     C_SCHEME_TRUE, C_SCHEME_TRUE, C_SCHEME_FALSE);
2845      C_allocate_bignum(5, (C_word)NULL, k2, size, q_negp, C_SCHEME_FALSE);
2846    } else {                    /* Just divide it as two bignums */
2847      C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
2848      C_u_bignum_divrem(4, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y));
2849    }
2850  }
2851}
2852
2853static void
2854bignum_divrem_fixnum_2(C_word c, C_word self, C_word negated_big)
2855{
2856   C_word k = C_block_item(self, 1);
2857   C_values(4, C_SCHEME_UNDEFINED, k, negated_big, C_fix(0));
2858}
2859
2860void C_ccall
2861C_u_bignum_divrem(C_word c, C_word self, C_word k, C_word x, C_word y)
2862{
2863  C_word kab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_CLOSURE(9)], *ka = kab, k2, size,
2864         q_negp = C_mk_bool(C_bignum_negativep(y) ?
2865                            !C_bignum_negativep(x) :
2866                            C_bignum_negativep(x)),
2867         r_negp = C_mk_bool(C_bignum_negativep(x));
2868
2869  switch(bignum_cmp_unsigned(x, y)) {
2870  case 0:
2871    C_values(4, C_SCHEME_UNDEFINED, k,
2872             C_truep(q_negp) ? C_fix(-1) : C_fix(1), C_fix(0));
2873  case -1:
2874    C_values(4, C_SCHEME_UNDEFINED, k, C_fix(0), x);
2875  case 1:
2876  default:
2877    k2 = C_closure(&ka, 9, (C_word)bignum_divide_2_unsigned, k, x, y,
2878                   /* Return quotient *and* remainder */
2879                   C_SCHEME_TRUE, C_SCHEME_TRUE, r_negp,
2880                   /* Will be filled in later */
2881                   C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED);
2882    size = C_fix(C_bignum_size(x) + 1 - C_bignum_size(y));
2883    C_allocate_bignum(5, (C_word)NULL, k2, size, q_negp, C_SCHEME_FALSE);
2884  }
2885}
2886
2887void C_ccall
2888C_basic_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
2889{
2890  C_word ab[nmax(C_SIZEOF_FLONUM * 2, C_SIZEOF_CLOSURE(5))], *a = ab, k2;
2891
2892  if (x & C_FIXNUM_BIT) {
2893    if (y & C_FIXNUM_BIT) {
2894      C_kontinue(k, C_u_i_fixnum_remainder_checked_loc(loc, x, y));
2895    } else if (C_immediatep(y)) {
2896      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2897    } else if (C_block_header(y) == C_FLONUM_TAG) {
2898      x = C_a_i_fix_to_flo(&a, 1, x);
2899      x = C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y);
2900      C_kontinue(k, x);
2901    } else if (C_IS_BIGNUM_TYPE(y)) {
2902      C_u_integer_remainder(5, (C_word)NULL, k, loc, x, y);
2903    } else {
2904      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2905    }
2906  } else if (C_immediatep(x)) {
2907    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), x);
2908  } else if (C_block_header(x) == C_FLONUM_TAG) {
2909    if (y & C_FIXNUM_BIT) {
2910      y = C_a_i_fix_to_flo(&a, 1, y);
2911      x = C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y);
2912      C_kontinue(k, x);
2913    } else if (C_immediatep(y)) {
2914      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2915    } else if (C_block_header(y) == C_FLONUM_TAG) {
2916      x = C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y);
2917      C_kontinue(k, x);
2918    } else if (C_IS_BIGNUM_TYPE(y)) {
2919      k2 = C_closure(&a, 5, (C_word)remainder_intflo,
2920                     k, loc, C_SCHEME_TRUE, y);
2921      C_u_flo_to_int(4, (C_word)NULL, k2, loc, x);
2922    } else {
2923      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2924    }
2925  } else if (C_IS_BIGNUM_TYPE(x)) {
2926    if (y & C_FIXNUM_BIT) {
2927      C_u_integer_remainder(5, (C_word)NULL, k, loc, x, y);
2928    } else if (C_immediatep(y)) {
2929      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
2930    } else if (C_block_header(y) == C_FLONUM_TAG) {
2931      k2 = C_closure(&a, 5, (C_word)remainder_intflo,
2932                     k, loc, C_SCHEME_FALSE, x);
2933      C_u_flo_to_int(4, (C_word)NULL, k2, loc, y);
2934    } else if (C_IS_BIGNUM_TYPE(y)) {
2935      C_u_bignum_remainder(4, (C_word)NULL, k, x, y);
2936    } else {
2937      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
2938    }
2939  } else {
2940    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), x);
2941  }
2942}
2943
2944void C_ccall
2945C_u_integer_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
2946{
2947  if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */
2948    if (x & C_FIXNUM_BIT) {
2949      /* abs(x) < abs(y), so it will always be x except for this case: */
2950      if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&
2951          C_bignum_negated_fitsinfixnump(y)) {
2952        C_kontinue(k, C_fix(0));
2953      } else {
2954        C_kontinue(k, x);
2955      }
2956    } else {
2957      C_u_bignum_remainder(4, (C_word)NULL, k, x, y);
2958    }
2959  } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */
2960    C_kontinue(k, C_u_i_fixnum_remainder_checked_loc(loc, x, y));
2961  } else { /* x is bignum, y is fixnum. */
2962    C_word absy = (y < 0) ? -C_unfix(y) : C_unfix(y);
2963
2964    if (absy == 1) {
2965      C_kontinue(k, C_fix(0));
2966    } else if (absy == 0) {
2967      C_div_by_zero_error(C_strloc(loc));
2968    } else if (C_fitsinbignumhalfdigitp(absy)) { /* Fast: div by halfdigit */
2969      C_word rem = bignum_remainder_unsigned_halfdigit(x, absy);
2970      C_kontinue(k, C_bignum_negativep(x) ? C_fix(-rem) : C_fix(rem));
2971    } else {                    /* Just divide it as two bignums */
2972      C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
2973      C_u_bignum_remainder(4, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y));
2974    }
2975  }
2976}
2977
2978static void remainder_intflo(C_word c, C_word self, C_word intnum)
2979{
2980  C_word k = C_block_item(self, 1),
2981         loc = C_block_item(self, 2),
2982         intnum_is_x =  C_block_item(self, 3),
2983         other_arg = C_block_item(self, 4),
2984         kab[C_SIZEOF_CLOSURE(2)], *ka = kab, k2;
2985 
2986  k2 = C_closure(&ka, 2, (C_word)remainder_intflo_2, k);
2987  if (C_truep(intnum_is_x))
2988    C_u_integer_remainder(5, (C_word)NULL, k2, loc, intnum, other_arg);
2989  else
2990    C_u_integer_remainder(5, (C_word)NULL, k2, loc, other_arg, intnum);
2991}
2992
2993static void remainder_intflo_2(C_word c, C_word self, C_word x)
2994{
2995   C_word k = C_block_item(self, 1),
2996          ab[C_SIZEOF_FLONUM], *a = ab;
2997   if (x & C_FIXNUM_BIT) C_kontinue(k, C_a_i_fix_to_flo(&a, 1, x));
2998   else C_kontinue(k, C_a_u_i_big_to_flo(&a, 1, x));
2999}
3000
3001void C_ccall
3002C_u_bignum_remainder(C_word c, C_word self, C_word k, C_word x, C_word y)
3003{
3004  C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_CLOSURE(9)], *a = ab, k2, size, negp;
3005
3006  switch(bignum_cmp_unsigned(x, y)) {
3007  case 0:
3008    C_kontinue(k, C_fix(0));
3009  case -1:
3010    C_kontinue(k, x);
3011  case 1:
3012  default:
3013    negp = C_mk_bool(C_bignum_negativep(x));
3014
3015    /* We can skip bignum_divide_2_unsigned because we need no quotient */
3016    k2 = C_closure(&a, 9, (C_word)bignum_divide_2_unsigned_2, k, x, y,
3017                   /* Do not return quotient, do return remainder */
3018                   C_SCHEME_FALSE, C_SCHEME_TRUE, negp,
3019                   C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED);
3020    size = C_fix(C_bignum_size(x) + 1); /* May need to be normalized */
3021    C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
3022  }
3023}
3024
3025static C_word
3026bignum_remainder_unsigned_halfdigit(C_word num, C_word den)
3027{
3028  C_word *start = C_bignum_digits(num),
3029         *scan = start + C_bignum_size(num),
3030         rem = 0, two_digits;
3031
3032  assert((den > 1) && (C_fitsinbignumhalfdigitp(den)));
3033  while (start < scan) {
3034    two_digits = (*--scan);
3035    rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_HI_HALF(two_digits)) % den;
3036    rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_LO_HALF(two_digits)) % den;
3037  }
3038  return rem;
3039}
3040
3041void C_ccall
3042C_basic_quotient(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
3043{
3044  C_word ab[nmax(/* C_SIZEOF_FIX_BIGNUM, */ C_SIZEOF_FLONUM * 2,
3045                 C_SIZEOF_CLOSURE(5))], *a = ab, k2;
3046
3047  if (x & C_FIXNUM_BIT) {
3048    if (y & C_FIXNUM_BIT) {
3049      C_kontinue(k, C_a_u_i_fixnum_quotient_checked_loc(&a, 3, loc, x, y));
3050    } else if (C_immediatep(y)) {
3051      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
3052    } else if (C_block_header(y) == C_FLONUM_TAG) {
3053      x = C_a_i_fix_to_flo(&a, 1, x);
3054      x = C_a_i_flonum_quotient_checked_loc(&a, 3, loc, x, y);
3055      C_kontinue(k, x);
3056    } else if (C_IS_BIGNUM_TYPE(y)) {
3057      C_u_integer_quotient(5, (C_word)NULL, k, loc, x, y);
3058    } else {
3059      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
3060    }
3061  } else if (C_immediatep(x)) {
3062    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), x);
3063  } else if (C_block_header(x) == C_FLONUM_TAG) {
3064    if (y & C_FIXNUM_BIT) {
3065      y = C_a_i_fix_to_flo(&a, 1, y);
3066      x = C_a_i_flonum_quotient_checked_loc(&a, 3, loc, x, y);
3067      C_kontinue(k, x);
3068    } else if (C_immediatep(y)) {
3069      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
3070    } else if (C_block_header(y) == C_FLONUM_TAG) {
3071      x = C_a_i_flonum_quotient_checked_loc(&a, 3, loc, x, y);
3072      C_kontinue(k, x);
3073    } else if (C_IS_BIGNUM_TYPE(y)) {
3074      k2 = C_closure(&a, 5, (C_word)quotient_intflo,
3075                     k, loc, C_SCHEME_TRUE, y);
3076      C_u_flo_to_int(4, (C_word)NULL, k2, loc, x);
3077    } else {
3078      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
3079    }
3080  } else if (C_IS_BIGNUM_TYPE(x)) {
3081    if (y & C_FIXNUM_BIT) {
3082      C_u_integer_quotient(5, (C_word)NULL, k, loc, x, y);
3083    } else if (C_immediatep(y)) {
3084      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
3085    } else if (C_block_header(y) == C_FLONUM_TAG) {
3086      k2 = C_closure(&a, 5, (C_word)quotient_intflo,
3087                     k, loc, C_SCHEME_FALSE, x);
3088      C_u_flo_to_int(4, (C_word)NULL, k2, loc, y);
3089    } else if (C_IS_BIGNUM_TYPE(y)) {
3090      C_u_bignum_quotient(4, (C_word)NULL, k, x, y);
3091    } else {
3092      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
3093    }
3094  } else {
3095    barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), x);
3096  }
3097}
3098
3099static void quotient_intflo(C_word c, C_word self, C_word intnum)
3100{
3101  C_word k = C_block_item(self, 1),
3102         loc = C_block_item(self, 2),
3103         intnum_is_x =  C_block_item(self, 3),
3104         other_arg = C_block_item(self, 4),
3105         kab[C_SIZEOF_CLOSURE(2)], *ka = kab, k2;
3106 
3107  k2 = C_closure(&ka, 2, (C_word)quotient_intflo_2, k);
3108  if (C_truep(intnum_is_x))
3109    C_u_integer_quotient(5, (C_word)NULL, k2, loc, intnum, other_arg);
3110  else
3111    C_u_integer_quotient(5, (C_word)NULL, k2, loc, other_arg, intnum);
3112}
3113
3114static void quotient_intflo_2(C_word c, C_word self, C_word x)
3115{
3116   C_word k = C_block_item(self, 1),
3117          ab[C_SIZEOF_FLONUM], *a = ab;
3118   if (x & C_FIXNUM_BIT) C_kontinue(k, C_a_i_fix_to_flo(&a, 1, x));
3119   else C_kontinue(k, C_a_u_i_big_to_flo(&a, 1, x));
3120}
3121
3122void C_ccall
3123C_u_integer_quotient(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
3124{
3125  if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */
3126    if (x & C_FIXNUM_BIT) {
3127      /* abs(x) < abs(y), so it will always be zero except for this case: */
3128      if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&
3129          C_bignum_negated_fitsinfixnump(y)) {
3130        C_kontinue(k, C_fix(-1));
3131      } else {
3132        C_kontinue(k, C_fix(0));
3133      }
3134    } else {
3135      C_u_bignum_quotient(4, (C_word)NULL, k, x, y);
3136    }
3137  } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */
3138    C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
3139    C_kontinue(k, C_a_u_i_fixnum_quotient_checked_loc(&a, 3, loc, x, y));
3140  } else { /* x is bignum, y is fixnum. */
3141    C_word absy = (y < 0) ? -C_unfix(y) : C_unfix(y);
3142   
3143    if (y == C_fix(1)) {
3144      C_kontinue(k, x);
3145    } else if (y == C_fix(0)) {
3146      C_div_by_zero_error(C_strloc(loc));
3147    } else if (y == C_fix(-1)) {
3148      C_u_bignum_negate(3, (C_word)NULL, k, x);
3149    } else if (C_fitsinbignumhalfdigitp(absy)) {
3150      C_word negp = C_mk_bool((y < 0) ? !C_bignum_negativep(x) :
3151                                        C_bignum_negativep(x)),
3152             kab[C_SIZEOF_CLOSURE(7)], *ka = kab, k2,
3153             size, func;
3154
3155      size = C_fix(C_bignum_size(x));
3156      k2 = C_closure(&ka, 7,
3157                     (C_word)bignum_destructive_divide_unsigned_halfdigit,
3158                     k, x, C_fix(absy), /* Return quotient, not remainder */
3159                     C_SCHEME_TRUE, C_SCHEME_FALSE, C_SCHEME_FALSE);
3160      C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
3161    } else {                    /* Just divide it as two bignums */
3162      C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
3163      C_u_bignum_quotient(4, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y));
3164    }
3165  }
3166}
3167
3168void C_ccall
3169C_u_bignum_quotient(C_word c, C_word self, C_word k, C_word x, C_word y)
3170{
3171  C_word ab[C_SIZEOF_CLOSURE(9)], *a = ab, k2, size,
3172         negp = C_mk_bool(C_bignum_negativep(x) ?
3173                         !C_bignum_negativep(y) :
3174                         C_bignum_negativep(y));
3175
3176  switch(bignum_cmp_unsigned(x, y)) {
3177  case 0:
3178    C_kontinue(k, C_truep(negp) ? C_fix(-1) : C_fix(1));
3179  case -1:
3180    C_kontinue(k, C_fix(0));
3181  case 1:
3182  default:
3183    k2 = C_closure(&a, 9, (C_word)bignum_divide_2_unsigned, k, x, y,
3184                   /* Return quotient, not remainder */
3185                   C_SCHEME_TRUE, C_SCHEME_FALSE, C_SCHEME_FALSE,
3186                   /* Will be filled in later */
3187                   C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED);
3188    size = C_fix(C_bignum_size(x) + 1 - C_bignum_size(y));
3189    C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
3190  }
3191}
3192
3193static void
3194bignum_destructive_divide_unsigned_halfdigit(C_word c, C_word self, C_word quotient)
3195{
3196  C_word k = C_block_item(self, 1),
3197         numerator = C_block_item(self, 2),
3198         denominator = C_unfix(C_block_item(self, 3)),
3199         /* return_quotient = C_block_item(self, 4), */
3200         return_remainder = C_block_item(self, 5),
3201         remainder_negp = C_block_item(self, 6),
3202         *start = C_bignum_digits(quotient),
3203         *end = start + C_bignum_size(quotient) - 1,
3204         remainder;
3205
3206  bignum_digits_destructive_copy(quotient, numerator);
3207
3208  remainder = bignum_digits_destructive_scale_down(start, end, denominator);
3209  assert(C_fitsinbignumhalfdigitp(remainder));
3210
3211  quotient = C_bignum_simplify(quotient);
3212
3213  if (C_truep(return_remainder)) {
3214    remainder = C_truep(remainder_negp) ? -remainder : remainder;
3215    C_values(4, C_SCHEME_UNDEFINED, k, quotient, C_fix(remainder));
3216  } else {
3217    C_kontinue(k, quotient);
3218  }
3219}
3220
3221
3222static void
3223bignum_destructive_normalize(C_word target, C_word source, C_word shift_left)
3224{
3225  C_word digit, carry = 0,
3226         *scan_source = C_bignum_digits(source),
3227         *scan_target = C_bignum_digits(target),
3228         *end_source = scan_source + C_bignum_size(source),
3229         *end_target = scan_target + C_bignum_size(target),
3230         shift_right = C_BIGNUM_DIGIT_LENGTH - shift_left,
3231         mask = (1L << shift_right) - 1;
3232
3233  while (scan_source < end_source) {
3234    digit = (*scan_source++);
3235    (*scan_target++) = (((digit & mask) << shift_left) | carry);
3236    carry = (digit >> shift_right);
3237  }
3238  if (scan_target < end_target)
3239    (*scan_target) = carry;
3240  else
3241    assert(carry == 0);
3242}
3243
3244/* TODO: This pointer stuff here is suspicious: it's probably slow */
3245static C_word
3246bignum_divide_and_subtract_digit(C_word v1, C_word v2, C_word guess, C_word *u)
3247{
3248  C_word product, diff, sum, carry;
3249
3250  product = v2 * guess;
3251  diff = u[2] - C_BIGNUM_DIGIT_LO_HALF(product);
3252  if (diff < 0) {
3253    u[2] = diff + ((C_word)1 << C_BIGNUM_HALF_DIGIT_LENGTH);
3254    carry = C_BIGNUM_DIGIT_HI_HALF(product) + 1;
3255  } else {
3256    u[2] = diff;
3257    carry = C_BIGNUM_DIGIT_HI_HALF(product);
3258  }
3259 
3260  product = v1 * guess + carry;
3261  diff = u[1] - C_BIGNUM_DIGIT_LO_HALF(product);
3262  if (diff < 0) {
3263    u[1] = diff + ((C_word)1 << C_BIGNUM_HALF_DIGIT_LENGTH);
3264    carry = C_BIGNUM_DIGIT_HI_HALF(product) + 1;
3265  } else {
3266    u[1] = diff;
3267    carry = C_BIGNUM_DIGIT_HI_HALF(product);
3268    if (carry == 0) return guess; /* DONE */
3269  }
3270
3271  diff = u[0] - carry;
3272  if (diff < 0) {
3273    u[0] = diff + ((C_word)1 << C_BIGNUM_HALF_DIGIT_LENGTH);
3274  } else {
3275    u[0] = diff;
3276    return guess; /* DONE */
3277  }
3278
3279  sum = v2 + u[2];
3280  u[2] = sum & C_BIGNUM_HALF_DIGIT_MASK;
3281  carry = C_fitsinbignumhalfdigitp(sum);
3282
3283  sum = v1 + u[1] + carry;
3284  u[1] = sum & C_BIGNUM_HALF_DIGIT_MASK;
3285  carry = C_fitsinbignumhalfdigitp(sum);
3286
3287  u[0] += carry;
3288
3289  return guess - 1;
3290}
3291
3292/* This is a reduced version of the division algorithm, applied to the
3293   case of dividing two bignum digits by one bignum digit.  It is
3294   assumed that the numerator, denominator are normalized. */
3295
3296#define BDD_STEP(qn, j)                                                 \
3297{                                                                       \
3298  uj = u[j];                                                            \
3299  if (uj != v1) {                                                       \
3300    uj_uj1 = C_BIGNUM_DIGIT_COMBINE(uj, u[j + 1]);                      \
3301    guess = uj_uj1 / v1;                                                \
3302    comparand = C_BIGNUM_DIGIT_COMBINE(uj_uj1 % v1, u[j + 2]);          \
3303  } else {                                                              \
3304    guess = C_BIGNUM_HALF_DIGIT_MASK;                                   \
3305    comparand = C_BIGNUM_DIGIT_COMBINE(u[j + 1] + v1, u[j + 2]);        \
3306  }                                                                     \
3307  while ((guess * v2) > comparand) {                                    \
3308    guess -= 1;                                                         \
3309    comparand += v1 << C_BIGNUM_HALF_DIGIT_LENGTH;                      \
3310    if (!C_fitsinbignumdigitp(comparand))                               \
3311      break;                                                            \
3312  }                                                                     \
3313  qn = bignum_divide_and_subtract_digit(v1, v2, guess, &u[j]);          \
3314}
3315
3316/* Because the algorithm from Knuth requires combining the two highest
3317 * digits of u (which we can't fit in a C_word), we instead do two
3318 * such steps, a halfdigit at a time.
3319 */
3320static C_word
3321bignum_divide_digit(C_word uh, C_word ul, C_word v, C_word *q)
3322{
3323  C_word guess, comparand, v1, v2, uj, uj_uj1, q1, q2, u[4];
3324
3325  if (uh == 0) {
3326    if (ul < v) {
3327      *q = 0;
3328      return ul;
3329    } else if (ul == v) {
3330      *q = 1;
3331      return 0;
3332    }
3333  }
3334  u[0] = C_BIGNUM_DIGIT_HI_HALF(uh);
3335  u[1] = C_BIGNUM_DIGIT_LO_HALF(uh);
3336  u[2] = C_BIGNUM_DIGIT_HI_HALF(ul);
3337  u[3] = C_BIGNUM_DIGIT_LO_HALF(ul);
3338  v1 = C_BIGNUM_DIGIT_HI_HALF(v);
3339  v2 = C_BIGNUM_DIGIT_LO_HALF(v);
3340  BDD_STEP(q1, 0);
3341  BDD_STEP(q2, 1);
3342  *q = C_BIGNUM_DIGIT_COMBINE(q1, q2);
3343  return C_BIGNUM_DIGIT_COMBINE(u[2], u[3]);
3344}
3345
3346#undef BDD_STEP
3347
3348/* Full bignum division */
3349
3350static void
3351bignum_divide_2_unsigned(C_word c, C_word self, C_word quotient)
3352{
3353  C_word numerator = C_block_item(self, 2),
3354         remainder_negp = C_block_item(self, 6),
3355         size = C_fix(C_bignum_size(numerator) + 1);
3356
3357  /* Nice: We can recycle the current closure */
3358  C_set_block_item(self, 0, (C_word)bignum_divide_2_unsigned_2);
3359  C_set_block_item(self, 7, quotient);
3360  C_allocate_bignum(5, (C_word)NULL, self, size, remainder_negp, C_SCHEME_FALSE);
3361}
3362
3363/* For help understanding this algorithm, see:
3364   Knuth, Donald E., "The Art of Computer Programming",
3365   volume 2, "Seminumerical Algorithms"
3366   section 4.3.1, "Multiple-Precision Arithmetic". */
3367
3368static void
3369bignum_divide_2_unsigned_2(C_word c, C_word self, C_word remainder)
3370{
3371  C_word k = C_block_item(self, 1),
3372         numerator = C_block_item(self, 2),
3373         denominator = C_block_item(self, 3),
3374         return_quotient = C_block_item(self, 4),
3375         return_remainder = C_block_item(self, 5),
3376         /* This one may be overwritten with the remainder */
3377         /* remainder_negp = C_block_item(self, 6), */
3378         quotient = C_block_item(self, 7),
3379         length_d = C_bignum_size(denominator),
3380         d1 = *(C_bignum_digits(denominator) + length_d - 1),
3381         shift = 0;
3382
3383  while (d1 < ((C_word)1 << (C_BIGNUM_DIGIT_LENGTH-1))) {
3384    d1 <<= 1;
3385    shift++;
3386  }
3387
3388  if (shift == 0) { /* Already normalized */
3389    bignum_digits_destructive_copy(remainder, numerator);
3390    /* Set most significant digit */
3391    *(C_bignum_digits(remainder) + C_bignum_size(numerator)) = 0;
3392
3393    bignum_destructive_divide_normalized(remainder, denominator, quotient);
3394
3395    if (C_truep(C_and(return_quotient, return_remainder))) {
3396      C_values(4, C_SCHEME_UNDEFINED, k,
3397               C_bignum_simplify(quotient), C_bignum_simplify(remainder));
3398    } else if (C_truep(return_remainder)) {
3399      C_kontinue(k, C_bignum_simplify(remainder));
3400    } else {
3401      assert(C_truep(return_quotient));
3402      C_kontinue(k, C_bignum_simplify(quotient));
3403    }
3404  } else {
3405    /* Requires normalisation of denominator;  Allocate temp bignum for it. */
3406    C_set_block_item(self, 0, (C_word)bignum_divide_2_unsigned_3);
3407    C_set_block_item(self, 6, remainder);
3408    C_set_block_item(self, 8, C_fix(shift));
3409    C_allocate_bignum(5, (C_word)NULL, self, C_fix(length_d),
3410                      C_SCHEME_FALSE, C_SCHEME_FALSE);
3411  }
3412}
3413
3414static void
3415bignum_divide_2_unsigned_3(C_word c, C_word self, C_word tmp_big)
3416{
3417  C_word k = C_block_item(self, 1),
3418         numerator = C_block_item(self, 2),
3419         denominator = C_block_item(self, 3),
3420         return_quotient = C_block_item(self, 4),
3421         return_remainder = C_block_item(self, 5),
3422         remainder = C_block_item(self, 6),
3423         quotient = C_block_item(self, 7),
3424         shift = C_unfix(C_block_item(self, 8));
3425
3426  bignum_destructive_normalize(remainder, numerator, shift);
3427  bignum_destructive_normalize(tmp_big, denominator, shift);
3428  bignum_destructive_divide_normalized(remainder, tmp_big, quotient);
3429
3430  if (C_truep(return_remainder)) {
3431    if (C_truep(return_quotient)) {
3432      C_values(4, C_SCHEME_UNDEFINED, k,
3433               C_bignum_simplify(quotient),
3434               bignum_simplify_shifted(remainder, shift));
3435    } else {
3436      C_kontinue(k, bignum_simplify_shifted(remainder, shift));
3437    }
3438  } else {
3439    assert(C_truep(return_quotient));
3440    C_kontinue(k, C_bignum_simplify(quotient));
3441  }
3442}
3443
3444static void
3445bignum_destructive_divide_normalized(C_word u, C_word v, C_word q)
3446{
3447  C_word u_length = C_bignum_size(u),
3448         v_length = C_bignum_size(v),
3449         *u_start = C_bignum_digits(u),
3450         *u_scan = u_start + u_length,
3451         *u_scan_limit = u_start + v_length,
3452         *u_scan_start = u_scan - v_length,
3453         *v_start = C_bignum_digits(v),
3454         *v_end = v_start + v_length,
3455         *q_scan = (q == C_SCHEME_UNDEFINED) ? NULL :
3456                   (C_bignum_digits(q) + C_bignum_size(q)),
3457         v1 = v_end[-1],
3458         v2 = v_length == 1 ? 0 : v_end[-2],
3459         ph, /* high half of double-digit product */
3460         pl, /* low half of double-digit product */
3461         guess, uj, qj,
3462         gh, /* high half-digit of guess */
3463         ch, /* high half of double-digit comparand */
3464         v2l = C_BIGNUM_DIGIT_LO_HALF(v2),
3465         v2h = C_BIGNUM_DIGIT_HI_HALF(v2),
3466         cl, /* low half of double-digit comparand */
3467         gl, /* low half-digit of guess */
3468         gm; /* memory loc for reference parameter */
3469
3470  while (u_scan_limit < u_scan) {
3471    uj = (*--u_scan);
3472    if (uj != v1) {
3473      /* comparand = (((((uj * B) + uj1) % v1) * b) + uj2);
3474         guess = (((uj * B) + uj1) / v1); */
3475      cl = u_scan[-2];
3476      ch = bignum_divide_digit(uj, (u_scan[-1]), v1, (&gm));
3477      guess = gm;
3478    } else {
3479      cl = u_scan[-2];
3480      ch = u_scan[-1] + v1;
3481      guess = C_BIGNUM_DIGIT_MASK;
3482    }
3483    while (1) {
3484      /* product = (guess * v2); */
3485      gl = C_BIGNUM_DIGIT_LO_HALF(guess);
3486      gh = C_BIGNUM_DIGIT_HI_HALF(guess);
3487      pl = v2l * gl;
3488      ph = v2l * gh + v2h * gl + C_BIGNUM_DIGIT_HI_HALF(pl);
3489      pl = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(ph),
3490                                  C_BIGNUM_DIGIT_LO_HALF(pl));
3491      ph = v2h * gh + C_BIGNUM_DIGIT_HI_HALF(ph);
3492      /* if (comparand >= product) */
3493      if ((ch > ph) || ((ch == ph) && (cl >= pl)))
3494        break;
3495      guess--;
3496      /* comparand += (v1 << C_BIGNUM_DIGIT_LENGTH) */
3497      ch += v1;
3498      /* if (comparand >= (B^2)) */
3499      if (!C_fitsinbignumdigitp(ch))
3500        break;
3501    }
3502    qj = bignum_divide_and_subtract(v_start, v_end, guess, (--u_scan_start));
3503    if (q_scan != NULL)
3504      (*--q_scan) = qj;
3505  }
3506}
3507
3508static C_word
3509bignum_divide_and_subtract(C_word *v_start, C_word *v_end, C_word guess, C_word *u_start)
3510{
3511  if (guess == 0) {
3512    return 0;
3513  } else {
3514    C_word *v_scan = v_start,
3515           *u_scan = u_start,
3516           carry = 0,
3517           gl, gh, v, pl, vl, vh, ph, diff, sum;
3518
3519    gl = C_BIGNUM_DIGIT_LO_HALF(guess);
3520    gh = C_BIGNUM_DIGIT_HI_HALF(guess);
3521    while (v_scan < v_end) {
3522      v = (*v_scan++);
3523      vl = C_BIGNUM_DIGIT_LO_HALF(v);
3524      vh = C_BIGNUM_DIGIT_HI_HALF(v);
3525      pl = vl * gl + C_BIGNUM_DIGIT_LO_HALF(carry);
3526      ph = vl * gh + vh * gl + C_BIGNUM_DIGIT_HI_HALF(pl) +
3527                               C_BIGNUM_DIGIT_HI_HALF(carry);
3528      diff = (*u_scan) - C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(ph),
3529                                                C_BIGNUM_DIGIT_LO_HALF(pl));
3530      if (diff < 0) {
3531        (*u_scan++) = diff + ((C_word)1 << C_BIGNUM_DIGIT_LENGTH);
3532        carry = vh * gh + C_BIGNUM_DIGIT_HI_HALF(ph) + 1;
3533      } else {
3534        (*u_scan++) = diff;
3535        carry = vh * gh + C_BIGNUM_DIGIT_HI_HALF(ph);
3536      }
3537    }
3538    if (carry == 0)
3539      return guess;
3540
3541    diff = ((*u_scan) - carry);
3542    if (diff < 0) {
3543      (*u_scan) = diff + ((C_word)1 << C_BIGNUM_DIGIT_LENGTH);
3544    } else {
3545      (*u_scan) = diff;
3546      return guess;
3547    }
3548 
3549    /* Subtraction generated carry, implying guess is one too large.
3550       Add v back in to bring it back down. */
3551    v_scan = v_start;
3552    u_scan = u_start;
3553    carry = 0;
3554    while (v_scan < v_end) {
3555      sum = ((*v_scan++) + (*u_scan) + carry);
3556      if (C_fitsinbignumdigitp(sum)) {
3557        (*u_scan++) = sum;
3558        carry = 0;
3559      } else {
3560        (*u_scan++) = sum & C_BIGNUM_DIGIT_MASK;
3561        carry = 1;
3562      }
3563    }
3564    if (carry) {
3565      sum = (*u_scan) + carry;
3566      (*u_scan) = C_fitsinbignumdigitp(sum) ? sum : (sum  & C_BIGNUM_DIGIT_MASK);
3567    }
3568    return guess - 1;
3569  }
3570}
3571
3572/* Like bignum_simplify, but this also shifts division-normalized
3573 * numbers, to denormalize them to regular bignum representation.
3574 */
3575static C_word
3576bignum_simplify_shifted(C_word big, C_word shift_right)
3577{
3578  C_word length = C_bignum_size(big),
3579        *start = C_bignum_digits(big),
3580        *scan = start + length,
3581        digit, carry = 0,
3582        shift_left = C_BIGNUM_DIGIT_LENGTH - shift_right,
3583        mask = (1L << shift_right) - 1;
3584 
3585  while (!(*--scan)) {
3586    if (start == scan) { /* Don't bother with anything else */
3587      return C_fix(0);
3588    }
3589    --length;
3590  }
3591
3592  digit = (*scan);
3593  (*scan) = (digit >> shift_right);
3594  length -= (*scan == 0); /* Add 1 or 0 */
3595  carry = ((digit & mask) << shift_left);
3596 
3597  while (start < scan) {
3598    digit = (*--scan);
3599    (*scan) = ((digit >> shift_right) | carry);
3600    carry = ((digit & mask) << shift_left);
3601  }
3602  assert(carry == 0);
3603  /* This is only correct for remainder, not when normalizing tmp_y in gcd */
3604  /* assert(C_bignum_size(big) != length); */
3605  assert(length != 1 || *C_bignum_digits(big) != 0);
3606
3607  switch(length) {
3608  case 0:
3609    return C_fix(0);
3610  case 1:
3611    return C_fix(C_bignum_negativep(big) ? -*start : *start);
3612  case 2:
3613    if (C_bignum_negativep(big) && *scan == 1 && *start == 0)
3614      return C_fix(C_MOST_NEGATIVE_FIXNUM);
3615    /* FALLTHROUGH */
3616  default:
3617    /* Mutate vector size of internal bignum vector. */
3618    C_block_header(C_internal_bignum(big)) = (C_STRING_TYPE | C_wordstobytes(length+1));
3619    /* Set internal header. */
3620    C_bignum_header(big) = (C_bignum_header(big) & C_BIGNUM_HEADER_SIGN_BIT) | length;
3621    return big;
3622  }
3623}
3624
Note: See TracBrowser for help on using the repository browser.