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.