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

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

/*
 * Arithmetic functions.
 *    remainder, =,
 *    minusp, plusp
 *
 */

/*
 * 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: 4439bf35 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

Lisp_Object rembi(Lisp_Object a, Lisp_Object b)
{
    Lisp_Object nil;
    if (b == fixnum_of_int(0)) return aerror2("bad arg for remainder", a, b);
    else if (b == fixnum_of_int(1) ||
             b == fixnum_of_int(-1)) return fixnum_of_int(0);
    quotbn1(a, int_of_fixnum(b));
/*
 * If the divisor was a fixnum then the remainder will be a fixnum too.
 */
    errexit();
    return fixnum_of_int(nwork);
}

Lisp_Object rembb(Lisp_Object a, Lisp_Object b)
{
    Lisp_Object nil;
    quotbb(a, b);
    errexit();
    return mv_2;
}

#ifdef COMMON

static Lisp_Object remis(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remir(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remif(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remsi(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remsb(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remsr(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remsf(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object rembs(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object rembr(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object rembf(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remri(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remrs(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remrb(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remrr(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remrf(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remfi(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remfs(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remfb(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remfr(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

static Lisp_Object remff(Lisp_Object a, Lisp_Object b)
{
    return aerror2("bad arg for remainder", a, b);
}

#endif /* COMMON */

Lisp_Object Cremainder(Lisp_Object a, Lisp_Object b)
{
    int32 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 aa = int_of_fixnum(a);
                int32 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);
            }
#ifdef COMMON
/*
 * 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.
 */
    case TAG_SFLOAT:
            return remis(a, b);
#endif
    case TAG_NUMBERS:
            {   int32 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) == 8 &&
                    bignum_digits(b)[0] == 0x08000000)
                        return fixnum_of_int(0);
                else return a;
#ifdef COMMON
        case TYPE_RATNUM:
                return remir(a, b);
#endif
        default:
                return aerror1("Bad arg for remainder",  b);
                }
            }
#ifdef COMMON
    case TAG_BOXFLOAT:
            return remif(a, b);
#else
    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);
        }
#endif
    default:
            return aerror1("Bad arg for remainder",  b);
        }
#ifdef COMMON
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)0xf) + TAG_SFLOAT;
            }
    case TAG_NUMBERS:
            {   int32 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);
        }
#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 rembi(a, b);
#ifdef COMMON
            case TAG_SFLOAT:
                    return rembs(a, b);
#endif
            case TAG_NUMBERS:
                    {   int32 hb = type_of_header(numhdr(b));
                        switch (hb)
                        {
                case TYPE_BIGNUM:
                        return rembb(a, b);
#ifdef COMMON
                case TYPE_RATNUM:
                        return rembr(a, b);
#endif
                default:
                        return aerror1("Bad arg for remainder",  b);
                        }
                    }
#ifdef COMMON
            case TAG_BOXFLOAT:
                    return rembf(a, b);
#endif
            default:
                    return aerror1("Bad arg for remainder",  b);
                }
#ifdef COMMON
    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 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);
                }
#endif
    default:    return aerror1("Bad arg for remainder",  a);
            }
        }
case TAG_BOXFLOAT:
        switch ((int)b & TAG_BITS)
        {
#ifndef COMMON
    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);
            }
    default:
            return aerror1("Bad arg for remainder",  b);
#else
    case TAG_FIXNUM:
            return remfi(a, b);
    case TAG_SFLOAT:
            return remfs(a, b);
    case TAG_NUMBERS:
            {   int32 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);
#endif
        }
default:
        return aerror1("Bad arg for remainder",  a);
    }
}

/*
 * In the cases that I expect to be most speed-critical I will
 * implement "mod" directly. But in a load of other cases I will just
 * activate the existing "remainder" code and then make a few final
 * adjustments.  This MAY lead to error messages (on modulus by zero)
 * mentioning remainder rather than mod....
 * I will leave in the whole structure of separate functions for each
 * case since that will be useful if I ever need to come back here and
 * fine-tune more of the type-combinations. As a first pass I give
 * special treatment to (fixnum,fixnum) and (bignum,fixnum)
 */

