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