<<>>
    <<SchemeArithmeticImpl.mesa>>
        <<Copyright Ó 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Last changed by Pavel on March 15, 1989 3:06:41 am PST>>
        <<Michael Plass, December 27, 1990 4:17 pm PST>>
        <<>>
    DIRECTORY
        Basics USING [CompareInt, Comparison, LongNumber],
        BigCardinals USING [BigAdd, BigCARD, BigCompare, BigDivMod, BigFail, BigFromCard, BigGCD, BigMultiply, BigOdd, BigSubtract, 
        BigToCard, TimesTwoToTheNth, Zero],
        Real USING [Fix, FScale, Round],
        RealFns USING [ArcTan, Cos, Exp, Ln, Power, Sin, SqRt, Tan],
        Scheme USING [Any, ArithOp, Bignum, Car, Cdr, Complain, Complex, Cons, DefinePrimitive, Environment, false, Fixnum, Flonum, Number, 
        NumberKind, NumberRep, Primitive, ProperList, Ratnum, RegisterInit, Symbol, true, undefined];

    SchemeArithmeticImpl: CEDAR PROGRAM
    IMPORTS Basics, BigCardinals, Real, RealFns, Scheme
    EXPORTS Scheme
    ~ BEGIN OPEN Scheme;

        PrimitiveProc: TYPE ~ PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any Ź NIL];

