DRealSupportImpl.mesa
Copyright Ó 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
Russ Atkinson (RRA) June 22, 1989 9:57:24 pm PDT
Christian Jacobi, November 21, 1989 11:26:28 am PST
JKF, November 21, January 8, 1990 11:38:20 am PST
Willie-s, April 20, 1993 3:36 pm PDT
DIRECTORY
DRealSupport,
FloatingPointCommon USING [Error, NumberType];
DRealSupportImpl: CEDAR PROGRAM
IMPORTS FloatingPointCommon
EXPORTS DRealSupport
= BEGIN OPEN DRealSupport;
NumberType: TYPE = FloatingPointCommon.NumberType;
simpleClassification: BOOL = NumberType.LAST.ORD = 6 AND NumberType.zero.ORD = 0
AND NumberType.subnormal.ORD = 1 AND NumberType.normal.ORD = 2
AND NumberType.infinity.ORD = 3 AND NumberType.quiet.ORD = 4
AND NumberType.signaling.ORD = 5 AND NumberType.other.ORD = 6;
Public procedures written in Mesa
Classify: PUBLIC PROC [d: DREAL] RETURNS [NumberType] = TRUSTED {
w: WORD = DRealClassifyI[@d];
IF simpleClassification
THEN
We have statically determined that this will give the correct result
RETURN [VAL[w]]
ELSE
SELECT w FROM
0 => RETURN [zero];
1 => RETURN [subnormal];
2 => RETURN [normal];
3 => RETURN [infinity];
4 => RETURN [quiet];
5 => RETURN [signaling];
ENDCASE => RETURN [other];
};
Example: PUBLIC PROC [c: NumberType, min: BOOL ¬ FALSE] RETURNS [DREAL] = TRUSTED {
d: DREAL ¬ 0.0;
SELECT c FROM
subnormal => IF min
THEN {
help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE {
"+#define ex←subnormal←min(x) (DRealPtr(x)=min←subnormal())\n";
".ex←subnormal←min"
};
help[@d];
}
ELSE {
help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE {
"+#define ex←subnormal←max(x) (DRealPtr(x)=max←subnormal())\n";
".ex←subnormal←max"
};
help[@d];
};
normal => IF min
THEN {
help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE {
"+#define ex←normal←min(x) (DRealPtr(x)=min←normal())\n";
".ex←normal←min"
};
help[@d];
}
ELSE {
help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE {
"+#define ex←normal←max(x) (DRealPtr(x)=max←normal())\n";
".ex←normal←max"
};
help[@d];
};
infinity => {
help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE {
"+#define ex←infinity(x) (DRealPtr(x)=infinity())\n";
".ex←infinity"
};
help[@d];
};
quiet => {
help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE {
"+#define ex←quiet(x) (DRealPtr(x)=quiet←nan(0))\n";
".ex←quiet"
};
help[@d];
};
signaling => {
help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE {
"+#define ex←signaling(x) (DRealPtr(x)=signaling←nan(0))\n";
".ex←signaling"
};
help[@d];
};
ENDCASE;
RETURN [d];
};
DRealToReal: PUBLIC PROC [d: DREAL] RETURNS [REAL] = TRUSTED {
RETURN [FloatDRealI[@d]];
};
IntToDReal: PUBLIC PROC [i: INT] RETURNS [ret: DREAL] = TRUSTED {
DFloatInt[@ret, i];
};
CardToDReal: PUBLIC PROC [c: CARD] RETURNS [ret: DREAL] = TRUSTED {
DFloatCard[@ret, c];
};
RealToDReal: PUBLIC PROC [r: REAL] RETURNS [ret: DREAL] = TRUSTED {
DFloatReal[@ret, r];
};
Fix: PUBLIC PROC [x: DREAL] RETURNS [INT] = {
... rounds toward zero (error if outside the INT range)
last: INT = INT.LAST;
first: INT = INT.FIRST;
ret: INT ¬ 0;
frac: DREAL ¬ 0.0;
IF x < first THEN ERROR FloatingPointCommon.Error[other];
IF x >= CARD[last]+1 THEN ERROR FloatingPointCommon.Error[other];
[ret, frac] ¬ Modf[x];
IF x < 0.0 THEN IF frac # 0.0 THEN ret ¬ ret - 1;
RETURN [ret];
};
Round: PUBLIC PROC [x: DREAL] RETURNS [INT] = {
... rounds toward nearest (error if outside the INT range)
last: INT = INT.LAST;
first: INT = INT.FIRST;
ret: INT ¬ 0;
frac: DREAL ¬ 0.0;
IF x <= first THEN {
IF (x+0.5) >= first THEN RETURN [first];
ERROR FloatingPointCommon.Error[other];
};
IF x >= last THEN {
IF (x-0.5) <= last THEN RETURN [last];
ERROR FloatingPointCommon.Error[other];
};
[ret, frac] ¬ Modf[x];
SELECT TRUE FROM
frac < 0.5 => ret ¬ ret - 1;
frac = 0.5 => IF (ret MOD 2) # 0 THEN ret ¬ ret + 1;
ENDCASE => ret ¬ ret + 1;
RETURN [ret];
};
Modf: PROC [x: DREAL] RETURNS [int: INT, frac: DREAL] = TRUSTED {
DRealModfI: UNSAFE PROC [x: PDREAL, frac: PDREAL, ip: POINTER TO DINT]
= UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealModfI (x, frac, ip) W2 *x, *frac; double *ip; {\n";
" double d = DRealPtr(x);\n";
" d = modf(d, ip);\n";
" DRealPtr(frac) = d;\n";
" }\n";
".XR𡤍RealModfI";
};
di: DINT;
DRealModfI[@x, @frac, @di];
int ¬ di;
};
FScale: PUBLIC PROC [a: DREAL, scale: INTEGER] RETURNS [DREAL] = {
SELECT scale FROM
-2 => RETURN [a*0.25];
-1 => RETURN [a*0.5];
0 => RETURN [a];
1 => RETURN [a*2.0];
2 => RETURN [a*4.0];
ENDCASE => {
half: INTEGER = scale/2;
rem: INTEGER = scale-half;
RETURN [FScale[1.0, half]*FScale[a, rem]];
};
};
Neg: PUBLIC PROC [d: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealNegI[@ret, @d];
};
Abs: PUBLIC PROC [d: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealAbsI[@ret, @d];
};
Add: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealAddI[@ret, @x, @y];
};
Sub: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealSubI[@ret, @x, @y];
};
Mul: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealMulI[@ret, @x, @y];
};
Div: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealDivI[@ret, @x, @y];
};
Gt: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED {
RETURN [DRealGtI[@x, @y]];
};
Ge: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED {
RETURN [DRealGeI[@x, @y]];
};
Lt: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED {
RETURN [DRealLtI[@x, @y]];
};
Le: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED {
RETURN [DRealLeI[@x, @y]];
};
Eq: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED {
RETURN [DRealEqI[@x, @y]];
};
Ne: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED {
RETURN [DRealNeI[@x, @y]];
};
Min: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealMinI[@ret, @x, @y];
};
Max: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealMaxI[@ret, @x, @y];
};
Pwr: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealPwrI[@ret, @x, @y];
};
Floor: PUBLIC PROC [x: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealFloorI[@ret, @x];
};
Ceiling: PUBLIC PROC [x: DREAL] RETURNS [ret: DREAL] = TRUSTED {
DRealCeilingI[@ret, @x];
};
Support procedures written in C
PREAL: TYPE = POINTER TO REAL;
PDREAL: TYPE = POINTER TO DREAL;
DRealClassifyI: UNSAFE PROC [x: PDREAL] RETURNS [NAT] = UNCHECKED MACHINE CODE {
"+extern word XR𡤍RealClassifyI (x) W2 *x; {\n";
" double d = DRealPtr(x);\n";
" word w = fp𡤌lass(d);\n";
" switch (w) {\n";
" case fp←zero: return (0);\n";
" case fp←subnormal: return (1);\n";
" case fp←normal: return (2);\n";
" case fp←infinity: return (3);\n";
" case fp←quiet: return (4);\n";
" case fp←signaling: return (5);\n";
" };\n";
" return (6);\n";
" }\n";
".XR𡤍RealClassifyI";
};
FloatDFloatI: UNSAFE PROC [x: PDREAL] RETURNS [REAL] = UNCHECKED MACHINE CODE {
Ch.J.: C2C does not generate XR𡤏loatDFloatI any more. (From November 21, 1989 11:24:20 am PST on). This is replaced by XR𡤏loatDRealI.
"+extern word XR𡤏loatDFloatI (x) W2 *x; {\n";
" float f = DRealPtr(x);\n";
" return (*((ptr) &f));\n";
" }\n";
".XR𡤏loatDFloatI";
};
FloatDRealI: UNSAFE PROC [x: PDREAL] RETURNS [REAL] = UNCHECKED MACHINE CODE {
"+extern word XR𡤏loatDRealI (x) W2 *x; {\n";
" float f = DRealPtr(x);\n";
" return (*((ptr) &f));\n";
" }\n";
".XR𡤏loatDRealI";
};
DFloatInt: UNSAFE PROC [ret: PDREAL, x: INT] = UNCHECKED MACHINE CODE {
"+extern void XR�loatInt (ret, x) W2 *ret; word x; {\n";
" DRealPtr(ret) = ((int) x);\n";
" }\n";
".XR𡤏loatInt";
};
DFloatCard: UNSAFE PROC [ret: PDREAL, x: CARD] = UNCHECKED MACHINE CODE {
"+extern void XR�loatCard (ret, x) W2 *ret; word x; {\n";
" DRealPtr(ret) = ((unsigned) x);\n";
" }\n";
".XR�loatCard";
};
DFloatReal: UNSAFE PROC [ret: PDREAL, x: REAL] = UNCHECKED MACHINE CODE {
"+extern void XR�loatReal (ret, x) W2 *ret; word x; {\n";
" float f = *((float *) &x);\n";
" DRealPtr(ret) = f;\n";
" }\n";
".XR�loatReal";
};
DRealNegI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealNegI (ret, x) W2 *ret, *x; {\n";
" DRealPtr(ret) = - DRealPtr(x);\n";
" }\n";
".XR𡤍RealNegI";
};
DRealAbsI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealAbsI (ret, x) W2 *ret, *x; {\n";
" DRealPtr(ret) = fabs(DRealPtr(x));\n";
" }\n";
".XR𡤍RealAbsI";
};
DRealAddI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealAddI (ret, x, y) W2 *ret, *x, *y; {\n";
" DRealPtr(ret) = DRealPtr(x) + DRealPtr(y);\n";
" }\n";
".XR𡤍RealAddI";
};
DRealSubI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealSubI (ret, x, y) W2 *ret, *x, *y; {\n";
" DRealPtr(ret) = DRealPtr(x) - DRealPtr(y);\n";
" }\n";
".XR𡤍RealSubI";
};
DRealMulI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealMulI (ret, x, y) W2 *ret, *x, *y; {\n";
" DRealPtr(ret) = DRealPtr(x) * DRealPtr(y);\n";
" }\n";
".XR𡤍RealMulI";
};
DRealDivI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealDivI (ret, x, y) W2 *ret, *x, *y; {\n";
" DRealPtr(ret) = DRealPtr(x) / DRealPtr(y);\n";
" }\n";
".XR𡤍RealDivI";
};
DRealGtI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE {
"+extern word XR𡤍RealGtI (x, y) W2 *x, *y; {\n";
" if ( DRealPtr(x) > DRealPtr(y) ) {return (1);};\n";
" return (0);\n";
" }\n";
".XR𡤍RealGtI";
};
DRealGeI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE {
"+extern word XR𡤍RealGeI (x, y) W2 *x, *y; {\n";
" if ( DRealPtr(x) >= DRealPtr(y) ) {return (1);};\n";
" return (0);\n";
" }\n";
".XR𡤍RealGeI";
};
DRealLtI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE {
"+extern word XR𡤍RealLtI (x, y) W2 *x, *y; {\n";
" if ( DRealPtr(x) < DRealPtr(y) ) {return (1);};\n";
" return (0);\n";
" }\n";
".XR𡤍RealLtI";
};
DRealLeI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE {
"+extern word XR𡤍RealLeI (x, y) W2 *x, *y; {\n";
" if ( DRealPtr(x) <= DRealPtr(y) ) {return (1);};\n";
" return (0);\n";
" }\n";
".XR𡤍RealLeI";
};
DRealEqI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE {
"+extern word XR𡤍RealEqI (x, y) W2 *x, *y; {\n";
" if ( DRealPtr(x) == DRealPtr(y) ) {return (1);};\n";
" return (0);\n";
" }\n";
".XR𡤍RealEqI";
};
DRealNeI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE {
"+extern word XR𡤍RealNeI (x, y) W2 *x, *y; {\n";
" if ( DRealPtr(x) != DRealPtr(y) ) {return (1);};\n";
" return (0);\n";
" }\n";
".XR𡤍RealNeI";
};
DRealMinI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealMinI (ret, x, y) W2 *ret, *x, *y; {\n";
" if ( DRealPtr(x) <= DRealPtr(y) ) {*ret = *x; return;};\n";
" *ret = *y;\n";
" }\n";
".XR𡤍RealMinI";
};
DRealMaxI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealMaxI (ret, x, y) W2 *ret, *x, *y; {\n";
" if ( DRealPtr(x) >= DRealPtr(y) ) {*ret = *x; return;};\n";
" *ret = *y;\n";
" }\n";
".XR𡤍RealMaxI";
};
DRealPwrI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealPwrI (ret, x, y) W2 *ret, *x, *y; {\n";
" DRealPtr(ret) = pow(DRealPtr(x), DRealPtr(y));\n";
" }\n";
".XR𡤍RealPwrI";
};
DRealFloorI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealFloorI (ret, x) W2 *ret, *x; {\n";
" DRealPtr(ret) = floor(DRealPtr(x));\n";
" }\n";
".XR𡤍RealFloorI";
};
DRealCeilingI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE {
"+extern void XR𡤍RealCeilingI (ret, x) W2 *ret, *x; {\n";
" DRealPtr(ret) = ceil(DRealPtr(x));\n";
" }\n";
".XR𡤍RealCeilingI";
};
Initialization
DefInclude: PROC = TRUSTED MACHINE CODE {
"*";
"#include <math.h>\n";
"."
};
DefDRealPtr: PROC = TRUSTED MACHINE CODE {
"+#define DRealPtr(x) (*((double *) (x)))\n."
};
DefInclude[];
DefDRealPtr[];
TRUSTED {
dummy: DREAL ¬ 1.0;
dummyPtr: PDREAL ¬ @dummy;
[] ¬ FloatDFloatI[dummyPtr]}; -- need a use of FloatDFloatI to get the code included
END.