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

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

/*
 * Arithmetic functions... specials for Reduce (esp. factoriser)
 *
 */


/*
 * 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: 0d21727a 08-Apr-2002 */

#define FP_EVALUATE   1

#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"
#include "entries.h"
#ifdef TIMEOUT
#include "timeout.h"
#endif


Lisp_Object Lfrexp(Lisp_Object nil, Lisp_Object a)
{
    double d;
    int x;
    d = float_of_number(a);
    d = frexp(d, &x);
    if (d == 1.0) d = 0.5, x++;
    a = make_boxfloat(d, TYPE_DOUBLE_FLOAT);
    errexit();
    return Lcons(nil, fixnum_of_int((int32)x), a);
}

Lisp_Object Lmodular_difference(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    int32 r;
    CSL_IGNORE(nil);
    r = int_of_fixnum(a) - int_of_fixnum(b);
    if (r < 0) r += current_modulus;
    return onevalue(fixnum_of_int(r));
}

Lisp_Object Lmodular_minus(Lisp_Object nil, Lisp_Object a)
{
    CSL_IGNORE(nil);
    if (a != fixnum_of_int(0))
    {   int32 r = current_modulus - int_of_fixnum(a);
        a = fixnum_of_int(r);
    }
    return onevalue(a);
}

Lisp_Object Lmodular_number(Lisp_Object nil, Lisp_Object a)
{
    int32 r;
    a = Cremainder(a, fixnum_of_int(current_modulus));
    errexit();
    r = int_of_fixnum(a);
    if (r < 0) r += current_modulus;
    return onevalue(fixnum_of_int(r));
}

Lisp_Object Lmodular_plus(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    int32 r;
    CSL_IGNORE(nil);
    r = int_of_fixnum(a) + int_of_fixnum(b);
    if (r >= current_modulus) r -= current_modulus;
    return onevalue(fixnum_of_int(r));
}

Lisp_Object Lmodular_reciprocal(Lisp_Object nil, Lisp_Object n)
{
    int32 a, b, x, y;
    CSL_IGNORE(nil);
    a = current_modulus;
    b = int_of_fixnum(n);
    x = 0;
    y = 1;
    if (b == 0) return aerror1("modular-reciprocal", n);
    while (b != 1)
    {   int32 w = a / b;
        int32 t = b;
        b = a - b*w;
        a = t;
        t = y;
        y = x - y*w;
        x = t;
    }
    if (y < 0) y += current_modulus;
    return onevalue(fixnum_of_int(y));
}

Lisp_Object Lmodular_times(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    unsigned32 h, l, r, cm;
    int32 aa, bb;
    CSL_IGNORE(nil);
    cm = (unsigned32)current_modulus;
    aa = int_of_fixnum(a);
    bb = int_of_fixnum(b);
/*
 * The constant 46341 is sqrt(2^31) suitable rounded - if my modulus
 * is no bigger than that then a and b will both be strictly smaller,
 * and hence a*b will be < 2^31 and hence in range for 32-bit signed
 * arithmetic.  I make this test because I expect Imultiply and Idivide
 * to be pretty painful, while regular C multiplication and division are
 * (probably!) much better.
 */
    if (cm <= 46341U) r = (aa * bb) % cm;
    else
    {
#ifdef MULDIV64
        r = (unsigned32)(((unsigned64)aa * (unsigned64)bb) % (unsigned32)cm);
#else
        Dmultiply(h, l, aa, bb, 0);
        Ddivide(r, l, h, l, cm);
#endif
    }
    return onevalue(fixnum_of_int(r));
}

Lisp_Object Lmodular_quotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    push(a);
    b = Lmodular_reciprocal(nil, b);
    pop(a);
    errexit();
    return Lmodular_times(nil, a, b);
}

