DSupportImpl.mesa
Copyright Ó 1989, 1991 by Xerox Corporation. All rights reserved.
Christian Jacobi, November 15, 1989 9:09:45 pm PST
Christian Jacobi, December 14, 1989 11:46:53 am PST
Michael Plass, October 17, 1991 12:30 pm PDT
DIRECTORY
RealSupport USING [FScale, CardToReal],
RuntimeError USING [BoundsFault, ZeroDivisor],
DRealSupport USING [FScale, CardToDReal];
DSupportImpl: CEDAR PROGRAM
IMPORTS RealSupport, RuntimeError, DRealSupport =
BEGIN
Representation
DCARD: high32, low32
DINT: high32, low32; two's complement of 64 bits
ExternalNames: PROC [] = TRUSTED MACHINE CODE {
"^ExternalNames\n";
--test feature
"D64SetTestMode XR�SetTestMode\n";
--integer conversions
"DCardCard  XR�rdCard\n";
"DCardInt  XR�rdInt\n";
"DCardDInt  XR�rdDIntI\n";
"DIntInt  XR𡤍IntInt\n";
"DIntCard  XR𡤍IntCard\n";
"DIntDCard  XR𡤍IntDCardI\n";
"CardDInt  XR�rdDIntI\n";
"CardDCard  XR�rdDCardI\n";
"IntDInt  XR←IntDIntI\n";
"IntDCard  XR←IntDCardI\n";
--DCARD operations
"DCardAdd  XR�rdAddI\n";
"DCardSub  XR�rdSubI\n";
"DCardMul  XR�rdMulI\n";
"DCardDiv  XR�rdDivI\n";
"DCardMod  XR�rdModI\n";
"DCardPwr  XR�rdPwrI\n";
"DCardMin  XR�rdMinI\n";
"DCardMax  XR�rdMaxI\n";
"DCardGt  XR�rdGtI\n";
"DCardGe  XR�rdGeI\n";
"DEq  XR�qI\n";
--DINT operations
"DIntNeg  XR𡤍IntNegI\n";
"DIntAdd  XR𡤍IntAddI\n";
"DIntSub  XR𡤍IntSubI\n";
"DIntMul  XR𡤍IntMulI\n";
"DIntDiv  XR𡤍IntDivI\n";
"DIntMod  XR𡤍IntModI\n";
"DIntPwr  XR𡤍IntPwrI\n";
"DIntMin  XR𡤍IntMinI\n";
"DIntMax  XR𡤍IntMaxI\n";
"DIntGt  XR𡤍IntGtI\n";
"DIntGe  XR𡤍IntGeI\n";
"DIntAbs  XR𡤍IntAbsI\n";
--Floating point and D conversions
"DFloatDInt  XR�loatDIntI\n";
"DFloatDCard XR�loatDCardI\n";
"FloatDInt  XR𡤏loatDIntI\n";
"FloatDCard  XR𡤏loatDCardI\n";
};
DPointer: TYPE = POINTER TO DNumber;
DNumber: TYPE = MACHINE DEPENDENT RECORD [
SELECT OVERLAID * FROM
c64 => [c64: CARD64],
i64 => [i64: INT64],
r64 => [r64: REAL64],
c32 => [ch32, cl32: CARD32],
i32 => [ih32, il32: INT32],
c16 => [d3, d2, d1, d0: CARD16],
up => [bit0: [0..1], nhr: NAT31, bit32: [0..1], nlr: NAT31],
lo => [nhl: NAT31, bit31: [0..1], nll: NAT31, bit63: [0..1]],
ENDCASE
];
arithmeticError64: SIGNAL = CODE;
overFlowTests64: BOOL ¬ FALSE; --set TRUE for debugging package; FALSE for normal usage
conversiontests64: BOOL = TRUE;
ConversionError: PROC [] = {
IF conversiontests64 THEN ERROR RuntimeError.BoundsFault;
};
Overflow: PROC [] = {
IF overFlowTests64 THEN SIGNAL arithmeticError64;
};
D64SetTestMode: UNSAFE PROC [c: CARD] = TRUSTED {
--This procedure is private between this module and its test code.
--Other applications must not use this; if the feature is required and approved
--it would be put in a definition module, made work on a per process basis
--and set and removed in a region protected with an enable scope
overFlowTests64 ¬ c#0
};
DCardCard: UNSAFE PROC [res: DPointer, c: CARD32] = TRUSTED {
res.cl32 ¬ c; res.ch32 ¬ 0;
};
DCardInt: UNSAFE PROC [res: DPointer, i: INT32] = TRUSTED {
IF i<0 THEN ConversionError[];
res.il32 ¬ i; res.ch32 ¬ 0;
};
DCardDInt: UNSAFE PROC [res, dint: DPointer] = TRUSTED {
IF dint.ih32<0 THEN ConversionError[];
res­ ¬ dint­;
};
DIntCard: UNSAFE PROC [res: DPointer, c: CARD32] = TRUSTED {
res.ch32 ¬ 0; res.cl32 ¬ c;
};
DIntInt: UNSAFE PROC [res: DPointer, i: INT32] = TRUSTED {
IF i>=0 THEN res.ih32 ¬ 0 ELSE res.ih32 ¬ -1;
res.il32 ¬ i;
};
DIntDCard: UNSAFE PROC [res, dcard: DPointer] = TRUSTED {
IF dcard.ih32<0 THEN ConversionError[];
res­ ¬ dcard­;
};
CardDInt: UNSAFE PROC [dint: DPointer] RETURNS [CARD32] = TRUSTED {
IF dint.ch32#0 THEN ConversionError[];
RETURN [dint.cl32];
};
CardDCard: UNSAFE PROC [dcard: DPointer] RETURNS [CARD32] = TRUSTED {
IF dcard.ch32#0 THEN ConversionError[];
RETURN [dcard.cl32];
};
IntDInt: UNSAFE PROC [dint: DPointer] RETURNS [INT32] = TRUSTED {
SELECT dint.ch32 FROM
0 => IF dint.il32<0 THEN ConversionError[];
LAST[CARD] => IF dint.il32>=0 THEN ConversionError[];
ENDCASE => ConversionError[];
RETURN [dint.il32];
};
IntDCard: UNSAFE PROC [dcard: DPointer] RETURNS [INT32] = TRUSTED {
IF dcard.ch32#0 OR dcard.il32<0 THEN ConversionError[];
RETURN [dcard.il32];
};
DCardAdd: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
over: CARD32 ¬ IF (LAST[CARD32]-a.cl32)<b.cl32 THEN 1 ELSE 0;
IF (LAST[CARD32]-a.ch32)<=b.ch32 THEN {
IF (LAST[CARD32]-a.ch32)<b.ch32 OR over#0 THEN Overflow[];
};
res.cl32 ¬ a.cl32 + b.cl32;
res.ch32 ¬ a.ch32 + b.ch32 + over;
};
DCardSub: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
over: CARD32 ¬ IF a.cl32<b.cl32 THEN 1 ELSE 0;
IF a.ch32<=b.ch32 THEN {
IF a.ch32<b.ch32 OR over#0 THEN Overflow[];
};
res.cl32 ¬ a.cl32 - b.cl32;
res.ch32 ¬ a.ch32 - b.ch32 - over;
};
DCardMul: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
unit: CARD32 = LAST[CARD16]+1;
r0, r1, r2, r3: CARD32;
carry3, p1a, p1b, p2a, p2b, p2c, p3a, p3b, p3c, p3d: CARD32;
--
r0: CARD32 ← a.d0*b.d0;
r0 ¬ a.d0*b.d0;
--
r1: CARD32 ← a.d1*b.d0 + a.d0*b.d1;
p1a ¬ a.d1*b.d0;
p1b ¬ a.d0*b.d1;
carry3 ¬ IF LAST[CARD32]-p1a<p1b THEN 1 ELSE 0;
r1 ¬ p1a + p1b;
--
r2: CARD32 ← a.d2*b.d0 + a.d1*b.d1 + a.d0*b.d2;
p2a ¬ a.d2*b.d0;
p2b ¬ a.d1*b.d1;
p2c ¬ a.d0*b.d2;
IF LAST[CARD32]-p2a<p2b THEN Overflow[];
r2 ¬ p2a + p2b;
IF LAST[CARD32]-r2<p2c THEN Overflow[];
r2 ¬ r2 + p2c;
--
r3: CARD32 ← a.d3*b.d0 + a.d2*b.d1 + a.d1*b.d2 + a.d0*b.d3;
p3a ¬ a.d3*b.d0 + carry3; --can't overflow
p3b ¬ a.d2*b.d1;
p3c ¬ a.d1*b.d2;
p3d ¬ a.d0*b.d3;
IF p3a>unit OR p3b>unit OR p3c>unit OR p3d>unit THEN Overflow[];
r3 ¬ p3a + p3b + p3c + p3d;
--
r4: CARD32 ← a.d3*b.d1 + a.d2*b.d2 + a.d1 * b.d3;
--
r5: CARD32 ← a.d3*b.d2 + a.d2*b.d3;
--
r6: CARD32 ← a.d3*b.d3;
--
--res.d0
res.d0 ¬ r0 MOD unit;
r0 ¬ r0/unit;
--
--res.d1
carry3 ¬ IF LAST[CARD32]-r1<r0 THEN 1 ELSE 0;
r1 ¬ r1 + r0;
res.d1 ¬ r1 MOD unit;
r1 ¬ r1/unit;
--
--res.d2
IF LAST[CARD32]-r2<r1 THEN Overflow[];
r2 ¬ r2 + r1;
res.d2 ¬ r2 MOD unit;
r2 ¬ r2/unit;
--
--res.d3
IF r3>unit THEN Overflow[];
r3 ¬ r3 + r2 + carry3; --can't overflow anymore
res.d3 ¬ r3 MOD unit;
--res.d4..6
IF r3>=unit OR
(a.d3>0 AND (b.d1+b.d2+b.d3>0)) OR
(b.d3>0 AND (a.d1+a.d2>0)) OR
(a.d2>0 AND b.d2>0) THEN Overflow[];
};
Div2: PROC [a: DPointer] RETURNS [res: DNumber] = TRUSTED {
res.cl32 ¬ (a.ch32 MOD 2) * 20000000000B + a.cl32 / 2;
res.ch32 ¬ a.ch32 / 2;
};
Mul2: PROC [a: DPointer] RETURNS [res: DNumber] = TRUSTED INLINE {
res.c64 ¬ a.c64 + a.c64
};
DCardDiv: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
IF a.c64<b.c64 THEN res.c64 ¬ 0
ELSE IF b.ch32=0 AND b.cl32<=2 THEN {
SELECT b.cl32 FROM
2 => res­ ¬ Div2[a];
1 => res­ ¬ a­;
0 => SIGNAL RuntimeError.ZeroDivisor;
ENDCASE => ERROR;
}
ELSE {
result: DNumber ¬ [c64[0]];
d: DNumber ¬ b­;
count: NAT ¬ 1;
rest: DNumber ¬ Div2[a];
WHILE d.c64<=rest.c64 DO d ¬ Mul2[@d]; count ¬ count + 1 ENDLOOP;
rest ¬ a­;
FOR i: NAT IN [0..count) DO
result ¬ Mul2[@result];
IF rest.c64>=d.c64 THEN {rest.c64 ¬ rest.c64 - d.c64; result.c64 ¬ result.c64 + 1};
d ¬ Div2[@d];
ENDLOOP;
res­ ¬ result;
};
};
DCardMod: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
res.c64 ¬ a.c64 - (a.c64 / b.c64) * b.c64;
};
DCardPwr: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
MixedPwr: UNSAFE PROC [x: CARD64, y: CARD32] RETURNS [CARD64] = TRUSTED {
SELECT y FROM
0 => RETURN [1];
1 => RETURN [x];
ENDCASE =>
IF y MOD 2 # 0
THEN RETURN [x * MixedPwr[x*x, y / 2]]
ELSE RETURN [MixedPwr[x*x, y / 2]];
};
IF b.ch32>0 THEN {
IF a.ch32>0
THEN Overflow[]
ELSE SELECT a.cl32 FROM
0 => res.c64 ¬ 0;
1 => res.c64 ¬ a.c64;
ENDCASE => Overflow[];
RETURN;
};
res.c64 ¬ MixedPwr[a.c64, b.cl32]
};
DCardGt: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED {
SELECT TRUE FROM
a.ch32>b.ch32 => RETURN [TRUE];
a.ch32<b.ch32 => RETURN [FALSE];
ENDCASE => RETURN [a.cl32>b.cl32]
};
DCardGe: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED {
SELECT TRUE FROM
a.ch32>b.ch32 => RETURN [TRUE];
a.ch32<b.ch32 => RETURN [FALSE];
ENDCASE => RETURN [a.cl32>=b.cl32]
};
DEq: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED {
RETURN [a.cl32=b.cl32 AND a.ch32=b.ch32]
};
DCardMin: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
IF DCardGt[a, b] THEN res­ ¬ b­ ELSE res­ ¬ a­
};
DCardMax: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
IF DCardGt[a, b] THEN res­ ¬ a­ ELSE res­ ¬ b­
};
XDIntNeg: UNSAFE PROC [res, a: DPointer] = TRUSTED {
n1: DNumber ¬ [c32[LAST[CARD32], LAST[CARD32]]];
p1: DNumber ¬ [c32[0, 1]];
t: DNumber;
DIntSub[@t, @n1, a];
DIntSub[res, @t, @p1];
};
Neg64: UNSAFE PROC [res, n: DPointer] = TRUSTED {
untested negative of 64 bit (two's complement)
res.cl32 ¬ LAST[CARD32] - n.cl32;
res.ch32 ¬ LAST[CARD32] - n.ch32;
IF res.cl32=LAST[CARD32]
THEN {res.ch32 ¬ res.ch32 + 1; res.cl32 ¬ 0}
ELSE res.cl32 ¬ res.cl32 + 1
};
IsDFirstNeg: PROC [a: DPointer] RETURNS [BOOL ] = TRUSTED INLINE {
RETURN [a.cl32=0 AND a.ih32=FIRST[INT32]]
};
DIntNeg: UNSAFE PROC [res, a: DPointer] = TRUSTED {
IF IsDFirstNeg[a] THEN Overflow[];
Neg64[res, a];
};
DIntAdd: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
over: CARD32 ¬ IF (LAST[CARD32]-a.cl32)<b.cl32 THEN 1 ELSE 0;
h: CARD32 ¬ a.ch32 + b.ch32 + over;
IF
(LOOPHOLE[h, INT32]<0 AND a.ih32>=0 AND b.ih32>=0) OR
(LOOPHOLE[h, INT32]>=0 AND a.ih32<0 AND b.ih32<0) THEN Overflow[];
res.cl32 ¬ a.cl32 + b.cl32;
res.ch32 ¬ h;
};
DIntSub: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
over: CARD32 ¬ IF a.cl32<b.cl32 THEN 1 ELSE 0;
h: CARD32 ¬ a.ch32 - b.ch32 - over;
IF
(a.ih32<0 AND LOOPHOLE[h, INT32]>=0 AND b.ih32>=0) OR
(a.ih32>=0 AND LOOPHOLE[h, INT32]<0 AND b.ih32<0) THEN Overflow[];
res.cl32 ¬ a.cl32 - b.cl32;
res.ch32 ¬ h;
};
DIntMul: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
x, y: DNumber; invert: BOOL ¬ FALSE;
IF a.ih32>=0
THEN x ¬ a­
ELSE {Neg64[@x, a]; invert ¬ NOT invert};
IF b.ih32>=0
THEN y ¬ b­
ELSE {Neg64[@y, b]; invert ¬ NOT invert};
x.c64 ¬ x.c64*y.c64;
IF x.ih32<0 THEN Overflow[];
IF invert THEN Neg64[res, @x] ELSE res­ ¬ x;
};
DIntDiv: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
x, y: DNumber; invert: BOOL ¬ FALSE;
IF a.ih32>=0
THEN x ¬ a­
ELSE {Neg64[@x, a]; invert ¬ NOT invert};
IF b.ih32>=0
THEN y ¬ b­
ELSE {Neg64[@y, b]; invert ¬ NOT invert};
x.c64 ¬ x.c64 / y.c64;
IF x.ih32<0 THEN Overflow[];
IF invert THEN Neg64[res, @x] ELSE res­ ¬ x;
};
DIntMod: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
--will signal RuntimeError.ZeroDivisor if necessary without explicit test here because it is mapped to CARD64 MOD
IF b.ih32>=0 THEN {
IF a.ih32>=0 THEN {
res.c64 ¬ a.c64 MOD b.c64
}
ELSE {
m: DNumber;
Neg64[@m, a];
m.c64 ¬ m.c64 MOD b.c64;
IF m.ch32=0 AND m.cl32=0 THEN res­ ¬ m ELSE res.c64 ¬ b.c64 - m.c64
}
}
ELSE {
bb, m: DNumber;
Neg64[@bb, b];
IF a.ih32>=0 THEN {
m.c64 ¬ a.c64 MOD bb.c64;
IF m.ch32=0 AND m.cl32=0 THEN res­ ¬ m ELSE res.c64 ¬ m.c64 - bb.c64
}
ELSE {
Neg64[@m, a];
m.c64 ¬ m.c64 MOD bb.c64;
Neg64[res, @m]
}
}
};
DIntPwr: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
x: DNumber;
IF b.ih32<0 THEN Overflow[];
IF a.ih32>=0
THEN {
x.c64 ¬ a.c64 ** b.c64;
IF x.ih32<0 THEN Overflow[]
}
ELSE {
Neg64[@x, a];
x.c64 ¬ x.c64 ** b.c64;
IF x.ih32<0 THEN Overflow[];
IF b.cl32 MOD 2 # 0 THEN Neg64[@x, @x];
};
res­ ¬ x;
};
DIntGt: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED {
SELECT TRUE FROM
a.ih32>b.ih32 => RETURN [TRUE];
a.ih32<b.ih32 => RETURN [FALSE];
a.ih32<0 => RETURN [a.cl32<b.cl32];
ENDCASE => RETURN [a.cl32>b.cl32]
};
DIntGe: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED {
SELECT TRUE FROM
a.ih32>b.ih32 => RETURN [TRUE];
a.ih32<b.ih32 => RETURN [FALSE];
a.ih32<0 => RETURN [a.cl32<=b.cl32];
ENDCASE => RETURN [a.cl32>=b.cl32]
};
DIntAbs: UNSAFE PROC [res, a: DPointer] = TRUSTED {
--the result is CARD64...
IF a.ih32>=0
THEN res­ ¬ a­
ELSE Neg64[res, a] --no crash on FIRST[INT64]
};
DIntMin: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
IF DIntGt[a, b] THEN res­ ¬ b­ ELSE res­ ¬ a­
};
DIntMax: UNSAFE PROC [res, a, b: DPointer] = TRUSTED {
IF DIntGt[a, b] THEN res­ ¬ a­ ELSE res­ ¬ b­
};
DFloatDCard: UNSAFE PROC [res, a: DPointer] = TRUSTED {
res.r64 ¬ DRealSupport.FScale[DRealSupport.CardToDReal[a.ch32], 32] + DRealSupport.CardToDReal[a.cl32]
};
DFloatDInt: UNSAFE PROC [res: DPointer, a: DPointer] = TRUSTED {
IF a.ih32>=0
THEN res.r64 ¬ a.c64
ELSE {
aa: DNumber;
Neg64[@aa, a];
aa.r64 ¬ aa.c64;
res.r64 ¬ -aa.r64
}
};
FloatDCard: UNSAFE PROC [dcard: DPointer] RETURNS [REAL] = TRUSTED {
RETURN [RealSupport.FScale[RealSupport.CardToReal[dcard.ch32], 32] + RealSupport.CardToReal[dcard.cl32]]
};
FloatDInt: UNSAFE PROC [dint: DPointer] RETURNS [r: REAL] = TRUSTED {
IF dint.ih32>=0
THEN r ¬ dint.c64
ELSE {
aa: DNumber;
Neg64[@aa, dint];
r ¬ aa.c64;
r ¬ -r
}
};
ExternalNames[];
END.