static Lisp_Object mod_by_rem(Lisp_Object a, Lisp_Object b)
{
    Lisp_Object nil;
    CSLbool sb = minusp(b);
    errexit();
    a = Cremainder(a, b);   /* Repeats dispatch on argument type. Sorry */
    errexit();
    if (sb)
    {   if (plusp(a))
        {   errexit();
            a = plus2(a, b);
        }
    }
    else if (minusp(a))
    {   errexit();
        a = plus2(a, b);
    }
    return a;
}

static Lisp_Object modib(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modbi(Lisp_Object a, Lisp_Object b)
{
    Lisp_Object nil = C_nil;
    int32 bb = int_of_fixnum(b);
    if (b == fixnum_of_int(0)) return aerror2("bad arg for mod", a, b);
    if (bb == 1 || bb == -1) nwork = 0;
    else quotbn1(a, bb);
/*
 * If the divisor was a fixnum then the remainder will be a fixnum too.
 */
    errexit();
    if (bb < 0)
    {   if (nwork > 0) nwork += bb;
    }
    else if (nwork < 0) nwork += bb;
    return fixnum_of_int(nwork);
}

static Lisp_Object modbb(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

#ifdef COMMON

static Lisp_Object modis(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modir(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modif(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modsi(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modsb(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modsr(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modsf(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modbs(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modbr(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modbf(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modri(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modrs(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modrb(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modrr(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modrf(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modfi(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modfs(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modfb(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object modfr(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

static Lisp_Object ccl_modff(Lisp_Object a, Lisp_Object b)
{
    return mod_by_rem(a, b);
}

#endif /* COMMON */

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 p = int_of_fixnum(a);
                int32 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);
            }
#ifdef COMMON
/*
 * 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);
#endif
    case TAG_NUMBERS:
            {   int32 hb = type_of_header(numhdr(b));
                switch (hb)
                {
        case TYPE_BIGNUM:
                return modib(a, b);
#ifdef COMMON
        case TYPE_RATNUM:
                return modir(a, b);
#endif
        default:
                return aerror1("Bad arg for mod",  b);
                }
            }
#ifdef COMMON
    case TAG_BOXFLOAT:
            return modif(a, b);
#endif
    default:
            return aerror1("Bad arg for mod",  b);
        }
#ifdef COMMON
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)0xf) + TAG_SFLOAT;
            }
    case TAG_NUMBERS:
            {   int32 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);
        }
#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 modbi(a, b);
#ifdef COMMON
            case TAG_SFLOAT:
                    return modbs(a, b);
#endif
            case TAG_NUMBERS:
                    {   int32 hb = type_of_header(numhdr(b));
                        switch (hb)
                        {
                case TYPE_BIGNUM:
                        return modbb(a, b);
#ifdef COMMON
                case TYPE_RATNUM:
                        return modbr(a, b);
#endif
                default:
                        return aerror1("Bad arg for mod",  b);
                        }
                    }
#ifdef COMMON
            case TAG_BOXFLOAT:
                    return modbf(a, b);
#endif
            default:
                    return aerror1("Bad arg for mod",  b);
                }
#ifdef COMMON
    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 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);
                }
#endif
    default:    return aerror1("Bad arg for mod",  a);
            }
        }
#ifdef COMMON
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 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);
        }
#endif
default:
        return aerror1("Bad arg for mod",  a);
    }
}

CSLbool zerop(Lisp_Object a)
{
    switch ((int)a & TAG_BITS)
    {
case TAG_FIXNUM:
        return (a == fixnum_of_int(0));
#ifdef COMMON
case TAG_NUMBERS:
        /* #C(r i) must satisfy zerop is r and i both do */
        if (is_complex(a) && zerop(real_part(a)))
            return zerop(imag_part(a));
        else return NO;
case TAG_SFLOAT:
/*
 * The code here assumes that the the floating point number zero
 * is represented by a zero bit-pattern... see onep() for a more
 * cautious way of coding things.
 */
        return ((a & 0x7ffffff8) == 0); /* Strip sign bit as well as tags */
#endif
case TAG_BOXFLOAT:
        return (float_of_number(a) == 0.0);
default:
        return NO;
    }
}

CSLbool onep(Lisp_Object a)
{
    switch ((int)a & TAG_BITS)
    {
case TAG_FIXNUM:
        return (a == fixnum_of_int(1));
#ifdef COMMON
case TAG_NUMBERS:
        /* #C(r i) must satisfy onep(r) and zerop(i) */
        if (is_complex(a) && onep(real_part(a)))
            return zerop(imag_part(a));
        else return NO;
case TAG_SFLOAT:
        {   Float_union w;
            w.f = (float)1.0;
            return (a == (w.i & ~(int32)0xf) + TAG_SFLOAT);
        }
#endif
case TAG_BOXFLOAT:
        return (float_of_number(a) == 1.0);
default:
        return NO;
    }
}

/*
 * sign testing
 */

CSLbool minusp(Lisp_Object a)
{
    switch ((int)a & TAG_BITS)
    {
case TAG_FIXNUM:
        return ((int32)a < 0);
#ifdef COMMON
case TAG_SFLOAT:
        {   Float_union aa;
            aa.i = a - TAG_SFLOAT;
            return (aa.f < 0.0);
        }
#endif
case TAG_NUMBERS:
        {   int32 ha = type_of_header(numhdr(a));
            switch (ha)
            {
    case TYPE_BIGNUM:
                {   int32 l = (bignum_length(a)-CELL-4)/4;
                    return ((int32)bignum_digits(a)[l] < (int32)0);
                }
#ifdef COMMON
    case TYPE_RATNUM:
                return minusp(numerator(a));
#endif
    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;
    }
}


CSLbool plusp(Lisp_Object a)
{
    switch ((int)a & TAG_BITS)
    {
case TAG_FIXNUM:
        return (a > fixnum_of_int(0));
#ifdef COMMON
case TAG_SFLOAT:
        {   Float_union aa;
            aa.i = a - TAG_SFLOAT;
            return (aa.f > 0.0);
        }
#endif
case TAG_NUMBERS:
        {   int32 ha = type_of_header(numhdr(a));
            switch (ha)
            {
    case TYPE_BIGNUM:
                {   int32 l = (bignum_length(a)-CELL-4)/4;
/* This is OK because a bignum can never have the value zero */
                    return ((int32)bignum_digits(a)[l] >= (int32)0);
                }
#ifdef COMMON
    case TYPE_RATNUM:
                return plusp(numerator(a));
#endif
    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;
    }
}


/*
 * Numeric equality - note that comparisons involving non-numbers
 * are errors here (unlike the position in eql, equal, equalp).  Also
 * this must be coded so that it never provokes garbage collection.
 */

#ifdef COMMON
static CSLbool numeqis(Lisp_Object a, Lisp_Object b)
{
    Float_union bb;
    bb.i = b - TAG_SFLOAT;
    return ((double)int_of_fixnum(a) == (double)bb.f);
}

static CSLbool numeqic(Lisp_Object a, Lisp_Object b)
{
    if (!zerop(imag_part(b))) return NO;
    else return numeq2(a, real_part(b));
}
#endif

#define numeqif(a,b) ((double)int_of_fixnum(a) == float_of_number(b))

#ifdef COMMON
#define numeqsi(a, b) numeqis(b, a)
#endif

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 w, len;
    unsigned32 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 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;
}

#ifdef COMMON
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 dx, w, len;
    unsigned32 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 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 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;
}

#define numeqsc(a, b) numeqic(a, b)

static CSLbool numeqsf(Lisp_Object a, Lisp_Object b)
{
    Float_union aa;
    aa.i = a - TAG_SFLOAT;
    return ((double)aa.f == float_of_number(b));
}

#define numeqbs(a, b) numeqsb(b, a)
#endif

static CSLbool numeqbb(Lisp_Object a, Lisp_Object b)
{
    int32 la = bignum_length(a);
    if (la != (int32)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;
}

#ifdef COMMON
#define numeqbc(a, b) numeqic(a, b)
#endif

#define numeqbf(a, b) numeqsb(b, a)

#ifdef COMMON
#define numeqrs(a, b) numeqsr(b, a)

static CSLbool numeqrr(Lisp_Object a, Lisp_Object b)
{
    return numeq2(numerator(a), numerator(b)) &&
           numeq2(denominator(a), denominator(b));
}

#define numeqrc(a, b) numeqic(a, b)

#define numeqrf(a, b) numeqsr(b, a)

#define numeqci(a, b) numeqic(b, a)

#define numeqcs(a, b) numeqic(b, a)

#define numeqcb(a, b) numeqic(b, a)

#define numeqcr(a, b) numeqic(b, a)

static CSLbool numeqcc(Lisp_Object a, Lisp_Object b)
{
    return numeq2(real_part(a), real_part(b)) &&
           numeq2(imag_part(a), imag_part(b));
}

#define numeqcf(a, b) numeqic(b, a)
#endif

#define numeqfi(a, b) numeqif(b, a)

#ifdef COMMON
#define numeqfs(a, b) numeqsf(b, a)
#endif

#define numeqfb(a, b) numeqbf(b, a)

#ifdef COMMON
#define numeqfr(a, b) numeqrf(b, a)

#define numeqfc(a, b) numeqic(a, b)
#endif

static CSLbool numeqff(Lisp_Object a, Lisp_Object b)
{
    return (float_of_number(a) == float_of_number(b));
}

/*
 * This comparison must signal an error on non-numeric operands in
 * Common Lisp mode, but behave as EQ in CSL mode.
 */

#ifdef COMMON
#  define differenta aerror1("Bad arg for =",  a); return 0
#  define differentb aerror1("Bad arg for =",  b); return 0
#else
#  define differenta return NO
#  define differentb return NO
#endif

CSLbool numeq2(Lisp_Object a, Lisp_Object b)
{
#ifndef COMMON
    if (a == b) return YES;
#endif
    switch ((int)a & TAG_BITS)
    {
case TAG_FIXNUM:
        switch ((int)b & TAG_BITS)
        {
    case TAG_FIXNUM:
#ifdef COMMON
            return (a == b);
#else
            return NO;
#endif
#ifdef COMMON
    case TAG_SFLOAT:
            return numeqis(a, b);
#endif
    case TAG_NUMBERS:
            {   int32 hb = type_of_header(numhdr(b));
                switch (hb)
                {
        case TYPE_BIGNUM:
                return 0;
#ifdef COMMON
        case TYPE_RATNUM:
                return 0;
        case TYPE_COMPLEX_NUM:
                return numeqic(a, b);   /* (= 2 #C(2.0 0.0))?  Yuk */
#endif
        default:
                differentb;
                }
            }
    case TAG_BOXFLOAT:
            return numeqif(a, b);
    default:
            differentb;
        }
#ifdef COMMON
case TAG_SFLOAT:
        switch ((int)b & TAG_BITS)
        {
    case TAG_FIXNUM:
            return numeqsi(a, b);
    case TAG_SFLOAT:
            return (a == b) ||
            (a == TAG_SFLOAT && b == TAG_SFLOAT|0x80000000) ||
            (a == TAG_SFLOAT|0x80000000 && b == TAG_SFLOAT); /* !!! */
    case TAG_NUMBERS:
            {   int32 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;
        }
#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 0;
#ifdef COMMON
            case TAG_SFLOAT:
                    return numeqbs(a, b);
#endif
            case TAG_NUMBERS:
                    {   int32 hb = type_of_header(numhdr(b));
                        switch (hb)
                        {
                case TYPE_BIGNUM:
                        return numeqbb(a, b);
#ifdef COMMON
                case TYPE_RATNUM:
                        return 0;
                case TYPE_COMPLEX_NUM:
                        return numeqbc(a, b);
#endif
                default:
                        differentb;
                        }
                    }
            case TAG_BOXFLOAT:
                    return numeqbf(a, b);
            default:
                    differentb;
                }
#ifdef COMMON
    case TYPE_RATNUM:
                switch ((int)b & TAG_BITS)
                {
            case TAG_FIXNUM:
                    return 0;
            case TAG_SFLOAT:
                    return numeqrs(a, b);
            case TAG_NUMBERS:
                    {   int32 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 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;
                }
#endif
    default:    differenta;
            }
        }
case TAG_BOXFLOAT:
        switch ((int)b & TAG_BITS)
        {
    case TAG_FIXNUM:
            return numeqfi(a, b);
#ifdef COMMON
    case TAG_SFLOAT:
            return numeqfs(a, b);
#endif
    case TAG_NUMBERS:
            {   int32 hb = type_of_header(numhdr(b));
                switch (hb)
                {
        case TYPE_BIGNUM:
                return numeqfb(a, b);
#ifdef COMMON
        case TYPE_RATNUM:
                return numeqfr(a, b);
        case TYPE_COMPLEX_NUM:
                return numeqfc(a, b);
#endif
        default:
                differentb;
                }
            }
    case TAG_BOXFLOAT:
            return numeqff(a, b);
    default:
            differentb;
        }
default:
        differenta;
    }
}

/* end of arith11.c */