Lisp_Object Lmodular_expt(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    int32 x, r, p;
    unsigned32 h, l;
    CSL_IGNORE(nil);
    x = int_of_fixnum(b);
    if (x == 0) return onevalue(fixnum_of_int(1));
    p = int_of_fixnum(a);
/*
 * I could play games here on half-length current_modulus and use
 * native C arithmetic, but I judge this case not to be quite that
 * critically important. Also on 64-bit machines I could do more
 * work in-line.
 */
    p = p % current_modulus; /* In case somebody is being silly! */
    while ((x & 1) == 0)
    {   Dmultiply(h, l, p, p, 0);
        Ddivide(p, l, h, l, current_modulus);
        x = x/2;
    }
    r = p;
    while (x != 1)
    {   Dmultiply(h, l, p, p, 0);
        Ddivide(p, l, h, l, current_modulus);
        x = x/2;
        if ((x & 1) != 0)
        {   Dmultiply(h, l, r, p, 0);
            Ddivide(r, l, h, l, current_modulus);
        }
    }
    return onevalue(fixnum_of_int(r));
}

Lisp_Object Lset_small_modulus(Lisp_Object nil, Lisp_Object a)
{
    int32 r, old = current_modulus;
    CSL_IGNORE(nil);
    if (!is_fixnum(a)) return aerror1("set-small-modulus", a);
    r = int_of_fixnum(a);
/*
 * I COULD allow a small modulus of up to 2^27, but for compatibility
 * with Cambridge Lisp I will limit myself to 24 bits.
 */
    if (r > 0x00ffffff) return aerror1("set-small-modulus", a);
    current_modulus = r;
    return onevalue(fixnum_of_int(old));
}

Lisp_Object Liadd1(Lisp_Object nil, Lisp_Object a)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a)) return aerror1("iadd1", a);
    return onevalue((Lisp_Object)((int32)a + 0x10));
}

Lisp_Object Lidifference(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("idifference", a, b);
    return onevalue((Lisp_Object)((int32)a - (int32)b + TAG_FIXNUM));
}

/*
 * xdifference is provided just for the support of the CASE operator. It
 * subtracts its arguments but returns NIL if either argument is not
 * an small integer or if the result overflows.
 */

Lisp_Object Lxdifference(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    int32 r;
    if (!is_fixnum(a) || !is_fixnum(b)) return onevalue(nil);
    r = int_of_fixnum(a) - int_of_fixnum(b);
    if (r < -0x08000000 || r > 0x07ffffff) return onevalue(nil);
    return onevalue(fixnum_of_int(r));
}

Lisp_Object Ligreaterp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("igreaterp", a, b);
    return onevalue(Lispify_predicate(a > b));
}

Lisp_Object Lilessp(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilessp", a, b);
    return onevalue(Lispify_predicate(a < b));
}

Lisp_Object Ligeq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("igeq", a, b);
    return onevalue(Lispify_predicate(a >= b));
}

Lisp_Object Lileq(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ileq", a, b);
    return onevalue(Lispify_predicate(a <= b));
}

static Lisp_Object MS_CDECL Lilogand(Lisp_Object nil, int nargs, ...)
{
    va_list a;
    Lisp_Object r;
    if (nargs == 0) return onevalue(fixnum_of_int(-1));
    if (nargs > ARG_CUT_OFF) return aerror("too many args for ilogand");
    CSL_IGNORE(nil);
    va_start(a, nargs);
    r = va_arg(a, Lisp_Object);
    if (!is_fixnum(r)) return aerror1("ilogand", r);
    while (--nargs != 0)
    {   Lisp_Object w = va_arg(a, Lisp_Object);
        if (!is_fixnum(w))
        {   va_end(a);
            return aerror1("ilogand", w);
        }
        r = (Lisp_Object)((int32)r & (int32)w);
    }
    va_end(a);
    return onevalue(r);
}

static Lisp_Object MS_CDECL Lilogor(Lisp_Object nil, int nargs, ...)
{
    va_list a;
    Lisp_Object r;
    if (nargs == 0) return onevalue(fixnum_of_int(0));
    if (nargs > ARG_CUT_OFF) return aerror("too many args for ilogor");
    CSL_IGNORE(nil);
    va_start(a, nargs);
    r = va_arg(a, Lisp_Object);
    if (!is_fixnum(r)) return aerror1("ilogor", r);
    while (--nargs != 0)
    {   Lisp_Object w = va_arg(a, Lisp_Object);
        if (!is_fixnum(w))
        {   va_end(a);
            return aerror1("ilogor", w);
        }
        r = (Lisp_Object)((int32)r | (int32)w);
    }
    va_end(a);
    return onevalue(r);
}

