reduce-historical/r37/lisp/csl/cslbase/arith01.c

/*  arith01.c                         Copyright (C) 1990-2002 Codemist Ltd */

/*
 * Arithmetic functions.
 *        Addition of generic numbers
 *        and in particular a lot of bignum support.
 *
 */

/*
 * This code may be used and modified, and redistributed in binary
 * or source form, subject to the "CCL Public License", which should
 * accompany it. This license is a variant on the BSD license, and thus
 * permits use of code derived from this in either open and commercial
 * projects: but it does require that updates to this code be made
 * available back to the originators of the package.
 * Before merging other code in with this or linking this code
 * with other packages or libraries please check that the license terms
 * of the other material are compatible with those of this.
 */



/* Signature: 66948772 08-Apr-2002 */

#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#include <math.h>

#include "machine.h"
#include "tags.h"
#include "cslerror.h"
#include "externs.h"
#include "arith.h"
#ifdef TIMEOUT
#include "timeout.h"
#endif

/*
 * I start off with a collection of utility functions that create
 * Lisp structures to represent various sorts of numbers
 * and which extract values from same.
 * The typedefs that explain the layout of these structures are in "tags.h"
 */

Lisp_Object make_one_word_bignum(int32 n)
/*
 * n is an integer - create a bignum representation of it.  This is
 * done when n is outside the range 0xf8000000 to 0x07ffffff.
 */
{   Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+4);
    Lisp_Object nil;
    errexit();
    bignum_digits(w)[0] = n;
#ifdef ADDRESS_64
    bignum_digits(w)[1] = 0;  /* padding */
#endif
    return w;
}

Lisp_Object make_two_word_bignum(int32 a1, unsigned32 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;
#ifndef ADDRESS_64
    bignum_digits(w)[2] = 0;
#endif
    return w;
}

#ifdef COMMON
Lisp_Object make_sfloat(double d)
/*
 * Turn a regular floating point value into a Lisp "short float", which
 * is an immediate object obtained by using the bottom 4 bits of a 32-bit
 * word as tag, and the rest as just whatever would stand for a regular
 * single precision value.  In doing the conversion here I ignore
 * rounding etc - short floats are to save heap turn-over, but will
 * not give robust numeric results.
 */
{
    Float_union w;
    w.f = (float)d;
    return (w.i & ~(int32)0xf) + TAG_SFLOAT;
}
#endif

Lisp_Object make_boxfloat(double a, int32 type)
/*
 * Make a boxed float (single, double or long according to the type specifier)
 * if type==0 this makes a short float
 */
{
    Lisp_Object r, nil;
#ifndef COMMON
    CSL_IGNORE(type);
#endif
#ifdef COMMON
    switch (type)
    {
case 0:
        {   Float_union aa;
            aa.f = (float)a;
            return (aa.i & ~(intxx)0xf) + TAG_SFLOAT;
        }
case TYPE_SINGLE_FLOAT:
        r = getvector(TAG_BOXFLOAT, TYPE_SINGLE_FLOAT, sizeof(Single_Float));
        errexit();
        single_float_val(r) = (float)a;
        return r;
default: /* TYPE_DOUBLE_FLOAT I hope */
#endif
        r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT, sizeof(Double_Float));
        errexit();
        double_float_val(r) = a;
        return r;
#ifdef COMMON
case TYPE_LONG_FLOAT:
        r = getvector(TAG_BOXFLOAT, TYPE_LONG_FLOAT, sizeof(Long_Float));
        errexit();
        long_float_val(r) = a;
        return r;
    }
#endif
}

static double bignum_to_float(Lisp_Object v, int32 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 n = (h-CELL-4)/4;  /* Last index into the data */
    int x = 31*(int)n;
    int32 msd = (int32)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;
}

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

int32 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 == 8) 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;
    }
}

#ifdef ADDRESS_64

int64 sixty_four_bits(Lisp_Object a)
{
    return (int64)thirty_two_bits(a); /* Inadequate really! */
}

#endif

