int32_t thirty_two_bits(Lisp_Object a)
/*
* return a 32 bit integer value for the Lisp integer (fixnum or bignum)
* passed down - ignore any higher order bits and return 0 if the arg was
* floating, rational etc or not a number at all. Only really wanted where
* links between C-specific code (that might really want 32-bit values)
* and Lisp are being coded.
*/
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return int_of_fixnum(a);
case TAG_NUMBERS:
if (is_bignum(a))
{ int len = bignum_length(a);
/*
* Note that I keep 31 bits per word and use a 2s complement representation.
* thus if I have a one-word bignum I just want its contents but in all
* other cases I need just one bit from the next word up.
*/
if (len == CELL+4) return bignum_digits(a)[0]; /* One word bignum */
return bignum_digits(a)[0] | (bignum_digits(a)[1] << 31);
}
/* else drop through */
case TAG_BOXFLOAT:
default:
/*
* return 0 for all non-fixnums
*/
return 0;
}
}
static double bignum_to_float(Lisp_Object v, int32_t h, int *xp)
/*
* Convert a Lisp bignum to get a floating point value. This uses at most the
* top 3 digits of the bignum's representation since that is enough to achieve
* full double precision accuracy.
* This can not overflow, because it leaves an exponent-adjustment value
* in *xp. You need ldexp(r, *xp) afterwards.
*/
{
int32_t n = (h-CELL-4)/4; /* Last index into the data */
int x = 31*(int)n;
int32_t msd = (int32_t)bignum_digits(v)[n];
/* NB signed conversion on next line */
double r = (double)msd;
switch (n)
{
default: /* for very big numbers combine in 3 digits */
r = TWO_31*r + (double)bignum_digits(v)[--n];
x -= 31;
/* drop through */
case 1: r = TWO_31*r + (double)bignum_digits(v)[--n];
x -= 31;
/* drop through */
case 0: break; /* do no more */
}
*xp = x;
return r;
}
static CSLbool numeqbb(Lisp_Object a, Lisp_Object b)
{
int32_t la = bignum_length(a);
if (la != (int32_t)bignum_length(b)) return NO;
la = (la-CELL-4)/4;
while (la >= 0)
{ if (bignum_digits(a)[la] != bignum_digits(b)[la]) return NO;
else la--;
}
return YES;
}
Lisp_Object make_one_word_bignum(int32_t n)
/*
* n is an integer - create a bignum representation of it. This is
* done when n is outside the range 0xf8000000 to 0x07ffffff, but
* inside the range 0xc0000000 to 0x3fffffff.
*/
{ Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+4);
Lisp_Object nil;
errexit();
bignum_digits(w)[0] = n;
if (SIXTY_FOUR_BIT) bignum_digits(w)[1] = 0; /* padding */
return w;
}
Lisp_Object make_two_word_bignum(int32_t a1, uint32_t a0)
/*
* This make a 2-word bignum from the 2-word value (a1,a0), where it
* must have been arranged already that a1 and a0 are correctly
* normalized to put in the two words as indicated.
*/
{
Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+8);
Lisp_Object nil;
errexit();
bignum_digits(w)[0] = a0;
bignum_digits(w)[1] = a1;
if (!SIXTY_FOUR_BIT) bignum_digits(w)[2] = 0;
return w;
}
void validate_number(char *s, Lisp_Object a, Lisp_Object b, Lisp_Object c)
{
int32_t la, w, msd;
if (!is_numbers(a)) return;
la = (length_of_header(numhdr(a))-CELL-4)/4;
if (la < 0)
{ trace_printf("%s: number with no digits (%.8x)\n", s, numhdr(a));
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (la == 0)
{ msd = bignum_digits(a)[0];
w = msd & fix_mask;
if (w == 0 || w == fix_mask)
{ trace_printf("%s: %.8x should be fixnum\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (signed_overflow(msd))
{ trace_printf("%s: %.8x should be two-word\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
return;
}
msd = bignum_digits(a)[la];
if (signed_overflow(msd))
{ trace_printf("%s: %.8x should be longer\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (msd == 0 && ((msd = bignum_digits(a)[la-1]) & 0x40000000) == 0)
{ trace_printf("%s: 0: %.8x should be shorter\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (msd == -1 && ((msd = bignum_digits(a)[la-1]) & 0x40000000) != 0)
{ trace_printf("%s: -1: %.8x should be shorter\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
}
Lisp_Object copyb(Lisp_Object a)
/*
* copy a bignum.
*/
{
Lisp_Object b, nil;
int32_t len = bignum_length(a), i;
push(a);
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
pop(a);
errexit();
len = (len-CELL)/4;
for (i=0; i<len; i++)
bignum_digits(b)[i] = bignum_digits(a)[i];
return b;
}
CSLbool minusp(Lisp_Object a)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return ((int32_t)a < 0);
case TAG_SFLOAT:
{ Float_union aa;
aa.i = a - TAG_SFLOAT;
return (aa.f < 0.0);
}
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
{ int32_t l = (bignum_length(a)-CELL-4)/4;
return ((int32_t)bignum_digits(a)[l] < (int32_t)0);
}
case TYPE_RATNUM:
return minusp(numerator(a));
default:
aerror1("Bad arg for minusp", a);
return 0;
}
}
case TAG_BOXFLOAT:
{ double d = float_of_number(a);
return (d < 0.0);
}
default:
aerror1("Bad arg for minusp", a);
return 0;
}
}
Lisp_Object make_three_word_bignum(int32_t a2, uint32_t a1, uint32_t a0)
/*
* This make a 3-word bignum from the 3-word value (a2,a1,a0), where it
* must have been arranged already that the values are correctly
* normalized.
*/
{
Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+12);
Lisp_Object nil;
errexit();
bignum_digits(w)[0] = a0;
bignum_digits(w)[1] = a1;
bignum_digits(w)[2] = a2;
if (SIXTY_FOUR_BIT) bignum_digits(w)[3] = 0;
return w;
}
static CSLbool numeqsb(Lisp_Object a, Lisp_Object b)
/*
* This is coded to allow comparison of any floating type
* with a bignum
*/
{
double d = float_of_number(a), d1;
int x;
int32_t w, len;
uint32_t u;
if (-1.0e8 < d && d < 1.0e8) return NO; /* fixnum range (approx) */
len = (bignum_length(b)-CELL-4)/4;
if (len == 0) /* One word bignums can be treated specially */
{ int32_t v = bignum_digits(b)[0];
return (d == (double)v);
}
d1 = frexp(d, &x); /* separate exponent from mantissa */
if (d1 == 1.0) d1 = 0.5, x++; /* For Zortech */
/* The exponent x must be positive here, hence the % operation is defined */
d1 = ldexp(d1, x % 31);
/*
* At most 3 words in the bignum may contain nonzero data - I subtract
* the (double) value of those bits off and check that (a) the floating
* result left is zero and (b) there are no more bits left.
*/
x = x / 31;
if (x != len) return NO;
w = bignum_digits(b)[len];
d1 = (d1 - (double)w) * TWO_31;
u = bignum_digits(b)[--len];
d1 = (d1 - (double)u) * TWO_31;
if (len > 0)
{ u = bignum_digits(b)[--len];
d1 = d1 - (double)u;
}
if (d1 != 0.0) return NO;
while (--len >= 0)
if (bignum_digits(b)[len] != 0) return NO;
return YES;
}
int64_t sixty_four_bits(Lisp_Object a)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return int_of_fixnum(a);
case TAG_NUMBERS:
if (is_bignum(a))
{ int len = bignum_length(a);
switch (len)
{
case CELL+4:
return (int64_t)bignum_digits(a)[0]; /* One word bignum */
case CELL+8:
return bignum_digits(a)[0] |
((int64_t)bignum_digits(a)[1] << 31);
default:
return bignum_digits(a)[0] |
((int64_t)bignum_digits(a)[1] << 31) |
((int64_t)bignum_digits(a)[2] << 62);
}
}
/* else drop through */
case TAG_BOXFLOAT:
default:
/*
* return 0 for all non-fixnums
*/
return 0;
}
}
CSLbool plusp(Lisp_Object a)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
return (a > fixnum_of_int(0));
case TAG_SFLOAT:
{ Float_union aa;
aa.i = a - TAG_SFLOAT;
return (aa.f > 0.0);
}
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
{ int32_t l = (bignum_length(a)-CELL-4)/4;
/* This is OK because a bignum can never have the value zero */
return ((int32_t)bignum_digits(a)[l] >= (int32_t)0);
}
case TYPE_RATNUM:
return plusp(numerator(a));
default:
aerror1("Bad arg for plusp", a);
return 0;
}
}
case TAG_BOXFLOAT:
{ double d = float_of_number(a);
return (d > 0.0);
}
default:
aerror1("Bad arg for plusp", a);
return 0;
}
}
Lisp_Object lengthen_by_one_bit(Lisp_Object a, int32_t msd)
/*
* (a) is a bignum, and arithmetic on it has (just) caused overflow
* in its top word - I just need to stick on another word. (msd) is the
* current top word, and its sign will be used to decide on the value
* that must be appended.
*/
{
int32_t len = bignum_length(a);
/*
* Sometimes I need to allocate a new vector and copy data across into it
*/
if ((len & 4) == 0)
{ Lisp_Object b, nil;
int32_t i;
push(a);
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, len+4);
pop(a);
errexit();
len = (len-CELL)/4;
for (i=0; i<len; i++)
bignum_digits(b)[i] = clear_top_bit(bignum_digits(a)[i]);
bignum_digits(b)[len] = top_bit_set(msd) ? -1 : 0;
bignum_digits(b)[len+1] = 0;
return b;
}
else
/*
* .. whereas sometimes I have a spare word already available.
*/
{ numhdr(a) += pack_hdrlength(1L);
len = (len-CELL)/4;
bignum_digits(a)[len-1] = clear_top_bit(bignum_digits(a)[len-1]);
bignum_digits(a)[len] = top_bit_set(msd) ? -1 : 0;
return a;
}
}
static CSLbool numeqsr(Lisp_Object a, Lisp_Object b)
/*
* Here I will rely somewhat on the use of IEEE floating point values
* (an in particular the weaker supposition that I have floating point
* with a binary radix). Then for equality the denominator of b must
* be a power of 2, which I can test for and then account for.
*/
{
Lisp_Object nb = numerator(b), db = denominator(b);
double d = float_of_number(a), d1;
int x;
int32_t dx, w, len;
uint32_t u, bit;
/*
* first I will check that db (which will be positive) is a power of 2,
* and set dx to indicate what power of two it is.
* Note that db != 0 and that one of the top two words of a bignum
* must be nonzero (for normalisation) so I end up with a nonzero
* value in the variable 'bit'
*/
if (is_fixnum(db))
{ bit = int_of_fixnum(db);
w = bit;
if (w != (w & (-w))) return NO; /* not a power of 2 */
dx = 0;
}
else if (is_numbers(db) && is_bignum(db))
{ int32_t lenb = (bignum_length(db)-CELL-4)/4;
bit = bignum_digits(db)[lenb];
/*
* I need to cope with bignums where the leading digits is zero because
* the 0x80000000 bit of the next word down is 1. To do this I treat
* the number as having one fewer digits.
*/
if (bit == 0) bit = bignum_digits(db)[--lenb];
w = bit;
if (w != (w & (-w))) return NO; /* not a power of 2 */
dx = 31*lenb;
while (--lenb >= 0) /* check that the rest of db is zero */
if (bignum_digits(db)[lenb] != 0) return NO;
}
else return NO; /* Odd - what type IS db here? Maybe error. */
if ((bit & 0xffffU) == 0) dx += 16, bit = bit >> 16;
if ((bit & 0xff) == 0) dx += 8, bit = bit >> 8;
if ((bit & 0xf) == 0) dx += 4, bit = bit >> 4;
if ((bit & 0x3) == 0) dx += 2, bit = bit >> 2;
if ((bit & 0x1) == 0) dx += 1;
if (is_fixnum(nb))
{ double d1 = (double)int_of_fixnum(nb);
/*
* The ldexp on the next line could potentially underflow. In that case C
* defines that the result 0.0 be returned. To avoid trouble I put in a
* special test the relies on that fact that a value represented as a rational
* would not have been zero.
*/
if (dx > 10000) return NO; /* Avoid gross underflow */
d1 = ldexp(d1, (int)-dx);
return (d == d1 && d != 0.0);
}
len = (bignum_length(nb)-CELL-4)/4;
if (len == 0) /* One word bignums can be treated specially */
{ int32_t v = bignum_digits(nb)[0];
double d1;
if (dx > 10000) return NO; /* Avoid gross underflow */
d1 = ldexp((double)v, (int)-dx);
return (d == d1 && d != 0.0);
}
d1 = frexp(d, &x); /* separate exponent from mantissa */
if (d1 == 1.0) d1 = 0.5, x++; /* For Zortech */
dx += x; /* adjust to allow for the denominator */
d1 = ldexp(d1, (int)(dx % 31));
/* can neither underflow nor overflow here */
/*
* At most 3 words in the bignum may contain nonzero data - I subtract
* the (double) value of those bits off and check that (a) the floating
* result left is zero and (b) there are no more bits left.
*/
dx = dx / 31;
if (dx != len) return NO;
w = bignum_digits(nb)[len];
d1 = (d1 - (double)w) * TWO_31;
u = bignum_digits(nb)[--len];
d1 = (d1 - (double)u) * TWO_31;
if (len > 0)
{ u = bignum_digits(nb)[--len];
d1 = d1 - (double)u;
}
if (d1 != 0.0) return NO;
while (--len >= 0)
if (bignum_digits(nb)[len] != 0) return NO;
return YES;
}
Lisp_Object Cremainder(Lisp_Object a, Lisp_Object b)
{
int32_t c;
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
/*
* This is where fixnum % fixnum arithmetic happens - the case I most want to
* make efficient.
*/
if (b == fixnum_of_int(0))
return aerror2("bad arg for remainder", a, b);
/* No overflow is possible in a remaindering operation */
{ int32_t aa = int_of_fixnum(a);
int32_t bb = int_of_fixnum(b);
c = aa % bb;
/*
* C does not specify just what happens when % is used with negative
* operands (except maybe if the division went exactly), so here I do
* some adjusting, assuming that the quotient returned was one of the
* integral values surrounding the exact result.
*/
if (aa < 0)
{ if (c > 0) c -= bb;
}
else if (c < 0) c += bb;
return fixnum_of_int(c);
}
/*
* Common Lisp defines a meaning for the remainder function when applied
* to floating point values - so there is a whole pile of mess here to
* support that. Standard Lisp is only concerned with fixnums and
* bignums, but can tolerate the extra generality.
*/
case TAG_SFLOAT:
return remis(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
/*
* When I divide a fixnum a by a bignum b the remainder is a except in
* the case that a = 0xf8000000 and b = 0x08000000 in which case the
* answer is zero.
*/
if (int_of_fixnum(a) == fix_mask &&
bignum_length(b) == CELL+4 &&
bignum_digits(b)[0] == 0x08000000)
return fixnum_of_int(0);
else return a;
case TYPE_RATNUM:
return remir(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remif(a, b);
/*
case TAG_BOXFLOAT:
{ double v = (double) int_of_fixnum(a);
double u = float_of_number(b);
v = v - (v/u)*u;
return make_boxfloat(v, TYPE_DOUBLE_FLOAT);
}
*/
default:
return aerror1("Bad arg for remainder", b);
}
case TAG_SFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return remsi(a, b);
case TAG_SFLOAT:
{ Float_union aa, bb;
aa.i = a - TAG_SFLOAT;
bb.i = b - TAG_SFLOAT;
aa.f = (float) (aa.f + bb.f);
return (aa.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return remsb(a, b);
case TYPE_RATNUM:
return remsr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remsf(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return rembi(a, b);
case TAG_SFLOAT:
return rembs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return rembb(a, b);
case TYPE_RATNUM:
return rembr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return rembf(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
case TYPE_RATNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return remri(a, b);
case TAG_SFLOAT:
return remrs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return remrb(a, b);
case TYPE_RATNUM:
return remrr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remrf(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
default:
return aerror1("Bad arg for remainder", a);
}
}
case TAG_BOXFLOAT:
switch ((int)b & TAG_BITS)
{
/*
case TAG_FIXNUM:
{ double u = (double) int_of_fixnum(b);
double v = float_of_number(a);
v = v - (v/u)*u;
return make_boxfloat(v, TYPE_DOUBLE_FLOAT);
}
case TAG_BOXFLOAT:
{ double u = float_of_number(b);
double v = float_of_number(a);
v = v - (v/u)*u;
return make_boxfloat(v, TYPE_DOUBLE_FLOAT);
}
*/
case TAG_FIXNUM:
return remfi(a, b);
case TAG_SFLOAT:
return remfs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return remfb(a, b);
case TYPE_RATNUM:
return remfr(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
}
case TAG_BOXFLOAT:
return remff(a, b);
default:
return aerror1("Bad arg for remainder", b);
}
default:
return aerror1("Bad arg for remainder", a);
}
}
Lisp_Object negateb(Lisp_Object a)
/*
* Negate a bignum. Note that negating the 1-word bignum
* value of 0x08000000 will produce a fixnum as a result,
* which might confuse the caller... in a similar way negating
* the value -0x40000000 will need to promote from a one-word
* bignum to a 2-word bignum. How messy just for negation!
*/
{
Lisp_Object b, nil;
int32_t len = bignum_length(a), i, carry;
if (len == CELL+4) /* one-word bignum - do specially */
{ len = -(int32_t)bignum_digits(a)[0];
if (len == fix_mask) return fixnum_of_int(len);
else if (len == 0x40000000) return make_two_word_bignum(0, len);
else return make_one_word_bignum(len);
}
push(a);
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
pop(a);
errexit();
len = (len-CELL)/4-1;
carry = -1;
for (i=0; i<len; i++)
{ carry = clear_top_bit(~bignum_digits(a)[i]) + top_bit(carry);
bignum_digits(b)[i] = clear_top_bit(carry);
}
/*
* Handle the top digit separately since it is signed.
*/
carry = ~bignum_digits(a)[i] + top_bit(carry);
if (!signed_overflow(carry))
{
/*
* If the most significant word ends up as -1 then I just might
* have 0x40000000 in the next word down and so I may need to shrink
* the number. Since I handled 1-word bignums specially I have at
* least two words to deal with here.
*/
if (carry == -1 && (bignum_digits(b)[i-1] & 0x40000000) != 0)
{ bignum_digits(b)[i-1] |= ~0x7fffffff;
numhdr(b) -= pack_hdrlength(1);
if (SIXTY_FOUR_BIT)
{ if ((i & 1) != 0) bignum_digits(b)[i] = 0;
else bignum_digits(b)[i] = make_bighdr(2);
}
else
{ if ((i & 1) == 0) bignum_digits(b)[i] = 0;
else bignum_digits(b)[i] = make_bighdr(2);
}
}
else bignum_digits(b)[i] = carry; /* no shrinking needed */
return b;
}
/*
* Here I have overflow: this can only happen when I negate a number
* that started off with 0xc0000000 in the most significant digit,
* and I have to pad a zero word onto the front.
*/
bignum_digits(b)[i] = clear_top_bit(carry);
return lengthen_by_one_bit(b, carry);
}
static Lisp_Object plusbb(Lisp_Object a, Lisp_Object b)
/*
* add two bignums.
*/
{
int32_t la = bignum_length(a),
lb = bignum_length(b),
i, s, carry;
Lisp_Object c, nil;
if (la < lb) /* maybe swap order of args */
{ Lisp_Object t = a;
int32_t t1;
a = b; b = t;
t1 = la; la = lb; lb = t1;
}
/*
* now (a) is AT LEAST as long as b. I have special case code for
* when both args are single-word bignums, since I expect that to be
* an especially common case.
*/
if (la == CELL+4) /* and hence b also has only 1 digit */
{ int32_t va = bignum_digits(a)[0],
vb = bignum_digits(b)[0],
vc = va + vb;
if (signed_overflow(vc)) /* we have a 2-word bignum result */
{ Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+8);
errexit();
bignum_digits(w)[0] = clear_top_bit(vc);
bignum_digits(w)[1] = top_bit_set(vc) ? -1 : 0;
if (!SIXTY_FOUR_BIT) bignum_digits(w)[2] = 0;
return w;
}
/*
* here the result fits into one word - maybe it will squash down into
* a fixnum?
*/
else
{ vb = vc & fix_mask;
if (vb == 0 || vb == fix_mask) return fixnum_of_int(vc);
else return make_one_word_bignum(vc);
}
}
push2(a, b);
c = getvector(TAG_NUMBERS, TYPE_BIGNUM, la);
pop2(b, a);
errexit();
la = (la-CELL)/4 - 1;
lb = (lb-CELL)/4 - 1;
carry = 0;
/*
* Add all but the top digit of b
*/
for (i=0; i<lb; i++)
{ carry = bignum_digits(a)[i] + bignum_digits(b)[i] + top_bit(carry);
bignum_digits(c)[i] = clear_top_bit(carry);
}
if (la == lb) s = bignum_digits(b)[i];
else
/*
* If a is strictly longer than b I sign extend b here and add in as many
* copies of 0 or -1 as needbe to get up to the length of a.
*/
{ s = bignum_digits(b)[i];
carry = bignum_digits(a)[i] + clear_top_bit(s) + top_bit(carry);
bignum_digits(c)[i] = clear_top_bit(carry);
if (s < 0) s = -1; else s = 0;
for (i++; i<la; i++)
{ carry = bignum_digits(a)[i] + clear_top_bit(s) + top_bit(carry);
bignum_digits(c)[i] = clear_top_bit(carry);
}
}
/*
* the most significant digit is added using signed arithmetic so that I
* can tell if it overflowed.
*/
carry = bignum_digits(a)[i] + s + top_bit(carry);
if (!signed_overflow(carry))
{
/*
* Here the number has not expanded - but it may be shrinking, and it can
* shrink by any number of words, all the way down to a fixnum maybe. Note
* that I started with at least a 2-word bignum here.
*/
int32_t msd;
bignum_digits(c)[i] = carry;
if (carry == 0)
{ int32_t j = i-1;
while ((msd = bignum_digits(c)[j]) == 0 && j > 0) j--;
/*
* ... but I may need a zero word on the front if the next word down
* has its top bit set... (top of 31 bits, that is)
*/
if ((msd & 0x40000000) != 0)
{ j++;
if (i == j) return c;
}
if (j == 0)
{ int32_t s = bignum_digits(c)[0];
if ((s & fix_mask) == 0) return fixnum_of_int(s);
}
/*
* If I am shrinking by one word and had an even length to start with
* I do not have to mess about so much.
*/
if ((SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) != 0)) ||
(!SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) == 0)))
{ numhdr(c) -= pack_hdrlength(1L);
return c;
}
numhdr(c) -= pack_hdrlength(i - j);
if (SIXTY_FOUR_BIT)
{ i = (i+2) & ~1;
j = (j+2) & ~1; /* Round up to odd index */
}
else
{ i = (i+1) | 1;
j = (j+1) | 1; /* Round up to odd index */
}
/*
* I forge a header word to allow the garbage collector to skip over
* (and in due course reclaim) the space that turned out not to be needed.
*/
if (i != j) bignum_digits(c)[j] = make_bighdr(i - j);
return c;
}
/*
* Now do all the same sorts of things but this time for negative numbers.
*/
else if (carry == -1)
{ int32_t j = i-1;
msd = carry; /* in case j = 0 */
while ((msd = bignum_digits(c)[j]) == 0x7fffffff && j > 0) j--;
if ((msd & 0x40000000) == 0)
{ j++;
if (i == j) return c;
}
if (j == 0)
{ int32_t s = bignum_digits(c)[0] | ~0x7fffffff;
if ((s & fix_mask) == fix_mask) return fixnum_of_int(s);
}
if ((SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) != 0)) ||
(!SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) == 0)))
{ bignum_digits(c)[i] = 0;
bignum_digits(c)[i-1] |= ~0x7fffffff;
numhdr(c) -= pack_hdrlength(1);
return c;
}
numhdr(c) -= pack_hdrlength(i - j);
bignum_digits(c)[j+1] = 0;
bignum_digits(c)[j] |= ~0x7fffffff;
if (SIXTY_FOUR_BIT)
{ i = (i+2) & ~1;
j = (j+2) & ~1; /* Round up to odd index */
}
else
{ i = (i+1) | 1;
j = (j+1) | 1; /* Round up to odd index */
}
if (i != j) bignum_digits(c)[j] = make_bighdr(i - j);
return c;
}
return c;
}
else
{ bignum_digits(c)[i] = carry;
return lengthen_by_one_bit(c, carry);
}
}
static Lisp_Object plusib(Lisp_Object a, Lisp_Object b)
/*
* Add a fixnum to a bignum, returning a result as a fixnum or bignum
* depending on its size. This seems much nastier than one would have
* hoped.
*/
{
int32_t len = bignum_length(b)-CELL, i, sign = int_of_fixnum(a), s;
Lisp_Object c, nil;
len = len/4; /* This is always 4 because even on a 64-bit */
/* machine where CELL=8 I use 4-byte B-digits */
if (len == 1)
{ int32_t t;
/*
* Partly because it will be a common case and partly because it has
* various special cases I have special purpose code to cope with
* adding a fixnum to a one-word bignum.
*/
s = (int32_t)bignum_digits(b)[0] + sign;
t = s + s;
if (top_bit_set(s ^ t)) /* needs to turn into two-word bignum */
{ if (s < 0) return make_two_word_bignum(-1, clear_top_bit(s));
else return make_two_word_bignum(0, s);
}
t = s & fix_mask; /* Will it fit as a fixnum? */
if (t == 0 || t == fix_mask) return fixnum_of_int(s);
/* here the result is a one-word bignum */
return make_one_word_bignum(s);
}
/*
* Now, after all the silly cases have been handled, I have a calculation
* which seems set to give a multi-word result. The result here can at
* least never shrink to a fixnum since subtracting a fixnum can at
* most shrink the length of a number by one word. I omit the stack-
* check here in the hope that code here never nests enough for trouble.
*/
push(b);
c = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+4*len);
pop(b);
errexit();
s = bignum_digits(b)[0] + clear_top_bit(sign);
bignum_digits(c)[0] = clear_top_bit(s);
if (sign >= 0) sign = 0; else sign = 0x7fffffff; /* extend the sign */
len--;
for (i=1; i<len; i++)
{ s = bignum_digits(b)[i] + sign + top_bit(s);
bignum_digits(c)[i] = clear_top_bit(s);
}
/* Now just the most significant digit remains to be processed */
if (sign != 0) sign = -1;
{ s = bignum_digits(b)[i] + sign + top_bit(s);
if (!signed_overflow(s)) /* did it overflow? */
{
/*
* Here the most significant digit did not produce an overflow, but maybe
* what we actually had was some cancellation and the MSD is now zero
* or -1, so that the number should shrink...
*/
if ((s == 0 && (bignum_digits(c)[i-1] & 0x40000000) == 0) ||
(s == -1 && (bignum_digits(c)[i-1] & 0x40000000) != 0))
{ /* shrink the number */
numhdr(c) -= pack_hdrlength(1L);
if (s == -1) bignum_digits(c)[i-1] |= ~0x7fffffff;
/*
* Now sometimes the shrinkage will leave a padding word, sometimes it
* will really allow me to save space. As a jolly joke with a 64-bit
* system I need padding if there have been an odd number of (32-bit)
* words of bignum data while with a 32-bit system the header word is
* 32-bits wide and I need padding if there are ar even number of additional
* data words.
*/
if ((SIXTY_FOUR_BIT && ((i & 1) != 0)) ||
(!SIXTY_FOUR_BIT && ((i & 1) == 0)))
{ bignum_digits(c)[i] = 0; /* leave the unused word tidy */
return c;
}
/*
* Having shrunk the number I am leaving a doubleword of unallocated space
* in the heap. Dump a header word into it to make it look like an
* 8-byte bignum since that will allow the garbage collector to handle it.
* It I left it containing arbitrary junk I could wreck myself. The
* make_bighdr(2L) makes a header for a number that fills 2 32-bit words
* in all.
*/
*(Header *)&bignum_digits(c)[i] = make_bighdr(2L);
return c;
}
bignum_digits(c)[i] = s; /* length unchanged */
return c;
}
/*
* Here the result is one word longer than the input-bignum.
* Once again SOMTIMES this will not involve allocating more store,
* but just encroaching into the previously unused word that was padding
* things out to a multiple of 8 bytes.
*/
if ((SIXTY_FOUR_BIT && ((i & 1) == 0)) ||
(!SIXTY_FOUR_BIT && ((i & 1) == 1)))
{ bignum_digits(c)[i++] = clear_top_bit(s);
bignum_digits(c)[i] = top_bit_set(s) ? -1 : 0;
numhdr(c) += pack_hdrlength(1L);
return c;
}
push(c);
/*
* NB on the next line there is a +8. One +4 is because I had gone len--
* somewhere earlier. The other +4 is to increase the length of the number
* by one word.
*/
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+8+4*len);
pop(c);
errexit();
for (i=0; i<len; i++)
bignum_digits(b)[i] = bignum_digits(c)[i];
/*
* I move the top digit across by hand since if the number is negative
* I must lost its top bit
*/
bignum_digits(b)[i++] = clear_top_bit(s);
/* Now the one-word extension to the number */
bignum_digits(b)[i++] = top_bit_set(s) ? -1 : 0;
/*
* Finally because I know that I expanded into a new doubleword I should
* tidy up the second word of the newly allocated pair.
*/
bignum_digits(b)[i] = 0;
return b;
}
}