static Lisp_Object MS_CDECL Lilogxor(Lisp_Object nil, int nargs, ...)
{
    va_list a;
    Lisp_Object r;
    if (nargs == 0) return onevalue(fixnum_of_int(0));
    if (nargs > ARG_CUT_OFF) return aerror("too many args for ilogxor");
    CSL_IGNORE(nil);
    va_start(a, nargs);
    r = va_arg(a, Lisp_Object);
    if (!is_fixnum(r)) return aerror1("ilogxor", r);
    while (--nargs != 0)
    {   Lisp_Object w = va_arg(a, Lisp_Object);
        if (!is_fixnum(w))
        {   va_end(a);
            return aerror1("ilogxor", w);
        }
        r = (Lisp_Object)(((int32)r ^ (int32)w) + TAG_FIXNUM);
    }
    va_end(a);
    return onevalue(r);
}

static Lisp_Object Lilogand2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilogand", a, b);
    return onevalue(a & b);    
}

static Lisp_Object Lilogor2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilogor", a, b);
    return onevalue(a | b);    
}

static Lisp_Object Lilogxor2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("ilogxor", a, b);
    return onevalue((a ^ b) + TAG_FIXNUM);    
}

Lisp_Object Limin(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("imin", a, b);
    return onevalue(a < b ? a : b);
}

Lisp_Object Limax(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("imax", a, b);
    return onevalue(a > b ? a : b);
}

Lisp_Object Liminus(Lisp_Object nil, Lisp_Object a)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a)) return aerror1("iminus", a);
    return onevalue((Lisp_Object)(2*TAG_FIXNUM - (int32)a));
}

Lisp_Object Liminusp(Lisp_Object nil, Lisp_Object a)
{
    CSL_IGNORE(nil);
    return onevalue(Lispify_predicate((int32)a < (int32)fixnum_of_int(0)));
}

static Lisp_Object MS_CDECL Liplus(Lisp_Object nil, int nargs, ...)
{
    va_list a;
    Lisp_Object r;
    if (nargs == 0) return onevalue(fixnum_of_int(0));
    if (nargs > ARG_CUT_OFF) return aerror("too many args for iplus");
    CSL_IGNORE(nil);
    va_start(a, nargs);
    r = va_arg(a, Lisp_Object);
    if (!is_fixnum(r)) return aerror1("iplus", r);
    while (--nargs != 0)
    {   Lisp_Object w = va_arg(a, Lisp_Object);
        if (!is_fixnum(w))
        {   va_end(a);
            return aerror1("iplus", w);
        }
        r = (Lisp_Object)((int32)r + (int32)w - TAG_FIXNUM);
    }
    va_end(a);
    return onevalue(r);
}

Lisp_Object Liplus2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("iplus2", a, b);
    return onevalue((Lisp_Object)((int32)a + (int32)b - TAG_FIXNUM));
}

Lisp_Object Liquotient(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    int32 aa, bb, c;
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b) ||
        b == fixnum_of_int(0)) return aerror2("iquotient", a, b);
/* C does not define the exact behaviour of /, % on -ve args */
    aa = int_of_fixnum(a);
    bb = int_of_fixnum(b);
    c = aa % bb;
    if (aa < 0)
    {   if (c > 0) c -= bb;
    }
    else if (c < 0) c += bb;
    return onevalue(fixnum_of_int((aa-c)/bb));
}

Lisp_Object Liremainder(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    int32 aa, bb, c;
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b) ||
        b == fixnum_of_int(0)) return aerror2("iremainder", a, b);
/* C does not define the exact behaviour of /, % on -ve args */
    aa = int_of_fixnum(a);
    bb = int_of_fixnum(b);
    c = aa % bb;
    if (aa < 0)
    {   if (c > 0) c -= bb;
    }
    else if (c < 0) c += bb;
    return onevalue(fixnum_of_int(c));
}