#ifdef COMMON
Lisp_Object make_complex(Lisp_Object r, Lisp_Object i)
{
    Lisp_Object v, nil = C_nil;
/*
 * Here r and i are expected to be either both rational (which in this
 * context includes the case of integer values) or both of the same
 * floating point type.  It is assumed that this has already been
 * arranged by here.
 */
    if (i == fixnum_of_int(0)) return r;
    stackcheck2(0, r, i);
    push2(r, i);
    v = getvector(TAG_NUMBERS, TYPE_COMPLEX_NUM, sizeof(Complex_Number));
/*
 * The vector r has uninitialized contents here - dodgy.  If the call
 * to getvector succeeded then I fill it in, otherwise I will not
 * refer to it again, and I think that unreferenced vectors containing junk
 * are OK.
 */
    pop2(i, r);
    errexit();
    real_part(v) = r;
    imag_part(v) = i;
    return v;
}

Lisp_Object make_ratio(Lisp_Object p, Lisp_Object q)
/*
 * By the time this is called (p/q) must be in its lowest terms, q>0
 */
{
    Lisp_Object v, nil = C_nil;
    if (q == fixnum_of_int(1)) return p;
    stackcheck2(0, p, q);
    push2(p, q);
    v = getvector(TAG_NUMBERS, TYPE_RATNUM, sizeof(Rational_Number));
    pop2(q, p);
    errexit();
    numerator(v) = p;
    denominator(v) = q;
    return v;
}

#endif

/*
 * The next bit of code seems pretty dreadful, but I think that is just
 * what generic arithmetic is all about.  The code for plus2 is written
 * as a dispatch function into over 30 separate possible type-specific
 * versions of the code.  In a very few simple (and performance-critical)
 * cases the code is written in-line in plus2 - in particular arithmetic
 * on fixnums is done that way.  Similarly for other cases.
 * I Use one-character suffices to remind me about types:
 *          i       fixnum
 *          b       bignum
 *          r       ratio
 *          s       short float
 *          f       boxed float (single/double/long)
 *          c       complex
 *
 * Throughout this code I am going to IGNORE floating point exceptions,
 * at least for a first attempt.  Decent detection of and recovery after
 * floating point overflow seems an extra unpleasant distraction!  Note
 * that C allows me to trap the SIGFPE exception, but returning from
 * the exception handler gives undefined behaviour - one is expected
 * to longjmp out, which means accepting the cost of using setjmp.
 *
 * It would perhaps be reasonable to write the dispatch code as a big
 * macro so that the versions for plus, times etc could all be kept
 * in step - I have not done that (a) because the macro would have been
 * bigger than I like macros to be (b) it would have involved token-
 * splicing (or VERY many parameters) to generate the names of the
 * separate type-specific procedures and (c) doing it by hand allows me
 * total flexibility about coding various cases in-line.
 */

#ifdef COMMON

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)0xf) + TAG_SFLOAT;
}
#endif

/*
 * Bignums are represented as vectors where the most significant 32-bit
 * digit is treated as signed, and the remaining ones are unsigned.
 */

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 len = bignum_length(b)-CELL, i, sign = int_of_fixnum(a), s;
    Lisp_Object c, nil;
    len = len/4;
    if (len == 1)
    {   int32 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)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.
 */
#ifdef ADDRESS_64
                if ((i & 1) != 0)
#else
                if ((i & 1) == 0)
#endif
                {   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.
 */
#ifdef ADDRESS_64
        if ((i & 1) == 0)
#else
        if ((i & 1) == 1)
#endif
        {   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);
        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];
        bignum_digits(b)[i++] = clear_top_bit(s);
        bignum_digits(b)[i] = top_bit_set(s) ? -1 : 0;
        return b;
    }
}

