Exemplo n.º 1
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;
    }
}
Exemplo n.º 2
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;
}
Exemplo n.º 3
0
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;
}
Exemplo n.º 4
0
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;
}
Exemplo n.º 5
0
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;
}
Exemplo n.º 6
0
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);
    }
}
Exemplo n.º 7
0
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;
}
Exemplo n.º 8
0
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;
    }
}
Exemplo n.º 9
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;
}
Exemplo n.º 10
0
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;
}
Exemplo n.º 11
0
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;
    }
}
Exemplo n.º 12
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;
    }
}
Exemplo n.º 13
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;
    }
}
Exemplo n.º 14
0
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;
}
Exemplo n.º 15
0
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);
    }
}
Exemplo n.º 16
0
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);
}
Exemplo n.º 17
0
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);
    }
}
Exemplo n.º 18
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;
    }
}