<<Arithmetic Primitives>>
    SmallValue: TYPE ~ [-100..1000];

    smallFixnumTable: REF ARRAY SmallValue OF Fixnum ~ InitSmallFixnumTable[];
        InitSmallFixnumTable: PROC RETURNS [a: REF ARRAY SmallValue OF Fixnum] ~ {
            a Ź NEW[ARRAY SmallValue OF Fixnum];
            FOR i: INT IN SmallValue DO
                a[i] Ź NEW[INT Ź i];
                ENDLOOP;
            };

    MakeFixnum: PUBLIC PROC [int: INT] RETURNS [Fixnum] ~ {
        IF int IN SmallValue
            THEN RETURN [smallFixnumTable[int]]
            ELSE RETURN [NEW[INT Ź int]]
        };

    Negative: PUBLIC PROC [a: Any] RETURNS [BOOL] ~ {
        WITH a SELECT FROM
            a: Fixnum => RETURN [a­<0];
            a: Flonum => RETURN [a.real<0.0];
            a: Bignum => RETURN [a.neg];
            a: Ratnum => RETURN [Negative[a.numerator]];
            ENDCASE => Complain[a, "not a real number"];
        };

    TheReal: PROC [a: Any] RETURNS [Any] ~ {
        WITH a SELECT FROM
            a: Fixnum => RETURN [a];
            a: Flonum => RETURN [a];
            a: Bignum => RETURN [a];
            a: Ratnum => RETURN [a];
            ENDCASE => Complain[a, "not a real number"];
        };

    ComplexPrim: PrimitiveProc ~ {
        SELECT self.data FROM
            $rectangular => 
                RETURN [MakeRectangular[a, b]];
            $polar =>
                RETURN [MakePolar[a, b]];
            $realPart => {
                WITH a SELECT FROM
                    c: Complex => {RETURN [c.x]};
                    ENDCASE => {RETURN [TheReal[a]]};
                };
            $imagPart => {
                WITH a SELECT FROM
                    c: Complex => {RETURN [c.y]};
                    ENDCASE => {RETURN [Zero[Exact[a]]]};
                };
            ENDCASE => ERROR;
        };

    MakeNumber: PROC [any: Any] RETURNS [Number] ~ {
        WITH any SELECT FROM
            a: Fixnum => {
                card: CARD ~ ABS[a­]; -- will ABS overflow for INT.FIRST? not for PrincOps.
                bigCARD: BigCardinals.BigCARD ~ BigCardinals.BigFromCard[card];
                RETURN [NEW[NumberRep.bignum Ź [TRUE, bignum[a­<0, bigCARD]]]]
                };
            num: Number => RETURN [num];
            ENDCASE => Complain[any, "not a number"];
        };

    inexactZero: Flonum ~ NEW[NumberRep.flonum Ź [FALSE, flonum[0.0]]];
    exactZero: Fixnum ~ MakeFixnum[0];

    Zero: PROC [exact: BOOL] RETURNS [Any] ~ {
        RETURN [IF exact THEN exactZero ELSE inexactZero]
        };

    MakeRectangular: PUBLIC PROC [realPart, imagPart: Any] RETURNS [Any] ~ {
        exact: BOOL ~ Exact[TheReal[realPart]] AND Exact[TheReal[imagPart]];
        IF NumericallyEqual[imagPart, exactZero] THEN RETURN [ConvertExactness[realPart, exact]];
        RETURN [NEW[NumberRep.complex Ź
            [exact, complex[ConvertExactness[realPart, exact], ConvertExactness[imagPart, exact]]]
            ]]
        };

    MakePolar: PUBLIC PROC [magnitude, angle: Any] RETURNS [Any] ~ {
        exact: BOOL ~ Exact[TheReal[magnitude]] AND Exact[TheReal[angle]];
        IF NumericallyEqual[angle, exactZero]
            THEN RETURN [ConvertExactness[magnitude, exact]]
            ELSE {
                f: REAL ~ TheREAL[angle];
                cos: REAL ~ RealFns.Cos[f];
                sin: REAL ~ RealFns.Sin[f];
                cis: Complex ~
                    NEW[NumberRep.complex Ź[FALSE, complex[
                        NEW[NumberRep.flonum Ź [FALSE, flonum[cos]]],
                        NEW[NumberRep.flonum Ź [FALSE, flonum[sin]]]]]];
                RETURN [Arith[mult, magnitude, cis]]
                };
        };

    TheINT: PUBLIC PROC [any: Any] RETURNS [INT] ~ {
        WITH TheInteger[any] SELECT FROM
            k: Fixnum => { RETURN [k­] };
            num: Bignum => {
                c: CARD Ź CARD.LAST;
                c Ź BigCardinals.BigToCard[num.magnitude ! BigCardinals.BigFail => CONTINUE];
                IF num.neg 
                    THEN { IF c <= CARD[INT.LAST]+1 THEN RETURN [-c] }
                    ELSE { IF c <= CARD[INT.LAST] THEN RETURN [c] };
                };
            ENDCASE => ERROR;
        Complain[any, "integer out of bounds"];
        };

    TheCARD: PUBLIC PROC [any: Any] RETURNS [CARD] ~ {
        WITH TheInteger[any] SELECT FROM
            k: Fixnum => { IF 0 <= k­ THEN RETURN [k­] };
            num: Bignum => {
                c: CARD Ź CARD.LAST;
                ok: BOOL Ź TRUE;
                c Ź BigCardinals.BigToCard[num.magnitude ! BigCardinals.BigFail => {okŹFALSE; CONTINUE}];
                IF ok AND NOT num.neg THEN { RETURN [c] };
                };
            ENDCASE => ERROR;
        Complain[any, "integer out of bounds"];
        };

    KCheck: PUBLIC PROC [any: Any, max: INT Ź INT.LAST] RETURNS [INT] ~ {
        <<any must represent an exact non-negative integer not exceeding max, or we Complain>>
        WITH TheInteger[any] SELECT FROM
            k: Fixnum => { IF 0 <= k­ AND k­ <= max THEN RETURN [k­] };
            num: Bignum => {
                c: CARD Ź CARD.LAST;
                IF NOT num.exact THEN Complain[any, "not an exact integer"];
                c Ź BigCardinals.BigToCard[num.magnitude ! BigCardinals.BigFail => CONTINUE];
                IF c <= CARD[max] AND NOT num.neg THEN RETURN [c];
                };
            ENDCASE => ERROR;
        Complain[any, "integer out of bounds"];
        };

    TheComplex: PUBLIC PROC [a: Any] RETURNS [Complex] ~ {
        WITH a SELECT FROM
            a: Complex => RETURN [a];
            n: Fixnum => NULL;
            n: Number => NULL;
            ENDCASE => Complain[a, "not a number"];
        RETURN [NEW[NumberRep.complex Ź [Exact[a], complex[x: a, y: MakeFixnum[0]]]]]
        };

    Frac: PROC [num: BigCardinals.BigCARD] RETURNS [REAL] ~ {
        v: REAL Ź 0.0;
        IF num # BigCardinals.Zero THEN {
            sig: INT Ź -INT[num.size]*BITS[CARD16];
            FOR i: NAT IN [0..num.size) DO
                v Ź v + Real.FScale[num.contents[i], sig];
                sig Ź sig + BITS[CARD16];
                ENDLOOP;
            };
        RETURN [v]
        };

    Exponent: PROC [num: BigCardinals.BigCARD] RETURNS [INT] ~ {
        RETURN [IF num = BigCardinals.Zero THEN 0 ELSE INT[num.size]*BITS[CARD16]]
        };

    TheREAL: PUBLIC PROC [a: Any] RETURNS [REAL] ~ {
        WITH a SELECT FROM
            a: Fixnum => RETURN [REAL[a­]];
            a: Flonum => RETURN [a.real];
            a: Bignum => {
                mag: REAL ~ Real.FScale[Frac[a.magnitude], Exponent[a.magnitude]];
                v: REAL ~ IF a.neg THEN -mag ELSE mag;
                RETURN [v]
                };
            a: Ratnum => {
                n: Bignum ~ NARROW[a.numerator];
                d: Bignum ~ NARROW[a.denominator];
                mag: REAL ~ Real.FScale[Frac[n.magnitude]/Frac[d.magnitude], Exponent[n.magnitude]-Exponent[d.magnitude]];
                v: REAL ~ IF n.neg THEN -mag ELSE mag;
                RETURN [v]
                };
            ENDCASE => Complain[a, "domain error"];
        };

    TheFlonum: PUBLIC PROC [a: Any] RETURNS [Flonum] ~ {
        WITH a SELECT FROM
            a: Flonum => RETURN [a];
            ENDCASE => RETURN [NEW[NumberRep.flonum Ź [FALSE, flonum[TheREAL[a]]]]];
        };

    Exact: PUBLIC PROC [a: Any] RETURNS [BOOL] ~ {
        WITH a SELECT FROM
            a: Fixnum => RETURN [TRUE];
            a: Number => RETURN [a.exact];
            ENDCASE => Complain[a, "not a number"];
        };

    Odd: PROC [a: Any] RETURNS [BOOL] ~ {
        WITH TheInteger[a] SELECT FROM
            a: Fixnum => RETURN [OddINT[a­]];
            b: Bignum => RETURN [BigCardinals.BigOdd[b.magnitude]];
            ENDCASE => ERROR;
        };

    OddINT: PROC [int: INT] RETURNS [BOOL] ~ {
        lc: Basics.LongNumber ~ [li[int]];
        RETURN [VAL[lc.lo MOD 2]]
        };

    largestFlonumFraction: REAL Ź LargestFlonumFraction[];
    LargestFlonumFraction: PROC RETURNS [REAL] ~ INLINE {
        a: REAL Ź 0.5;
        FOR i: NAT IN [0..1000) DO
            b: REAL ~ a+a+0.5;
            IF b = REAL[Real.Fix[b]] THEN RETURN [a];
            a Ź b;
            ENDLOOP;
        ERROR; -- this doesn't act like floating point!
        };

    IsNaN: PROC [real: REAL] RETURNS [BOOL] ~ INLINE {
        SingleReal: TYPE = MACHINE DEPENDENT RECORD [
            sign: BOOL, exp: CARDINAL [0..377B], m: CARDINAL [0..37777777B] ];
        rep: SingleReal ~ LOOPHOLE[real];
        RETURN [rep.exp = 255]
        };

    TheInteger: PUBLIC PROC [a: Any] RETURNS [Any] ~ {
        <<Result will be either a Fixnum or a Bignum, or else we Complain>>
        WITH a SELECT FROM
            a: Fixnum => RETURN [a];
            a: Bignum => RETURN [a];
            f: Flonum => {
                bignum: Bignum Ź NIL;
                IF ABS[f.real] > largestFlonumFraction
                    THEN {
                        s: REAL Ź f.real;
                        e: NAT Ź 0;
                        UNTIL ABS[s] < LAST[INT] DO
                            s Ź s*0.5;
                            e Ź e + 1;
                            ENDLOOP;
                        bignum Ź NARROW[MakeNumber[MakeFixnum[Real.Fix[s]]]];
                        IF FALSE -- TRUE if BigCardinals.TimesTwoToTheNth is buggy
                            THEN {
                                FOR i: NAT IN [0..e) DO
                                    bignum.magnitude Ź BigCardinals.BigAdd[bignum.magnitude, bignum.magnitude];
                                    ENDLOOP;
                                }
                            ELSE bignum.magnitude Ź BigCardinals.TimesTwoToTheNth[bignum.magnitude, e];
                        bignum.exact Ź f.exact;
                        RETURN [bignum]
                        }
                    ELSE IF f.real = REAL[Real.Fix[f.real]] THEN {
                        bignum Ź NARROW[MakeNumber[MakeFixnum[Real.Fix[f.real]]]];
                        };
                IF bignum # NIL THEN { bignum.exact Ź f.exact; RETURN [bignum] };
                };
            ENDCASE => NULL;
        Complain[a, "not an integer"];
        };

    IsInteger: PUBLIC PROC [a: Any] RETURNS [BOOL] ~ {
        WITH a SELECT FROM
            a: Fixnum => RETURN [TRUE];
            a: Number => {
                WITH a SELECT FROM
                    bignum: Bignum => RETURN [TRUE];
                    flonum: Flonum => {
                        IF ABS[flonum.real] > largestFlonumFraction THEN RETURN [TRUE];
                        IF flonum.real = REAL[Real.Fix[flonum.real]] THEN RETURN [TRUE];
                        };
                    ENDCASE => NULL;
                };
            ENDCASE => NULL;
        RETURN [FALSE]
        };

    NumTypePredPrim: PrimitiveProc ~ {
        t: Any ~ self.data;
        WITH a SELECT FROM
            a: Fixnum => RETURN [SELECT t FROM $number, $complex, $real, $rational, $integer, $exact => true, $inexact => false, $odd => (IF 
            OddINT[a­] THEN true ELSE false),  $even => (IF OddINT[a­] THEN false ELSE true) ENDCASE => ERROR];
            a: Number => {
                SELECT t FROM
                    $exact => RETURN [IF a.exact THEN true ELSE false];
                    $inexact => RETURN [IF a.exact THEN false ELSE true];
                    $number => RETURN [true];
                    $complex => IF a.tag <= complex THEN RETURN [true];
                    $real => IF a.tag <= ratnum THEN RETURN [true];
                    $rational => IF a.tag = ratnum OR IsInteger[a] THEN RETURN [true];
                    $integer => IF IsInteger[a] THEN RETURN [true];
                    $odd, $even => {
                        is: Symbol Ź IF Odd[a] THEN $odd ELSE $even;
                        RETURN [IF is=t THEN true ELSE false]
                        };
                    ENDCASE => ERROR;
                };
            ENDCASE => { SELECT t FROM $exact, $inexact, $odd, $even => Complain[a, "domain error"] ENDCASE};
        RETURN [false]
        };

    Raise: PROC [a: Number, b: Number] RETURNS [Number] ~ {
        WITH a SELECT FROM
            flonum: Flonum => {
                IF IsInteger[flonum]
                    THEN RETURN [MakeNumber[TheInteger[flonum]]]
                    ELSE {
                        f: REAL Ź flonum.real*2.0;
                        t: REAL Ź 2.0;
                        bigt: BigCardinals.BigCARD Ź bignumTwo.magnitude;
                        UNTIL ABS[f] > largestFlonumFraction OR t > 1.0e+15 DO
                            f Ź f * t;
                            t Ź t * t;
                            bigt Ź BigCardinals.BigMultiply[bigt, bigt];
                            ENDLOOP;
                        UNTIL ABS[f] > largestFlonumFraction DO
                            <<t was in danger of overflow, so proceed cautiously>>
                            f Ź f * 2.0;
                            bigt Ź BigCardinals.BigAdd[bigt, bigt];
                            ENDLOOP;
                        RETURN [NARROW[MakeRatnum[num: NARROW[MakeNumber[TheInteger[NEW[NumberRep.flonum Ź [TRUE, flonum[f]]]]]], denom: 
                        NARROW[MakeBignum[neg: FALSE, mag: bigt, exact: TRUE, reduce: FALSE]], exact: flonum.exact]]]
                        };
                };
            bignum: Bignum => {
                RETURN [NEW[NumberRep.ratnum Ź [a.exact, ratnum[bignum, bignumOne]]]]
                };
            ENDCASE => NULL;
        IF b.tag = complex AND a.tag < complex THEN {
            RETURN [NEW[NumberRep.complex Ź [a.exact, complex[a, MakeFixnum[0]]]]]
            };
        Complain[a, "unimplemented coercion"]
        };
        <<The second arg is a target; Raise just need to make progress towards the target>>

    refForComparison: REF ARRAY Basics.Comparison OF REF Basics.Comparison Ź NEW[ARRAY Basics.Comparison OF REF Basics.Comparison Ź 
    [less: NEW[Basics.Comparison Ź less], equal: NEW[Basics.Comparison Ź equal], greater: NEW[Basics.Comparison Ź greater]]];

    FlonumArith: PROC [op: ArithOp, a: REAL, b: REAL] RETURNS [Any] ~ {
        CompareREAL: PROC [a, b: REAL] RETURNS [c: Basics.Comparison] ~ INLINE { 
            c Ź SELECT TRUE FROM
                a=b => equal,
                a>b => greater,
                ENDCASE => less;
            };
        realResult: REAL Ź 0.0;
        SELECT op FROM
            plus => realResult Ź (a+b);
            minus => realResult Ź (a-b);
            mult => realResult Ź (a*b);
            divide => realResult Ź (a/b);
            equality => RETURN [IF a = b THEN true ELSE false];
            compare => RETURN [refForComparison[CompareREAL[a, b]]];
            ENDCASE => ERROR;
        IF IsNaN[realResult] THEN RETURN [NIL];
        RETURN [NEW[NumberRep.flonum Ź [FALSE, flonum[realResult]]]]
        };

    bigINT: BigCardinals.BigCARD ~ BigCardinals.BigFromCard[LAST[INT]];
    MakeBignum: PROC [neg: BOOL, mag: BigCardinals.BigCARD, exact: BOOL, reduce: BOOL Ź TRUE] RETURNS [Any] ~ {
        IF reduce AND exact AND BigCardinals.BigCompare[mag, bigINT] # greater THEN {
            i: INT Ź BigCardinals.BigToCard[mag];
            IF neg THEN i Ź -i;
            RETURN [MakeFixnum[i]]
            };
        RETURN [NEW[NumberRep.bignum Ź [exact, bignum[neg, mag]]]]
        };

    BignumArith: PROC [op: ArithOp, a: Bignum, b: Bignum, reduce: BOOL Ź TRUE] RETURNS [Any] ~ {
        aMag: BigCardinals.BigCARD Ź a.magnitude;
        aNeg: BOOL Ź a.neg;
        bMag: BigCardinals.BigCARD Ź b.magnitude;
        bNeg: BOOL Ź b.neg;
        DO
            SELECT op FROM
                plus => {
                    IF aNeg # bNeg THEN { bNeg Ź NOT bNeg; op Ź minus; LOOP };
                    aMag Ź BigCardinals.BigAdd[aMag, bMag];
                    };
                minus => {
                    IF aNeg # bNeg THEN { bNeg Ź NOT bNeg; op Ź plus; LOOP };
                    SELECT BigCardinals.BigCompare[aMag, bMag] FROM
                        greater => { aMag Ź BigCardinals.BigSubtract[large: aMag, small: bMag] };
                        equal => { aMag Ź BigCardinals.Zero; aNeg Ź FALSE };
                        less => { aMag Ź BigCardinals.BigSubtract[large: bMag, small: aMag]; aNeg Ź NOT aNeg };
                        ENDCASE => ERROR;
                    };
                mult => {
                    aMag Ź BigCardinals.BigMultiply[aMag, bMag];
                    aNeg Ź aNeg # bNeg AND aMag#BigCardinals.Zero;
                    };
                divide => { RETURN [MakeRatnum[a, b, a.exact AND b.exact]] };
                equality, compare => {
                    sigA: INT ~ IF aMag=BigCardinals.Zero THEN 0 ELSE IF aNeg THEN -1 ELSE +1;
                    sigB: INT ~ IF bMag=BigCardinals.Zero THEN 0 ELSE IF bNeg THEN -1 ELSE +1;
                    c: Basics.Comparison Ź Basics.CompareInt[sigA, sigB];
                    IF c = equal THEN {
                        c Ź IF aNeg THEN BigCardinals.BigCompare[bMag, aMag] ELSE BigCardinals.BigCompare[aMag, bMag];
                        };
                    IF op = equality THEN RETURN [IF c = equal THEN true ELSE false];
                    RETURN [refForComparison[c]];
                    };
                quotient => {
                    aMag Ź BigCardinals.BigDivMod[aMag, bMag ! BigCardinals.BigFail => IF subclass = $DivideByZero THEN Complain[a, "divided by 
                    zero"]].quo;
                    aNeg Ź aNeg # bNeg AND aMag#BigCardinals.Zero;
                    };
                remainder => {
                    aMag Ź BigCardinals.BigDivMod[aMag, bMag ! BigCardinals.BigFail => IF subclass = $DivideByZero THEN Complain[a, "divided by 
                    zero"]].rem;
                    };
                ENDCASE => ERROR;
            EXIT;
            ENDLOOP;
        RETURN [MakeBignum[neg: aNeg, mag: aMag, exact: a.exact AND b.exact, reduce: reduce]]
        };

    bignumOne: Bignum ~ NEW[NumberRep.bignum Ź [TRUE, bignum[FALSE, BigCardinals.BigFromCard[1]]]];
    bignumTwo: Bignum ~ NEW[NumberRep.bignum Ź [TRUE, bignum[FALSE, BigCardinals.BigFromCard[2]]]];
    half: Ratnum ~ NARROW[MakeRatnum[bignumOne, bignumTwo, TRUE]];
    MakeRatnum: PROC [num, denom: Bignum, exact: BOOL] RETURNS [Any] ~ {
        gcd: BigCardinals.BigCARD ~ BigCardinals.BigGCD[num.magnitude, denom.magnitude];
        IF num.exact AND denom.exact AND NOT denom.neg AND
        BigCardinals.BigCompare[gcd, bignumOne.magnitude] = equal AND
        BigCardinals.BigCompare[denom.magnitude, bignumOne.magnitude] # equal
            THEN NULL
            ELSE {
                numMag: BigCardinals.BigCARD ~ BigCardinals.BigDivMod[num.magnitude, gcd].quo;
                denomMag: BigCardinals.BigCARD ~ BigCardinals.BigDivMod[denom.magnitude, gcd].quo;
                numNeg: BOOL ~ num.neg # denom.neg AND numMag # BigCardinals.Zero;
                IF BigCardinals.BigCompare[denomMag, bignumOne.magnitude] = equal THEN RETURN [MakeBignum[numNeg, numMag, exact]];
                num Ź NEW[NumberRep.bignum Ź [TRUE, bignum[numNeg, numMag]]];
                denom Ź NEW[NumberRep.bignum Ź [TRUE, bignum[FALSE, denomMag]]];
                };
        RETURN [NEW[NumberRep.ratnum Ź [exact, ratnum[num, denom]]]]
        };

    RationalArith: PROC [op: ArithOp, a: Ratnum, b: Ratnum] RETURNS [Any] ~ {
        aNum: Bignum ~ NARROW[a.numerator];
        aDenom: Bignum ~ NARROW[a.denominator];
        bNum: Bignum ~ NARROW[b.numerator];
        bDenom: Bignum ~ NARROW[b.denominator];
        num: Bignum Ź NIL;
        denom: Bignum Ź NIL;
        SELECT op FROM
            plus => {
                aNbD: Bignum ~ NARROW[BignumArith[mult, aNum, bDenom, FALSE]];
                aDbN: Bignum ~ NARROW[BignumArith[mult, aDenom, bNum, FALSE]];
                num Ź NARROW[BignumArith[plus, aNbD, aDbN, FALSE]];
                denom Ź NARROW[BignumArith[mult, aDenom, bDenom, FALSE]];
                };
            minus => {
                aNbD: Bignum ~ NARROW[BignumArith[mult, aNum, bDenom, FALSE]];
                aDbN: Bignum ~ NARROW[BignumArith[mult, aDenom, bNum, FALSE]];
                num Ź NARROW[BignumArith[minus, aNbD, aDbN, FALSE]];
                denom Ź NARROW[BignumArith[mult, aDenom, bDenom, FALSE]];
                };
            mult => {
                num Ź NARROW[BignumArith[mult, aNum, bNum, FALSE]];
                denom Ź NARROW[BignumArith[mult, aDenom, bDenom, FALSE]];
                };
            divide => {
                num Ź NARROW[BignumArith[mult, aNum, bDenom, FALSE]];
                denom Ź NARROW[BignumArith[mult, aDenom, bNum, FALSE]];
                };
            equality => {
                RETURN [IF BignumArith[equality, aNum, bNum] = true AND BignumArith[equality, aDenom, bDenom] = true THEN true ELSE false]
                };
            compare => {
                sigA: INT ~ IF aNum.magnitude=BigCardinals.Zero THEN 0 ELSE IF aNum.neg THEN -1 ELSE +1;
                sigB: INT ~ IF bNum.magnitude=BigCardinals.Zero THEN 0 ELSE IF bNum.neg THEN -1 ELSE +1;
                c: Basics.Comparison Ź Basics.CompareInt[sigA, sigB];
                IF c = equal THEN {
                    left: Bignum Ź NARROW[BignumArith[mult, aNum, bDenom, FALSE]];
                    right: Bignum Ź NARROW[BignumArith[mult, bNum, aDenom, FALSE]];
                    RETURN [BignumArith[compare, left, right]]
                    };
                RETURN [refForComparison[c]];
                };
            ENDCASE => ERROR;
        RETURN [MakeRatnum[num, denom, a.exact AND b.exact]]
        };

    ComplexArith: PROC [op: ArithOp, a: Complex, b: Complex] RETURNS [Any] ~ {
        realPart: Any Ź NIL;
        imagPart: Any Ź NIL;
        exact: BOOL ~ a.exact AND b.exact;
        SELECT op FROM
            plus, minus => {realPart Ź Arith[op, a.x, b.x]; imagPart Ź Arith[op, a.y, b.y]};
            mult => {
                realPart Ź Arith[minus, Arith[mult, a.x, b.x], Arith[mult, a.y, b.y]];
                imagPart Ź Arith[plus, Arith[mult, a.x, b.y], Arith[mult, a.y, b.x]];
                };
            divide => {
                d: Any ~ Arith[plus, Arith[mult, b.x, b.x], Arith[mult, b.y, b.y]];
                xd: Any ~ Arith[plus, Arith[mult, a.x, b.x], Arith[mult, a.y, b.y]];
                yd: Any ~ Arith[minus, Arith[mult, a.y, b.x], Arith[mult, a.x, b.y]];
                realPart Ź Arith[divide, xd, d];
                imagPart Ź Arith[divide, yd, d];
                };
            equality => {
                RETURN [IF Arith[equality, a.x, b.x] = true AND Arith[equality, a.y, b.y] = true THEN true ELSE false];
                };
            compare => Complain[Cons[a, Cons[b, NIL]], "comparison not allowed for non-reals"];
            ENDCASE => ERROR;
        IF Arith[equality, imagPart, MakeFixnum[0]] = true AND exact = Exact[realPart] THEN RETURN [ConvertExactness[realPart, exact]];
        RETURN [NEW[NumberRep.complex Ź [exact, complex[ConvertExactness[realPart, exact], ConvertExactness[imagPart, exact]]]]]
        };


    Arith: PUBLIC PROC [op: ArithOp, a: Any, b: Any] RETURNS [Any] ~ {
        integerOp: BOOL ~ SELECT op FROM quotient, remainder => TRUE ENDCASE => FALSE;
        WITH a SELECT FROM
            aa: Fixnum => {
                WITH b SELECT FROM
                    bb: Fixnum => {
                        a: INT ~ aa­;
                        b: INT ~ bb­;
                        SELECT op FROM
                            plus => {
                                IF a >= 0
                                    THEN {IF b <= 0 OR a <= INT.LAST-b THEN RETURN [MakeFixnum[a+b]]}
                                    ELSE {IF b >= 0 OR a >= INT.FIRST-b THEN RETURN [MakeFixnum[a+b]]};
                                };
                            minus => {
                                IF a >= 0
                                    THEN {IF b >= 0 OR a <= INT.LAST+b THEN RETURN [MakeFixnum[a-b]]}
                                    ELSE {IF b <= 0 OR a >= INT.FIRST+b THEN RETURN [MakeFixnum[a-b]]};
                                };
                            mult => { IF MAX[ABS[a],ABS[b]] <= 32767 THEN RETURN [MakeFixnum[a*b]] };
                            divide => {
                                IF b = 0 THEN Complain[aa, "divided by zero"];
                                IF a MOD b = 0 THEN RETURN [MakeFixnum[a/b]];
                                };
                            quotient => {
                                IF a >= 0 AND b > 0 THEN RETURN [MakeFixnum[a/b]];
                                };
                            remainder => {
                                IF a >= 0 AND b > 0 THEN RETURN [MakeFixnum[a MOD b]];
                                };
                            equality => { RETURN [IF a=b THEN true ELSE false] };
                            compare => { RETURN [refForComparison[Basics.CompareInt[a, b]]] };
                            ENDCASE => ERROR;
                        };
                    ENDCASE => NULL;
                };
            ENDCASE => NULL;
        -- handle complex and flonum arithmetic -- {
            aComplex, aExact, bComplex, bExact: BOOL Ź FALSE;
            WITH a SELECT FROM
                n: Fixnum => { aExact Ź TRUE };
                n: Number => { aExact Ź n.exact; aComplex Ź (n.tag = complex) };
                ENDCASE => NULL;
            WITH b SELECT FROM
                n: Fixnum => { bExact Ź TRUE };
                n: Number => { bExact Ź n.exact; bComplex Ź (n.tag = complex) };
                ENDCASE => NULL;
            IF NOT (integerOp OR (aExact AND bExact)) THEN {
                IF aComplex OR bComplex
                    THEN {RETURN [ComplexArith[op, TheComplex[a], TheComplex[b]]]}
                    ELSE {
                        result: Any ~ FlonumArith[op, TheREAL[a], TheREAL[b]];
                        IF result # NIL THEN RETURN[result];
                        };
                };
            };
        -- coerce to compatible types before operating -- {
            x: Number Ź MakeNumber[IF integerOp THEN TheInteger[a] ELSE a];
            y: Number Ź MakeNumber[IF integerOp THEN TheInteger[b] ELSE b];
            IF x.tag < bignum THEN x Ź Raise[x, bignumOne]; -- don't do floating-point arithmetic if the arguments are exact or if there was a 
            floating-point exception
            UNTIL x.tag = y.tag DO
                WHILE x.tag < y.tag DO x Ź Raise[x, y] ENDLOOP;
                WHILE x.tag > y.tag DO y Ź Raise[y, x] ENDLOOP;
                ENDLOOP;
            SELECT x.tag FROM
                bignum => RETURN [BignumArith[op, NARROW[x], NARROW[y]]];
                ratnum => RETURN [RationalArith[op, NARROW[x], NARROW[y]]];
                complex => RETURN [ComplexArith[op, NARROW[x], NARROW[y]]];
                general => ERROR; -- not yet implemented
                ENDCASE => ERROR;
            };
        };

    ArithPrim: PrimitiveProc ~ {
        op: ArithOp ~ NARROW[self.data, REF ArithOp]­;
        IF op IN [plus..divide] THEN {
            <<Process non-standard number of arguments>>
            IF b = undefined 
                THEN {
                    identity: Any ~ MakeFixnum[IF op IN [plus..minus] THEN 0 ELSE 1];
                    b Ź IF a = undefined THEN identity ELSE a;
                    a Ź identity;
                    }
                ELSE {
                    com: ArithOp Ź SELECT op FROM minus => plus, divide => mult ENDCASE => op;
                    WHILE rest # NIL DO
                        b Ź Arith[com, b, rest.car];
                        rest Ź NARROW[rest.cdr]
                        ENDLOOP;
                    }
            };
        result Ź Arith[op, a, b];
        };

    MakeReal: PUBLIC PROC [negative: BOOL, numerator, denominator: BigCardinals.BigCARD, exponent: INT, radix: INT, exact: BOOL] 
    RETURNS [Any] ~ {
        <<Compute and return the appropriate real number that is (perhaps approximately) equal to>>
            <<(IF negative THEN -1 ELSE 1) * (numerator / denominator) * (radix ^ exponent)>>
        num: Any Ź MakeBignum[negative, numerator, exact];
        denom: Any Ź MakeBignum[FALSE, denominator, exact];
        core: Any Ź Arith[divide, num, denom];

        IF exponent = 0 THEN 
            RETURN [core]
        ELSE {
            zero: Fixnum Ź MakeFixnum[0];
            one: Fixnum Ź MakeFixnum[1];
            two: Fixnum Ź MakeFixnum[2];
            Expt: PROC [base, exponent: Any] RETURNS [Any] ~ {
                IF NumericallyEqual[exponent, zero] THEN 
                    RETURN [one]
                ELSE IF Odd[exponent] THEN 
                    RETURN [Arith[mult, base, Expt[base, Arith[minus, exponent, one]]]]
                ELSE {
                    part: Any Ź Expt[base, Arith[quotient, exponent, two]];
                    RETURN [Arith[mult, part, part]]
                    };
                };
            expPart: Any Ź Expt[MakeFixnum[radix], MakeFixnum[ABS[exponent]]];

            RETURN [Arith[IF exponent < 0 THEN divide ELSE mult, core, expPart]]
            };
        };

    ConvertExactness: PUBLIC PROC [a: Any, exact: BOOL] RETURNS [Any] ~ {
        IF Exact[a] = exact
            THEN RETURN [a]
            ELSE {
                WITH a SELECT FROM
                    a: Fixnum => RETURN [MakeBignum[neg: a­ < 0, mag: BigCardinals.BigFromCard[ABS[a­]], exact: exact]];
                    b: Bignum => RETURN [MakeBignum[neg: b.neg, mag: b.magnitude, exact: exact]];
                    f: Flonum => {
                        IF exact AND IsInteger[f]
                            THEN RETURN [ConvertExactness[TheInteger[f], exact]]
                            ELSE RETURN [NEW[NumberRep.flonum Ź [exact, flonum[f.real]]]];
                        };
                    q: Ratnum => RETURN [NEW[NumberRep.ratnum Ź [exact, ratnum[q.numerator, q.denominator]]]];
                    z: Complex => RETURN [NEW[NumberRep.complex Ź [exact, complex[ConvertExactness[z.x, exact], ConvertExactness[z.y, exact]]]]];
                    ENDCASE => ERROR;
                };
        };

    NumericallyEqual: PROC [a, b: Any] RETURNS [BOOL] ~ INLINE {
        RETURN [Arith[equality, a, b]#false];
        };

    RealFnsPrim: PrimitiveProc ~ {
        <<ENABLE Real.RealException => {>>
            <<msg: ROPE ~ Rope.Cat["arithmetic exception:",>>
                <<IF flags[invalidOperation] THEN " invalid-operation" ELSE NIL,>>
                <<IF flags[divisionByZero] THEN " division-by-zero" ELSE NIL,>>
                <<IF flags[fixOverflow] OR flags[overflow] THEN " overflow" ELSE NIL,>>
                <<IF flags[underflow] THEN " underflow" ELSE NIL>>
                <<];>>
            <<Complain[Cons[a, IF b = undefined THEN NIL ELSE Cons[b, NIL]], msg]>>
            <<};>>
        f: REAL ~ TheREAL[a];
        imag: BOOL Ź FALSE;
        realResult: REAL Ź 0.0;
        flo: Flonum Ź NIL;
        IF IsNaN[f] THEN realResult Ź f ELSE SELECT self.data FROM
            $sqrt => {realResult Ź RealFns.SqRt[ABS[f]]; imag Ź (f < 0)};
            $exp => {realResult Ź RealFns.Exp[f]};
            $expt => {
                e: REAL ~ TheREAL[b];
                realResult Ź IF IsNaN[e] THEN e ELSE RealFns.Power[f, e];
                };
            $log => {realResult Ź RealFns.Ln[f]};
            $sin => {realResult Ź RealFns.Sin[f]};
            $cos => {realResult Ź RealFns.Cos[f]};
            $tan => {realResult Ź RealFns.Tan[f]};
            $atan => {
                IF b = undefined
                    THEN realResult Ź RealFns.ArcTan[f, 1.0]
                    ELSE {
                        e: REAL ~ TheREAL[b];
                        realResult Ź IF IsNaN[e] THEN e ELSE RealFns.ArcTan[f, e];
                        };
                };
            ENDCASE => ERROR;
        IF IsNaN[realResult] THEN Complain[Cons[a, IF b = undefined THEN NIL ELSE Cons[b, NIL]], " floating-point exception"];
        flo Ź NEW[NumberRep.flonum Ź [FALSE, flonum[realResult]]];
        IF imag THEN RETURN [NEW[NumberRep.complex Ź [FALSE, complex[MakeFixnum[0], flo]]]] ELSE RETURN [flo]
        };

    NumFnsPrim: PrimitiveProc ~ {
        SELECT self.data FROM
            $numerator => {
                IF IsInteger[a] THEN RETURN [a];
                WITH a SELECT FROM
                    r: Ratnum => RETURN [r.numerator]
                    ENDCASE => Complain[a, "is not rational"];
                };
            $denominator => {
                IF IsInteger[a] THEN RETURN [MakeFixnum[1]];
                WITH a SELECT FROM
                    r: Ratnum => RETURN [r.denominator]
                    ENDCASE => Complain[a, "is not rational"];
                };
            $gcd => {
                gcd: BigCardinals.BigCARD Ź BigCardinals.Zero;
                exact: BOOL Ź TRUE;
                FOR each: Any Ź rest, Cdr[each] UNTIL each = NIL DO
                    WITH TheInteger[Car[each]] SELECT FROM
                        n: Fixnum => gcd Ź BigCardinals.BigGCD[BigCardinals.BigFromCard[n­], gcd];
                        n: Bignum => {
                            exact Ź exact AND n.exact;
                            gcd Ź BigCardinals.BigGCD[n.magnitude, gcd];
                            };
                        ENDCASE => ERROR;
                    ENDLOOP;
                RETURN [MakeBignum[neg: FALSE, mag: gcd, exact: exact, reduce: TRUE]];
                };
            $truncate => {
                result: Any Ź NIL;
                IF IsInteger[a] THEN RETURN [TheInteger[a]];
                WITH a SELECT FROM
                    q: Ratnum => {
                        result Ź Arith[quotient, q.numerator, q.denominator]
                        };
                    f: Flonum => {
                        result Ź MakeFixnum[Real.Fix[f.real]]
                        };
                    ENDCASE => Complain[a, "is not real"];
                RETURN [ConvertExactness[result, Exact[a]]]
                };
            $round => {
                result: Any Ź NIL;
                IF IsInteger[a] THEN RETURN [TheInteger[a]];
                WITH a SELECT FROM
                    q: Ratnum => {
                        neg: BOOL ~ Negative[q];
                        qh: Any ~ Arith[IF neg THEN minus ELSE plus, q, half];
                        IF IsInteger[qh]
                            THEN {
                                result Ź (IF Odd[qh]
                                    THEN Arith[IF neg THEN plus ELSE minus, qh, MakeFixnum[1]]
                                    ELSE qh);
                                }
                            ELSE {
                                WITH qh SELECT FROM
                                    qh: Ratnum => { result Ź Arith[quotient, qh.numerator, qh.denominator] };
                                    ENDCASE => ERROR;
                                };
                        };
                    f: Flonum => { result Ź MakeFixnum[Real.Round[f.real]] };
                    ENDCASE => Complain[a, "is not real"];
                RETURN [ConvertExactness[result, Exact[a]]]
                };
            $exact => { RETURN [ConvertExactness[a, TRUE]] };
            $inexact => { RETURN [ConvertExactness[a, FALSE]] };
            ENDCASE => Complain[a, "function is not implemented"];
        };

<<Registration of Primitives>>
    RegisterEssentials: PROC [env: Environment] ~ {
        DefinePrimitive[name: "+", nArgs: 2, dotted: FALSE, proc: ArithPrim, env: env,
        doc: "Binary arithmetic addition", data: NEW[ArithOp Ź plus]];
        DefinePrimitive[name: "-", nArgs: 2, dotted: FALSE, proc: ArithPrim, env: env,
        doc: "Binary arithmetic subtraction", data: NEW[ArithOp Ź minus]];
        DefinePrimitive[name: "*", nArgs: 2, dotted: FALSE, proc: ArithPrim, env: env,
        doc: "Binary arithmetic multiplication", data: NEW[ArithOp Ź mult]];
        DefinePrimitive[name: "/", nArgs: 2, dotted: FALSE, proc: ArithPrim, env: env,
        doc: "Binary arithmetic division", data: NEW[ArithOp Ź divide]];
        DefinePrimitive[name: "quotient", nArgs: 2, dotted: FALSE, proc: ArithPrim, env: env,
        doc: "integer quotient", data: NEW[ArithOp Ź quotient]];
        DefinePrimitive[name: "remainder", nArgs: 2, dotted: FALSE, proc: ArithPrim, env: env,
        doc: "integer remainder with sign of dividend", data: NEW[ArithOp Ź remainder]];
        DefinePrimitive[name: "complex?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $complex, doc: "test for a 
        complex number"];
        DefinePrimitive[name: "real?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $real, doc: "test for a real (i.e., 
        non-complex) number"];
        DefinePrimitive[name: "rational?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $rational, doc: "test for a 
        rational number"];
        DefinePrimitive[name: "integer?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $integer, doc: "test for an 
        integer number"];
        DefinePrimitive[name: "exact?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $exact, doc: "test a number for 
        exactness"];
        DefinePrimitive[name: "inexact?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $inexact, doc: "test a number for 
        inexactness"];
        DefinePrimitive[name: "odd?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $odd, doc: "test an integer for 
        oddness"];
        DefinePrimitive[name: "even?", nArgs: 1, dotted: FALSE, proc: NumTypePredPrim, env: env, data: $even, doc: "test an integer for 
        evenness"];
        };

    RegisterOptionals: PROC [env: Environment] ~ {
        DefinePrimitive[name: "+", nArgs: 2, optional: 2, dotted: TRUE, proc: ArithPrim, env: env,
        doc: "n-ary arithmetic addition", data: NEW[ArithOp Ź plus]];
        DefinePrimitive[name: "-", nArgs: 2, optional: 1, dotted: TRUE, proc: ArithPrim, env: env,
        doc: "n-ary arithmetic subtraction", data: NEW[ArithOp Ź minus]];
        DefinePrimitive[name: "*", nArgs: 2, optional: 2, dotted: TRUE, proc: ArithPrim, env: env,
        doc: "n-ary arithmetic multiplication", data: NEW[ArithOp Ź mult]];
        DefinePrimitive[name: "/", nArgs: 2, optional: 1, dotted: TRUE, proc: ArithPrim, env: env,
        doc: "n-ary arithmetic division", data: NEW[ArithOp Ź divide]];
        DefinePrimitive[name: "exact->inexact", nArgs: 1, dotted: FALSE, proc: NumFnsPrim, env: env, data: $inexact, doc: "convert a number 
        to an inexact number"];
        DefinePrimitive[name: "inexact->exact", nArgs: 1, dotted: FALSE, proc: NumFnsPrim, env: env, data: $exact, doc: "convert a number 
        to an exact number"];
        DefinePrimitive[name: "numerator", nArgs: 1, dotted: FALSE, proc: NumFnsPrim, env: env, data: $numerator, doc: "extract the 
        numerator of a rational number"];
        DefinePrimitive[name: "denominator", nArgs: 1, dotted: FALSE, proc: NumFnsPrim, env: env, data: $denominator, doc: "extract the 
        denominator of a rational number"];
        DefinePrimitive[name: "gcd", nArgs: 0, dotted: TRUE, proc: NumFnsPrim, env: env, data: $gcd, doc: "greatest common divisor of 
        integers"];
        DefinePrimitive[name: "truncate", nArgs: 1, dotted: FALSE, proc: NumFnsPrim, env: env, data: $truncate, doc: "truncate towards 
        zero"];
        DefinePrimitive[name: "round", nArgs: 1, dotted: FALSE, proc: NumFnsPrim, env: env, data: $round, doc: "round towards even"];
        DefinePrimitive[name: "make-rectangular", nArgs: 2, dotted: FALSE, proc: ComplexPrim, env: env, data: $rectangular, doc: "make a 
        complex number from rectangular coordinates"];
        DefinePrimitive[name: "make-polar", nArgs: 2, dotted: FALSE, proc: ComplexPrim, env: env, data: $polar, doc: "make a complex number 
        from polar coordinates"];
        DefinePrimitive[name: "real-part", nArgs: 1, dotted: FALSE, proc: ComplexPrim, env: env, data: $realPart, doc: "extract the real 
        part of a complex number"];
        DefinePrimitive[name: "imag-part", nArgs: 1, dotted: FALSE, proc: ComplexPrim, env: env, data: $imagPart, doc: "extract the 
        imaginary part of a complex number"];
        };

    RegisterRealFns: PROC [env: Environment] ~ {
        DefinePrimitive[name: "real-fns-sqrt", nArgs: 1, dotted: FALSE, proc: RealFnsPrim, env: env, data: $sqrt,
        doc: "square root of a real number"];
        DefinePrimitive[name: "real-fns-exp", nArgs: 1, dotted: FALSE, proc: RealFnsPrim, env: env, data: $exp,
        doc: "exponential function of a real number"];
        DefinePrimitive[name: "real-fns-expt", nArgs: 2, dotted: FALSE, proc: RealFnsPrim, env: env, data: $expt,
        doc: "exponentiation for real numbers"];
        DefinePrimitive[name: "real-fns-log", nArgs: 1, dotted: FALSE, proc: RealFnsPrim, env: env, data: $log,
        doc: "natural logarithm of a real number"];
        DefinePrimitive[name: "real-fns-sin", nArgs: 1, dotted: FALSE, proc: RealFnsPrim, env: env, data: $sin,
        doc: "sin of a real number"];
        DefinePrimitive[name: "real-fns-cos", nArgs: 1, dotted: FALSE, proc: RealFnsPrim, env: env, data: $cos,
        doc: "cosine of a real number"];
        DefinePrimitive[name: "real-fns-tan", nArgs: 1, dotted: FALSE, proc: RealFnsPrim, env: env, data: $tan,
        doc: "tangent of a real number"];
        DefinePrimitive[name: "real-fns-atan", nArgs: 2, optional: 1, dotted: FALSE, proc: RealFnsPrim, env: env, data: $atan,
        doc: "arc-tangent of a real number or a pair of real numbers"];
        };

<<Initalization>>
    RegisterInit[RegisterEssentials];
    RegisterInit[RegisterOptionals];
    RegisterInit[RegisterRealFns];

    END.