#ifdef COMMON
static Lisp_Object plusir(Lisp_Object a, Lisp_Object b)
/*
 * fixnum and ratio, but also valid for bignum and ratio.
 * Note that if the inputs were in lowest terms there is no need for
 * and GCD calculations here.
 */
{
    Lisp_Object nil;
    push(b);
    a = times2(a, denominator(b));
    nil = C_nil;
    if (!exception_pending()) a = plus2(a, numerator(stack[0]));
    pop(b);
    errexit();
    return make_ratio(a, denominator(b));
}

static Lisp_Object plusic(Lisp_Object a, Lisp_Object b)
/*
 * real of any sort plus complex.
 */
{
    Lisp_Object nil;
    push(b);
    a = plus2(a, real_part(b));
    pop(b);
    errexit();
/*
 * make_complex() takes responsibility for mapping #C(n 0) onto n
 */
    return make_complex(a, imag_part(b));
}
#endif

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

#ifdef COMMON
#define plussi(a, b) plusis(b, a)

#define plussb(a, b) plusbs(b, a)

#define plussr(a, b) plusrs(b, a)

#define plussc(a, b) plusic(a, b)

#endif

static Lisp_Object plussf(Lisp_Object a, Lisp_Object b)
/*
 * This can be used for any rational value plus a boxed-float. plusif()
 * is separated just for (minor) efficiency reasons.
 */
{
    double d = float_of_number(a) + float_of_number(b);
    return make_boxfloat(d, type_of_header(flthdr(b)));
}

#define plusbi(a, b) plusib(b, a)

#ifdef COMMON

static Lisp_Object plusbs(Lisp_Object a, Lisp_Object b)
{
    double d = float_of_number(a) + float_of_number(b);
    return make_sfloat(d);
}

#endif

Lisp_Object lengthen_by_one_bit(Lisp_Object a, int32 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 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 i;
        push(a);
        b = getvector(TAG_NUMBERS, TYPE_BIGNUM, len+4);
        pop(a);
        errexit();
        len = (len-CELL)/4;
        for (i=0; i<len; i++)
            bignum_digits(b)[i] = clear_top_bit(bignum_digits(a)[i]);
        bignum_digits(b)[len] = top_bit_set(msd) ? -1 : 0;
        bignum_digits(b)[len+1] = 0;
        return b;
    }
    else
/*
 * .. whereas sometimes I have a spare word already available.
 */
    {   numhdr(a) += pack_hdrlength(1L);
        len = (len-CELL)/4;
        bignum_digits(a)[len-1] = clear_top_bit(bignum_digits(a)[len-1]);
        bignum_digits(a)[len] = top_bit_set(msd) ? -1 : 0;
        return a;
    }
}

static Lisp_Object plusbb(Lisp_Object a, Lisp_Object b)
/*
 * add two bignums.
 */
{
    int32 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 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 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;
#ifndef ADDRESS_64
            bignum_digits(w)[2] = 0;
#endif
            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 msd;
        bignum_digits(c)[i] = carry;
        if (carry == 0)
        {   int32 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 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.
 */
#ifdef ADDRESS_64
            if (j == i-1 && (i & 1) != 0)
#else
            if (j == i-1 && (i & 1) == 0)
#endif
            {   numhdr(c) -= pack_hdrlength(1L);
                return c;
            }
            numhdr(c) -= pack_hdrlength(i - j);
#ifdef ADDRESS_64
            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 */
#endif
/*
 * 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.
 */
            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 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 s = bignum_digits(c)[0] | ~0x7fffffff;
                if ((s & fix_mask) == fix_mask) return fixnum_of_int(s);
            }
#ifdef ADDRESS_64
            if (j == i-1 && (i & 1) != 0)
#else
            if (j == i-1 && (i & 1) == 0)
#endif
            {   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;
#ifdef ADDRESS_64
            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 */
#endif
            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);
    }
}

#ifdef COMMON
#define plusbr(a, b) plusir(a, b)

#define plusbc(a, b) plusic(a, b)
#endif

#define plusbf(a, b) plussf(a, b)

#ifdef COMMON
#define plusri(a, b) plusir(b, a)

#define plusrs(a, b) plusbs(a, b)

#define plusrb(a, b) plusri(a, b)

