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);
}
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;
}
}
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 Lisp_Object plusis(Lisp_Object a, Lisp_Object b)
{
Float_union bb;
bb.i = b - TAG_SFLOAT;
bb.f = (float)((float)int_of_fixnum(a) + bb.f);
return (bb.i & ~(int32_t)0xf) + TAG_SFLOAT;
}
static Lisp_Object plusif(Lisp_Object a, Lisp_Object b)
/*
* Fixnum plus boxed-float.
*/
{
double d = (double)int_of_fixnum(a) + float_of_number(b);
return make_boxfloat(d, type_of_header(flthdr(b)));
}
Lisp_Object sub1(Lisp_Object p)
/*
* Decrement a number. Short cut when the number is a fixnum, otherwise
* just hand over to the general addition code.
*/
{
if (is_fixnum(p))
{ if (p == ~0x7ffffffe) /* The ONLY possible overflow case here */
return make_one_word_bignum(int_of_fixnum(p) - 1);
else return (Lisp_Object)(p - 0x10);
}
else return plus2(p, fixnum_of_int(-1));
}
static Lisp_Object Lscale_float(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
double d = float_of_number(a);
CSL_IGNORE(nil);
if (!is_fixnum(b)) return aerror("scale-float");
d = ldexp(d, int_of_fixnum(b));
#ifdef COMMON
if (is_sfloat(a)) return onevalue(make_sfloat(d));
else
#endif
if (!is_bfloat(a)) return aerror1("bad arg for scale-float", a);
else return onevalue(make_boxfloat(d, type_of_header(flthdr(a))));
}
Lisp_Object rembi(Lisp_Object a, Lisp_Object b)
{
Lisp_Object nil;
if (b == fixnum_of_int(0)) return aerror2("bad arg for remainder", a, b);
else if (b == fixnum_of_int(1) ||
b == fixnum_of_int(-1)) return fixnum_of_int(0);
quotbn1(a, int_of_fixnum(b));
/*
* If the divisor was a fixnum then the remainder will be a fixnum too.
*/
errexit();
return fixnum_of_int(nwork);
}
static Lisp_Object modbi(Lisp_Object a, Lisp_Object b)
{
Lisp_Object nil = C_nil;
int32_t bb = int_of_fixnum(b);
if (b == fixnum_of_int(0)) return aerror2("bad arg for mod", a, b);
if (bb == 1 || bb == -1) nwork = 0;
else quotbn1(a, bb);
/*
* If the divisor was a fixnum then the remainder will be a fixnum too.
*/
errexit();
if (bb < 0)
{ if (nwork > 0) nwork += bb;
}
else if (nwork < 0) nwork += bb;
return fixnum_of_int(nwork);
}
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);
}
}
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;
}
static CSLbool numeqis(Lisp_Object a, Lisp_Object b)
{
Float_union bb;
bb.i = b - TAG_SFLOAT;
return ((double)int_of_fixnum(a) == (double)bb.f);
}
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);
}
}
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);
}
}
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;
}
}
}
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;
}
}