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);
}
}
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 difference2(Lisp_Object a, Lisp_Object b)
{
Lisp_Object nil;
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
if (is_fixnum(a))
{
int32_t r = int_of_fixnum(a) - int_of_fixnum(b);
int32_t t = r & fix_mask;
if (t == 0 || t == fix_mask) return fixnum_of_int(r);
else return make_one_word_bignum(r);
}
else if (b != ~0x7ffffffe) return plus2(a, 2*TAG_FIXNUM-b);
else
{ push(a);
b = make_one_word_bignum(-int_of_fixnum(b));
break;
}
case TAG_NUMBERS:
push(a);
if (type_of_header(numhdr(b)) == TYPE_BIGNUM) b = negateb(b);
else b = negate(b);
break;
case TAG_BOXFLOAT:
default:
push(a);
b = negate(b);
break;
}
pop(a);
errexit();
return plus2(a, b);
}
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;
}
}
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 modulus(Lisp_Object a, Lisp_Object b)
{
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.
*/
{ int32_t p = int_of_fixnum(a);
int32_t q = int_of_fixnum(b);
if (q == 0) return aerror2("bad arg for mod", a, b);
p = p % q;
if (q < 0)
{ if (p > 0) p += q;
}
else if (p < 0) p += q;
/* No overflow is possible in a modulus operation */
return fixnum_of_int(p);
}
/*
* Common Lisp defines a meaning for the modulus 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.
*/
case TAG_SFLOAT:
return modis(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modib(a, b);
case TYPE_RATNUM:
return modir(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modif(a, b);
default:
return aerror1("Bad arg for mod", b);
}
case TAG_SFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return modsi(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 modsb(a, b);
case TYPE_RATNUM:
return modsr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modsf(a, b);
default:
return aerror1("Bad arg for mod", 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 modbi(a, b);
case TAG_SFLOAT:
return modbs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modbb(a, b);
case TYPE_RATNUM:
return modbr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modbf(a, b);
default:
return aerror1("Bad arg for mod", b);
}
case TYPE_RATNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return modri(a, b);
case TAG_SFLOAT:
return modrs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modrb(a, b);
case TYPE_RATNUM:
return modrr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return modrf(a, b);
default:
return aerror1("Bad arg for mod", b);
}
default:
return aerror1("Bad arg for mod", a);
}
}
case TAG_BOXFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return modfi(a, b);
case TAG_SFLOAT:
return modfs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return modfb(a, b);
case TYPE_RATNUM:
return modfr(a, b);
default:
return aerror1("Bad arg for mod", b);
}
}
case TAG_BOXFLOAT:
return ccl_modff(a, b);
default:
return aerror1("Bad arg for mod", b);
}
default:
return aerror1("Bad arg for mod", a);
}
}
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);
}
}
CSLbool numeq2(Lisp_Object a, Lisp_Object b)
{
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return (a == b);
case TAG_SFLOAT:
return numeqis(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return 0; /* fixnum can not be equal to a bignum */
case TYPE_RATNUM:
return 0;
case TYPE_COMPLEX_NUM:
return numeqic(a, b); /* (= 2 #C(2.0 0.0))? Yuk */
default:
differentb;
}
}
case TAG_BOXFLOAT:
return numeqif(a, b);
default:
differentb;
}
case TAG_SFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return numeqsi(a, b);
case TAG_SFLOAT:
/*
* I take a decision here that short floats will not honour the idea
* of NaNs in this comparison.
*/
return (a == b) ||
(a == TAG_SFLOAT && b == TAG_SFLOAT|0x80000000) ||
(a == TAG_SFLOAT|0x80000000 && b == TAG_SFLOAT); /* !!! */
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return numeqsb(a, b);
case TYPE_RATNUM:
return numeqsr(a, b);
case TYPE_COMPLEX_NUM:
return numeqsc(a, b);
default:
differentb;
}
}
case TAG_BOXFLOAT:
return numeqsf(a, b);
default:
differentb;
}
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 0;
case TAG_SFLOAT:
return numeqbs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return numeqbb(a, b);
case TYPE_RATNUM:
return 0;
case TYPE_COMPLEX_NUM:
return numeqbc(a, b);
default:
differentb;
}
}
case TAG_BOXFLOAT:
return numeqbf(a, b);
default:
differentb;
}
case TYPE_RATNUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return 0;
case TAG_SFLOAT:
return numeqrs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return 0;
case TYPE_RATNUM:
return numeqrr(a, b);
case TYPE_COMPLEX_NUM:
return numeqrc(a, b);
default:
differentb;
}
}
case TAG_BOXFLOAT:
return numeqrf(a, b);
default:
differentb;
}
case TYPE_COMPLEX_NUM:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return numeqci(a, b);
case TAG_SFLOAT:
return numeqcs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return numeqcb(a, b);
case TYPE_RATNUM:
return numeqcr(a, b);
case TYPE_COMPLEX_NUM:
return numeqcc(a, b);
default:
differentb;
}
}
case TAG_BOXFLOAT:
return numeqcf(a, b);
default:
differentb;
}
default:
differenta;
}
}
case TAG_BOXFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return numeqfi(a, b);
case TAG_SFLOAT:
return numeqfs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return numeqfb(a, b);
case TYPE_RATNUM:
return numeqfr(a, b);
case TYPE_COMPLEX_NUM:
return numeqfc(a, b);
default:
differentb;
}
}
case TAG_BOXFLOAT:
return numeqff(a, b);
default:
differentb;
}
default:
differenta;
}
}
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);
}
Lisp_Object negate(Lisp_Object a)
{
#ifdef COMMON
Lisp_Object nil; /* needed for errexit() */
#endif
switch ((int)a & TAG_BITS)
{
case TAG_FIXNUM:
{ int32_t aa = -int_of_fixnum(a);
/*
* negating the number -#x8000000 (which is a fixnum) yields a value
* which just fails to be a fixnum.
*/
if (aa != 0x08000000) return fixnum_of_int(aa);
else return make_one_word_bignum(aa);
}
#ifdef COMMON
case TAG_SFLOAT:
{ Float_union aa;
aa.i = a - TAG_SFLOAT;
aa.f = (float) (-aa.f);
return (aa.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
#endif
case TAG_NUMBERS:
{ int32_t ha = type_of_header(numhdr(a));
switch (ha)
{
case TYPE_BIGNUM:
return negateb(a);
#ifdef COMMON
case TYPE_RATNUM:
{ Lisp_Object n = numerator(a),
d = denominator(a);
push(d);
n = negate(n);
pop(d);
errexit();
return make_ratio(n, d);
}
case TYPE_COMPLEX_NUM:
{ Lisp_Object r = real_part(a),
i = imag_part(a);
push(i);
r = negate(r);
pop(i);
errexit();
push(r);
i = negate(i);
pop(r);
errexit();
return make_complex(r, i);
}
#endif
default:
return aerror1("bad arg for minus", a);
}
}
case TAG_BOXFLOAT:
{ double d = float_of_number(a);
return make_boxfloat(-d, type_of_header(flthdr(a)));
}
default:
return aerror1("bad arg for minus", a);
}
}
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;
}
}
double float_of_number(Lisp_Object a)
/*
* Return a (double precision) floating point value for the given Lisp
* number, or 0.0 in case of trouble. This is often called in circumstances
* where I already know the type of its argument and so its type-dispatch
* is unnecessary - in doing so I am trading off performance against
* code repetition.
*/
{
if (is_fixnum(a)) return (double)int_of_fixnum(a);
#ifdef COMMON
else if (is_sfloat(a))
{ Float_union w;
w.i = a - TAG_SFLOAT;
return (double)w.f;
}
#endif
else if (is_bfloat(a))
{ int32_t h = type_of_header(flthdr(a));
switch (h)
{
#ifdef COMMON
case TYPE_SINGLE_FLOAT:
return (double)single_float_val(a);
#endif
case TYPE_DOUBLE_FLOAT:
return double_float_val(a);
#ifdef COMMON
case TYPE_LONG_FLOAT:
return (double)long_float_val(a);
#endif
default:
return 0.0;
}
}
else
{ Header h = numhdr(a);
int x1;
double r1;
switch (type_of_header(h))
{
case TYPE_BIGNUM:
r1 = bignum_to_float(a, length_of_header(h), &x1);
return ldexp(r1, x1);
#ifdef COMMON
case TYPE_RATNUM:
{ int x2;
Lisp_Object na = numerator(a);
a = denominator(a);
if (is_fixnum(na)) r1 = float_of_number(na), x1 = 0;
else r1 = bignum_to_float(na,
length_of_header(numhdr(na)), &x1);
if (is_fixnum(a)) r1 = r1 / float_of_number(a), x2 = 0;
else r1 = r1 / bignum_to_float(a,
length_of_header(numhdr(a)), &x2);
/* Floating point overflow can only arise in this ldexp() */
return ldexp(r1, x1 - x2);
}
#endif
default:
/*
* If the value was non-numeric or a complex number I hand back 0.0,
* and since I am supposed to have checked the object type already
* this OUGHT not to arrive - bit raising an exception seems over-keen.
*/
return 0.0;
}
}
}
Lisp_Object plus2(Lisp_Object a, Lisp_Object b)
/*
* I probably want to change the specification of plus2 so that the fixnum +
* fixnum case is always expected to be done before the main body of the code
* is entered. Well maybe even if I do that it then costs very little to
* include the fixnum code here as well, so I will not delete it.
*/
{
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. Note that even if this becomes a bignum it can only be a
* one word one.
*/
{ int32_t r = int_of_fixnum(a) + int_of_fixnum(b);
int32_t t = r & fix_mask;
if (t == 0 || t == fix_mask) return fixnum_of_int(r);
else return make_one_word_bignum(r);
}
#ifdef COMMON
case TAG_SFLOAT:
return plusis(a, b);
#endif
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusib(a, b);
#ifdef COMMON
case TYPE_RATNUM:
return plusir(a, b);
case TYPE_COMPLEX_NUM:
return plusic(a, b);
#endif
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusif(a, b);
default:
return aerror1("bad arg for plus", b);
}
#ifdef COMMON
case TAG_SFLOAT:
switch (b & TAG_BITS)
{
case TAG_FIXNUM:
return plussi(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 plussb(a, b);
case TYPE_RATNUM:
return plussr(a, b);
case TYPE_COMPLEX_NUM:
return plussc(a, b);
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plussf(a, b);
default:
return aerror1("bad arg for plus", b);
}
#endif
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 plusbi(a, b);
#ifdef COMMON
case TAG_SFLOAT:
return plusbs(a, b);
#endif
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusbb(a, b);
#ifdef COMMON
case TYPE_RATNUM:
return plusbr(a, b);
case TYPE_COMPLEX_NUM:
return plusbc(a, b);
#endif
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusbf(a, b);
default:
return aerror1("bad arg for plus", b);
}
#ifdef COMMON
case TYPE_RATNUM:
switch (b & TAG_BITS)
{
case TAG_FIXNUM:
return plusri(a, b);
case TAG_SFLOAT:
return plusrs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusrb(a, b);
case TYPE_RATNUM:
return plusrr(a, b);
case TYPE_COMPLEX_NUM:
return plusrc(a, b);
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusrf(a, b);
default:
return aerror1("bad arg for plus", b);
}
case TYPE_COMPLEX_NUM:
switch (b & TAG_BITS)
{
case TAG_FIXNUM:
return plusci(a, b);
case TAG_SFLOAT:
return pluscs(a, b);
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return pluscb(a, b);
case TYPE_RATNUM:
return pluscr(a, b);
case TYPE_COMPLEX_NUM:
return pluscc(a, b);
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return pluscf(a, b);
default:
return aerror1("bad arg for plus", b);
}
#endif
default: return aerror1("bad arg for plus", a);
}
}
case TAG_BOXFLOAT:
switch ((int)b & TAG_BITS)
{
case TAG_FIXNUM:
return plusfi(a, b);
#ifdef COMMON
case TAG_SFLOAT:
return plusfs(a, b);
#endif
case TAG_NUMBERS:
{ int32_t hb = type_of_header(numhdr(b));
switch (hb)
{
case TYPE_BIGNUM:
return plusfb(a, b);
#ifdef COMMON
case TYPE_RATNUM:
return plusfr(a, b);
case TYPE_COMPLEX_NUM:
return plusfc(a, b);
#endif
default:
return aerror1("bad arg for plus", b);
}
}
case TAG_BOXFLOAT:
return plusff(a, b);
default:
return aerror1("bad arg for plus", b);
}
default:
return aerror1("bad arg for plus", a);
}
}