static Lisp_Object plusrr(Lisp_Object a, Lisp_Object b)
/*
 * Adding two ratios involves some effort to keep the result in
 * lowest terms.
 */
{
    Lisp_Object nil = C_nil;
    Lisp_Object na = numerator(a), nb = numerator(b);
    Lisp_Object da = denominator(a), db = denominator(b);
    Lisp_Object w = nil;
    push5(na, nb, da, db, nil);
#define g   stack[0]
#define db  stack[-1]
#define da  stack[-2]
#define nb  stack[-3]
#define na  stack[-4]
    g = gcd(da, db);
    nil = C_nil;
    if (exception_pending()) goto fail;
/*
 * all the calls to quot2() in this procedure are expected - nay required -
 * to give exact integer quotients.
 */
    db = quot2(db, g);
    nil = C_nil;
    if (exception_pending()) goto fail;
    g = quot2(da, g);
    nil = C_nil;
    if (exception_pending()) goto fail;
    na = times2(na, db);
    nil = C_nil;
    if (exception_pending()) goto fail;
    nb = times2(nb, g);
    nil = C_nil;
    if (exception_pending()) goto fail;
    na = plus2(na, nb);
    nil = C_nil;
    if (exception_pending()) goto fail;
    da = times2(da, db);
    nil = C_nil;
    if (exception_pending()) goto fail;
    g = gcd(na, da);
    nil = C_nil;
    if (exception_pending()) goto fail;
    na = quot2(na, g);
    nil = C_nil;
    if (exception_pending()) goto fail;
    da = quot2(da, g);
    nil = C_nil;
    if (exception_pending()) goto fail;
    w = make_ratio(na, da);
/*
 * All the goto statements and the label seem a fair way of expressing
 * the common action that has to be taken if an error or interrupt is
 * detected during any of the intermediate steps here.  Anyone who
 * objects can change it if they really want...
 */
fail:
    popv(5);
    return w;
#undef na
#undef nb
#undef da
#undef db
#undef g
}

#define plusrc(a, b) plusic(a, b)

#define plusrf(a, b) plussf(a, b)

#define plusci(a, b) plusic(b, a)

#define pluscs(a, b) plussc(b, a)

#define pluscb(a, b) plusbc(b, a)

#define pluscr(a, b) plusrc(b, a)

static Lisp_Object pluscc(Lisp_Object a, Lisp_Object b)
/*
 * Add complex values.
 */
{
    Lisp_Object c, nil;
    push2(a, b);
    c = plus2(imag_part(a), imag_part(b));
    pop2(b, a);
    errexit();
    a = plus2(real_part(a), real_part(b));
    errexit();
    return make_complex(a, c);
}

#define pluscf(a, b) plusfc(b, a)
#endif

#define plusfi(a, b) plusif(b, a)

#ifdef COMMON
#define plusfs(a, b) plussf(b, a)
#endif

#define plusfb(a, b) plusbf(b, a)

#ifdef COMMON
#define plusfr(a, b) plusrf(b, a)

#define plusfc(a, b) plusic(a, b)
#endif

static Lisp_Object plusff(Lisp_Object a, Lisp_Object b)
/*
 * Add two boxed floats - the type of the result must match the
 * longer of the types of the arguments, hence the extra
 * messing about.
 */
{
#ifdef COMMON
    int32 ha = type_of_header(flthdr(a)), hb = type_of_header(flthdr(b));
#endif
    double d;
/*
 * This is written as a declaration followed by a separate assignment to
 * d because I hit a compiler bug on a VAX once otherwise.
 */
    d = float_of_number(a) + float_of_number(b);
#ifdef COMMON
    if (ha == TYPE_LONG_FLOAT || hb == TYPE_LONG_FLOAT)
        ha = TYPE_LONG_FLOAT;
    else if (ha == TYPE_DOUBLE_FLOAT || hb == TYPE_DOUBLE_FLOAT)
        ha = TYPE_DOUBLE_FLOAT;
    else ha = TYPE_SINGLE_FLOAT;
    return make_boxfloat(d, ha);
#else
    return make_boxfloat(d, TYPE_DOUBLE_FLOAT);
#endif
}

