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); } }