Lisp_Object Lirightshift(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("irightshift", a, b);
    return onevalue(fixnum_of_int(int_of_fixnum(a) >> int_of_fixnum(b)));
}

Lisp_Object Lisub1(Lisp_Object nil, Lisp_Object a)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a)) return aerror1("isub1", a);
    return onevalue((Lisp_Object)((int32)a - 0x10));
}

static Lisp_Object MS_CDECL Litimes(Lisp_Object nil, int nargs, ...)
{
    va_list a;
    Lisp_Object rr;
    int32 r;
    if (nargs == 0) return onevalue(fixnum_of_int(1));
    if (nargs > ARG_CUT_OFF) return aerror("too many args for itimes");
    CSL_IGNORE(nil);
    va_start(a, nargs);
    rr = va_arg(a, Lisp_Object);
    if (!is_fixnum(rr)) return aerror1("itimes", rr);
    r = int_of_fixnum(rr);
    while (nargs-- != 0)
    {   Lisp_Object w = va_arg(a, Lisp_Object);
        if (!is_fixnum(w))
        {   va_end(a);
            return aerror1("itimes", w);
        }
        r = r * int_of_fixnum(w);
    }
    va_end(a);
    return onevalue(fixnum_of_int(r));
}

Lisp_Object Litimes2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
    CSL_IGNORE(nil);
    if (!is_fixnum(a) || !is_fixnum(b)) return aerror2("itimes2", a, b);
    return onevalue(fixnum_of_int(int_of_fixnum(a) * int_of_fixnum(b)));
}

Lisp_Object Lionep(Lisp_Object nil, Lisp_Object a)
{
    CSL_IGNORE(nil);
    return onevalue(Lispify_predicate((int32)a == (int32)fixnum_of_int(1)));
}

Lisp_Object Lizerop(Lisp_Object nil, Lisp_Object a)
{
    CSL_IGNORE(nil);
    return onevalue(Lispify_predicate((int32)a == (int32)fixnum_of_int(0)));
}

#ifdef FP_EVALUATE

static double fp_args[32];
static double fp_stack[16];

/* codes 0 to 31 just load up arguments */
#define FP_RETURN        32
#define FP_PLUS          33
#define FP_DIFFERENCE    34
#define FP_TIMES         35
#define FP_QUOTIENT      36
#define FP_MINUS         37
#define FP_SQUARE        38
#define FP_CUBE          39
#define FP_SIN           40
#define FP_COS           41
#define FP_TAN           42
#define FP_EXP           43
#define FP_LOG           44
#define FP_SQRT          45


static Lisp_Object Lfp_eval(Lisp_Object nil, Lisp_Object code,
                                             Lisp_Object args)
/*
 * The object of this code is to support fast evaluation of numeric
 * expressions.  The first argument is a vector of byte opcodes, while
 * the second arg is a list of floating point values whose value will (or
 * at least may) be used.  There are at most 32 values in this list.
 */
{
    int n = 0;
    double w;
    unsigned char *p;
    if (!is_vector(code)) return aerror("fp-evaluate");
    while (consp(args))
    {   fp_args[n++] = float_of_number(qcar(args));
        args = qcdr(args);
    }
    n = 0;
    p = &ucelt(code, 0);
    for (;;)
    {   int op = *p++;
/*
 * Opcodes 0 to 31 just load up the corresponding input value.
 */
        if (op < 32)
        {   fp_stack[n++] = fp_args[op];
            continue;
        }
        switch (op)
        {
    default:
            return aerror("Bad op in fp-evaluate");
    case FP_RETURN:
            args = make_boxfloat(fp_stack[0], TYPE_DOUBLE_FLOAT);
            errexit();
            return onevalue(args);
    case FP_PLUS:
            n--;
            fp_stack[n] += fp_stack[n-1];
            continue;
    case FP_DIFFERENCE:
            n--;
            fp_stack[n] -= fp_stack[n-1];
            continue;
    case FP_TIMES:
            n--;
            fp_stack[n] *= fp_stack[n-1];
            continue;
    case FP_QUOTIENT:
            n--;
            fp_stack[n] /= fp_stack[n-1];
            continue;
    case FP_MINUS:
            fp_stack[n] = -fp_stack[n];
            continue;
    case FP_SQUARE:
            fp_stack[n] *= fp_stack[n];
            continue;
    case FP_CUBE:
            w = fp_stack[n];
            w *= w;
            fp_stack[n] *= w;
            continue;
    case FP_SIN:
            fp_stack[n] = sin(fp_stack[n]);
            continue;
    case FP_COS:
            fp_stack[n] = cos(fp_stack[n]);
            continue;
    case FP_TAN:
            fp_stack[n] = tan(fp_stack[n]);
            continue;
    case FP_EXP:
            fp_stack[n] = exp(fp_stack[n]);
            continue;
    case FP_LOG:
            fp_stack[n] = log(fp_stack[n]);
            continue;
    case FP_SQRT:
            fp_stack[n] = sqrt(fp_stack[n]);
            continue;
        }
    }
}