/*
 * and now for the dispatch code...
 */

/*
 * The following verifies that a number is properly formatted - a
 * fixnum if small enough or a decently normalised bignum.  For use when
 * there is suspicion of a bug wrt such matters. Call is
 *   validate_number("msg", numberToCheck, nX, nY)
 * where nX and nY must be numbers and are shown in any
 * diagnostic.
 */

void validate_number(char *s, Lisp_Object a, Lisp_Object b, Lisp_Object c)
{
    int32 la, w, msd;
    if (!is_numbers(a)) return;
    la = (length_of_header(numhdr(a))-CELL-4)/4;
    if (la < 0)
        {   trace_printf("%s: number with no digits (%.8x)\n", s, numhdr(a));
            if (is_number(b)) prin_to_trace(b), trace_printf("\n");
            if (is_number(c)) prin_to_trace(c), trace_printf("\n");
            my_exit(EXIT_FAILURE);
        }
    if (la == 0)
    {   msd = bignum_digits(a)[0];
        w = msd & fix_mask;
        if (w == 0 || w == fix_mask)
        {   trace_printf("%s: %.8x should be fixnum\n", s, msd);
            if (is_number(b)) prin_to_trace(b), trace_printf("\n");
            if (is_number(c)) prin_to_trace(c), trace_printf("\n");
            my_exit(EXIT_FAILURE);
        }
        if (signed_overflow(msd))
        {   trace_printf("%s: %.8x should be two-word\n", s, msd);
            if (is_number(b)) prin_to_trace(b), trace_printf("\n");
            if (is_number(c)) prin_to_trace(c), trace_printf("\n");
            my_exit(EXIT_FAILURE);
        }
        return;
    }
    msd = bignum_digits(a)[la];
    if (signed_overflow(msd))
    {   trace_printf("%s: %.8x should be longer\n", s, msd);
        if (is_number(b)) prin_to_trace(b), trace_printf("\n");
        if (is_number(c)) prin_to_trace(c), trace_printf("\n");
        my_exit(EXIT_FAILURE);
    }
    if (msd == 0 && ((msd = bignum_digits(a)[la-1]) & 0x40000000) == 0)
    {   trace_printf("%s: 0: %.8x should be shorter\n", s, msd);
        if (is_number(b)) prin_to_trace(b), trace_printf("\n");
        if (is_number(c)) prin_to_trace(c), trace_printf("\n");
        my_exit(EXIT_FAILURE);
    }
    if (msd == -1 && ((msd = bignum_digits(a)[la-1]) & 0x40000000) != 0)
    {   trace_printf("%s: -1: %.8x should be shorter\n", s, msd);
        if (is_number(b)) prin_to_trace(b), trace_printf("\n");
        if (is_number(c)) prin_to_trace(c), trace_printf("\n");
        my_exit(EXIT_FAILURE);
    }
}


Lisp_Object 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.
 */
            {   int32 r = int_of_fixnum(a) + int_of_fixnum(b);
                int32 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 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)0xf) + TAG_SFLOAT;
            }
    case TAG_NUMBERS:
            {   int32 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 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 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 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 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 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);
    }
}

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 r = int_of_fixnum(a) - int_of_fixnum(b);
            int32 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 add1(Lisp_Object p)
/*
 * Increment a number.  Short cut when the number is a fixnum, otherwise
 * just hand over to the general addition code.
 */
{
    if (is_fixnum(p))
    {   unsigned32 r = (int32)p + 0x10;
                                  /* fixnums have data shifted left 4 bits */
        if (r == ~0x7ffffffe)     /* The ONLY possible overflow case here  */
            return make_one_word_bignum(1 + int_of_fixnum(p));
        else return (Lisp_Object)r;
    }
    else return plus2(p, fixnum_of_int(1));
}

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

/* end of arith01.c */