#endif

setup_type const arith12_setup[] =
{
    {"frexp",                   Lfrexp, too_many_1, wrong_no_1},
    {"modular-difference",      too_few_2, Lmodular_difference, wrong_no_2},
    {"modular-minus",           Lmodular_minus, too_many_1, wrong_no_1},
    {"modular-number",          Lmodular_number, too_many_1, wrong_no_1},
    {"modular-plus",            too_few_2, Lmodular_plus, wrong_no_2},
    {"modular-quotient",        too_few_2, Lmodular_quotient, wrong_no_2},
    {"modular-reciprocal",      Lmodular_reciprocal, too_many_1, wrong_no_1},
    {"modular-times",           too_few_2, Lmodular_times, wrong_no_2},
    {"modular-expt",            too_few_2, Lmodular_expt, wrong_no_2},
    {"set-small-modulus",       Lset_small_modulus, too_many_1, wrong_no_1},
    {"iadd1",                   Liadd1, too_many_1, wrong_no_1},
    {"idifference",             too_few_2, Lidifference, wrong_no_2},
    {"xdifference",             too_few_2, Lxdifference, wrong_no_2},
    {"igeq",                    too_few_2, Ligeq, wrong_no_2},
    {"igreaterp",               too_few_2, Ligreaterp, wrong_no_2},
    {"ileq",                    too_few_2, Lileq, wrong_no_2},
    {"ilessp",                  too_few_2, Lilessp, wrong_no_2},
    {"ilogand",                 Lidentity, Lilogand2, Lilogand},
    {"ilogor",                  Lidentity, Lilogor2, Lilogor},
    {"ilogxor",                 Lidentity, Lilogxor2, Lilogxor},
    {"imax",                    too_few_2, Limax, wrong_no_2},
    {"imin",                    too_few_2, Limin, wrong_no_2},
    {"iminus",                  Liminus, too_many_1, wrong_no_1},
    {"iminusp",                 Liminusp, too_many_1, wrong_no_1},
    {"iplus",                   Lidentity, Liplus2, Liplus},
    {"iplus2",                  too_few_2, Liplus2, wrong_no_2},
    {"iquotient",               too_few_2, Liquotient, wrong_no_2},
    {"iremainder",              too_few_2, Liremainder, wrong_no_2},
    {"irightshift",             too_few_2, Lirightshift, wrong_no_2},
    {"isub1",                   Lisub1, too_many_1, wrong_no_1},
    {"itimes",                  Lidentity, Litimes2, Litimes},
    {"itimes2",                 too_few_2, Litimes2, wrong_no_2},
    {"ionep",                   Lionep, too_many_1, wrong_no_1},
    {"izerop",                  Lizerop, too_many_1, wrong_no_1},
#ifdef FP_EVALUATE
    {"fp-evaluate",             too_few_2, Lfp_eval, wrong_no_2},
#endif
    {NULL,                      0, 0, 0}
};

/* end of arith12.c */