mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 11:02:24 +00:00
Original meaning of VAL restored. Many library files disabled until use of VAL in 64 bits fixed.
This commit is contained in:
David Brown
parent
8f82f6e47b
commit
80f5e51789
29 changed files with 261 additions and 174 deletions
|
|
@ -2,20 +2,20 @@
|
|||
MODULE oocLowReal;
|
||||
|
||||
(*
|
||||
LowReal - Gives access to the underlying properties of the type REAL
|
||||
for IEEE single-precision numbers.
|
||||
LowReal - Gives access to the underlying properties of the type REAL
|
||||
for IEEE single-precision numbers.
|
||||
Copyright (C) 1995 Michael Griebling
|
||||
|
||||
|
||||
This module is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU Lesser General Public License as
|
||||
it under the terms of the GNU Lesser General Public License as
|
||||
published by the Free Software Foundation; either version 2 of the
|
||||
License, or (at your option) any later version.
|
||||
|
||||
|
||||
This module is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
|
@ -24,9 +24,9 @@ MODULE oocLowReal;
|
|||
|
||||
|
||||
IMPORT S := SYSTEM, Console;
|
||||
|
||||
|
||||
(*
|
||||
|
||||
|
||||
Real number properties are defined as follows:
|
||||
|
||||
radix--The whole number value of the radix used to represent the
|
||||
|
|
@ -44,69 +44,69 @@ IMPORT S := SYSTEM, Console;
|
|||
small--The smallest positive value of the corresponding real number
|
||||
type, represented to maximal precision.
|
||||
|
||||
IEC559--A Boolean value that is TRUE if and only if the implementation
|
||||
of the corresponding real number type conforms to IEC 559:1989
|
||||
IEC559--A Boolean value that is TRUE if and only if the implementation
|
||||
of the corresponding real number type conforms to IEC 559:1989
|
||||
(IEEE 754:1987) in all regards.
|
||||
|
||||
NOTES
|
||||
6 -- If `IEC559' is TRUE, the value of `radix' is 2.
|
||||
7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989
|
||||
7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989
|
||||
is used for the type REAL.
|
||||
7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989
|
||||
7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989
|
||||
is used for the type REAL.
|
||||
|
||||
LIA1--A Boolean value that is TRUE if and only if the implementation of
|
||||
the corresponding real number type conforms to ISO/IEC 10967-1:199x
|
||||
(LIA-1) in all regards: parameters, arithmetic, exceptions, and
|
||||
LIA1--A Boolean value that is TRUE if and only if the implementation of
|
||||
the corresponding real number type conforms to ISO/IEC 10967-1:199x
|
||||
(LIA-1) in all regards: parameters, arithmetic, exceptions, and
|
||||
notification.
|
||||
|
||||
rounds--A Boolean value that is TRUE if and only if each operation produces
|
||||
a result that is one of the values of the corresponding real number
|
||||
rounds--A Boolean value that is TRUE if and only if each operation produces
|
||||
a result that is one of the values of the corresponding real number
|
||||
type nearest to the mathematical result.
|
||||
|
||||
gUnderflow--A Boolean value that is TRUE if and only if there are values of
|
||||
the corresponding real number type between 0.0 and `small'.
|
||||
gUnderflow--A Boolean value that is TRUE if and only if there are values of
|
||||
the corresponding real number type between 0.0 and `small'.
|
||||
|
||||
exception--A Boolean value that is TRUE if and only if every operation that
|
||||
exception--A Boolean value that is TRUE if and only if every operation that
|
||||
attempts to produce a real value out of range raises an exception.
|
||||
|
||||
extend--A Boolean value that is TRUE if and only if expressions of the
|
||||
corresponding real number type are computed to higher precision than
|
||||
extend--A Boolean value that is TRUE if and only if expressions of the
|
||||
corresponding real number type are computed to higher precision than
|
||||
the stored values.
|
||||
|
||||
nModes--The whole number value giving the number of bit positions needed for
|
||||
nModes--The whole number value giving the number of bit positions needed for
|
||||
the status flags for mode control.
|
||||
|
||||
|
||||
*)
|
||||
CONST
|
||||
radix*= 2;
|
||||
CONST
|
||||
radix*= 2;
|
||||
places*= 24;
|
||||
expoMax*= 127;
|
||||
expoMax*= 127;
|
||||
expoMin*= 1-expoMax;
|
||||
large*= MAX(REAL);(*3.40282347E+38;*) (* MAX(REAL) *)
|
||||
(*small*= 1.17549435E-38; (* 2^(-126) *)*)
|
||||
small* = 1/8.50705917E37; (* don't know better way; -- noch *)
|
||||
IEC559*= TRUE;
|
||||
LIA1*= FALSE;
|
||||
rounds*= FALSE;
|
||||
rounds*= FALSE;
|
||||
gUnderflow*= TRUE; (* there are IEEE numbers smaller than `small' *)
|
||||
exception*= FALSE; (* at least in the default implementation *)
|
||||
extend*= FALSE;
|
||||
nModes*= 0;
|
||||
|
||||
|
||||
TEN=10.0; (* some commonly-used constants *)
|
||||
ONE=1.0;
|
||||
ONE=1.0;
|
||||
ZERO=0.0;
|
||||
|
||||
expOffset=expoMax;
|
||||
hiBit=22;
|
||||
|
||||
expOffset=expoMax;
|
||||
hiBit=22;
|
||||
expBit=hiBit+1;
|
||||
nMask={0..hiBit,31}; (* number mask *)
|
||||
expMask={expBit..30}; (* exponent mask *)
|
||||
|
||||
|
||||
TYPE
|
||||
Modes*= SET;
|
||||
|
||||
|
||||
VAR
|
||||
(*small* : REAL; tmp: REAL;*) (* this was a test to get small as a variable at runtime. obviously, compile time preferred; -- noch *)
|
||||
ErrorHandler*: PROCEDURE (errno : INTEGER);
|
||||
|
|
@ -132,15 +132,18 @@ p := p * i;
|
|||
PROCEDURE DefaultHandler (errno : INTEGER);
|
||||
BEGIN
|
||||
err:=errno
|
||||
END DefaultHandler;
|
||||
END DefaultHandler;
|
||||
|
||||
PROCEDURE ClearError*;
|
||||
BEGIN
|
||||
err:=0
|
||||
END ClearError;
|
||||
|
||||
END ClearError;
|
||||
|
||||
|
||||
|
||||
(*** Refactor for 64 bit support.
|
||||
PROCEDURE exponent*(x: REAL): INTEGER;
|
||||
(*
|
||||
(*
|
||||
The value of the call exponent(x) shall be the exponent value of `x'
|
||||
that lies between `expoMin' and `expoMax'. An exception shall occur
|
||||
and may be raised if `x' is equal to 0.0.
|
||||
|
|
@ -148,14 +151,15 @@ PROCEDURE exponent*(x: REAL): INTEGER;
|
|||
BEGIN
|
||||
(* NOTE: x=0.0 should raise exception *)
|
||||
IF x=ZERO THEN RETURN 0
|
||||
ELSE RETURN SHORT(S.LSH(S.VAL(LONGINT,x),-expBit) MOD 256)-expOffset
|
||||
ELSE RETURN SHORT(S.LSH(S.VAL(LONGINT,x),-expBit) MOD 256)-expOffset
|
||||
END
|
||||
END exponent;
|
||||
*)
|
||||
|
||||
PROCEDURE exponent10*(x: REAL): INTEGER;
|
||||
(*
|
||||
The value of the call exponent10(x) shall be the base 10 exponent
|
||||
value of `x'. An exception shall occur and may be raised if `x' is
|
||||
(*
|
||||
The value of the call exponent10(x) shall be the base 10 exponent
|
||||
value of `x'. An exception shall occur and may be raised if `x' is
|
||||
equal to 0.0.
|
||||
*)
|
||||
VAR exp: INTEGER;
|
||||
|
|
@ -163,19 +167,20 @@ BEGIN
|
|||
exp:=0; x:=ABS(x);
|
||||
IF x=ZERO THEN RETURN exp END; (* exception could be raised here *)
|
||||
WHILE x>=TEN DO x:=x/TEN; INC(exp) END;
|
||||
WHILE (x>ZERO) & (x<1.0) DO x:=x*TEN; DEC(exp) END;
|
||||
WHILE (x>ZERO) & (x<1.0) DO x:=x*TEN; DEC(exp) END;
|
||||
RETURN exp
|
||||
END exponent10;
|
||||
|
||||
|
||||
(*** Refactor for 64 bit support.
|
||||
PROCEDURE fraction*(x: REAL): REAL;
|
||||
(*
|
||||
The value of the call fraction(x) shall be the significand (or
|
||||
significant) part of `x'. Hence the following relationship shall
|
||||
hold: x = scale(fraction(x), exponent(x)).
|
||||
hold: x = scale(fraction(x), exponent(x)).
|
||||
*)
|
||||
CONST eZero={(hiBit+2)..29};
|
||||
CONST eZero={(hiBit+2)..29};
|
||||
BEGIN
|
||||
IF x=ZERO THEN RETURN ZERO
|
||||
IF x=ZERO THEN RETURN ZERO
|
||||
ELSE RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+eZero)*2.0 (* set the mantissa's exponent to zero *)
|
||||
END
|
||||
END fraction;
|
||||
|
|
@ -192,18 +197,20 @@ PROCEDURE IsNaN * (real: REAL) : BOOLEAN;
|
|||
BEGIN
|
||||
sreal:=S.VAL(SET, real);
|
||||
RETURN (sreal*expMask=expMask) & (sreal*fracMask#{})
|
||||
END IsNaN;
|
||||
END IsNaN;
|
||||
*)
|
||||
|
||||
PROCEDURE sign*(x: REAL): REAL;
|
||||
(*
|
||||
The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0,
|
||||
or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or
|
||||
-1.0 if `x' is equal to 0.0.
|
||||
-1.0 if `x' is equal to 0.0.
|
||||
*)
|
||||
BEGIN
|
||||
IF x<ZERO THEN RETURN -ONE ELSE RETURN ONE END
|
||||
END sign;
|
||||
|
||||
(*** Refactor for 64 bit support.
|
||||
PROCEDURE scale*(x: REAL; n: INTEGER): REAL;
|
||||
(*
|
||||
The value of the call scale(x,n) shall be the value x*radix^n if such
|
||||
|
|
@ -219,27 +226,27 @@ BEGIN
|
|||
lexp:=S.VAL(SET,S.LSH(exp+expOffset,expBit)); (* shifted exponent bits *)
|
||||
RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+lexp) (* insert new exponent *)
|
||||
END scale;
|
||||
|
||||
|
||||
PROCEDURE ulp*(x: REAL): REAL;
|
||||
(*
|
||||
The value of the call ulp(x) shall be the value of the corresponding
|
||||
real number type equal to a unit in the last place of `x', if such a
|
||||
value exists; otherwise an exception shall occur and may be raised.
|
||||
value exists; otherwise an exception shall occur and may be raised.
|
||||
*)
|
||||
BEGIN
|
||||
RETURN scale(ONE, exponent(x)-places+1)
|
||||
END ulp;
|
||||
|
||||
|
||||
PROCEDURE succ*(x: REAL): REAL;
|
||||
(*
|
||||
The value of the call succ(x) shall be the next value of the
|
||||
corresponding real number type greater than `x', if such a type
|
||||
exists; otherwise an exception shall occur and may be raised.
|
||||
*)
|
||||
*)
|
||||
BEGIN
|
||||
RETURN x+ulp(x)*sign(x)
|
||||
END succ;
|
||||
|
||||
|
||||
PROCEDURE pred*(x: REAL): REAL;
|
||||
(*
|
||||
The value of the call pred(x) shall be the next value of the
|
||||
|
|
@ -249,31 +256,31 @@ PROCEDURE pred*(x: REAL): REAL;
|
|||
BEGIN
|
||||
RETURN x-ulp(x)*sign(x)
|
||||
END pred;
|
||||
|
||||
|
||||
PROCEDURE intpart*(x: REAL): REAL;
|
||||
(*
|
||||
The value of the call intpart(x) shall be the integral part of `x'.
|
||||
For negative values, this shall be -intpart(abs(x)).
|
||||
For negative values, this shall be -intpart(abs(x)).
|
||||
*)
|
||||
VAR loBit: INTEGER;
|
||||
BEGIN
|
||||
loBit:=(hiBit+1)-exponent(x);
|
||||
IF loBit<=0 THEN RETURN x (* no fractional part *)
|
||||
ELSIF loBit<=hiBit+1 THEN
|
||||
ELSIF loBit<=hiBit+1 THEN
|
||||
RETURN S.VAL(REAL,S.VAL(SET,x)*{loBit..31}) (* integer part is extracted *)
|
||||
ELSE RETURN ZERO (* no whole part *)
|
||||
END
|
||||
END intpart;
|
||||
|
||||
|
||||
PROCEDURE fractpart*(x: REAL): REAL;
|
||||
(*
|
||||
(*
|
||||
The value of the call fractpart(x) shall be the fractional part of
|
||||
`x'. This satifies the relationship fractpart(x)+intpart(x)=x.
|
||||
*)
|
||||
BEGIN
|
||||
RETURN x-intpart(x)
|
||||
END fractpart;
|
||||
|
||||
|
||||
PROCEDURE trunc*(x: REAL; n: INTEGER): REAL;
|
||||
(*
|
||||
The value of the call trunc(x,n) shall be the value of the most
|
||||
|
|
@ -283,14 +290,14 @@ PROCEDURE trunc*(x: REAL; n: INTEGER): REAL;
|
|||
VAR loBit: INTEGER; mask: SET;
|
||||
BEGIN loBit:=places-n;
|
||||
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
|
||||
ELSIF loBit<=0 THEN RETURN x (* nothing was truncated *)
|
||||
ELSIF loBit<=0 THEN RETURN x (* nothing was truncated *)
|
||||
ELSE mask:={loBit..31}; (* truncation bit mask *)
|
||||
RETURN S.VAL(REAL,S.VAL(SET,x)*mask)
|
||||
END
|
||||
END trunc;
|
||||
|
||||
|
||||
PROCEDURE round*(x: REAL; n: INTEGER): REAL;
|
||||
(*
|
||||
(*
|
||||
The value of the call round(x,n) shall be the value of `x' rounded to
|
||||
the most significant `n' places. An exception shall occur and may be
|
||||
raised if such a value does not exist, or if `n' is less than or equal
|
||||
|
|
@ -299,7 +306,7 @@ PROCEDURE round*(x: REAL; n: INTEGER): REAL;
|
|||
VAR loBit: INTEGER; num, mask: SET; r: REAL;
|
||||
BEGIN loBit:=places-n;
|
||||
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
|
||||
ELSIF loBit<=0 THEN RETURN x (* nothing was rounded *)
|
||||
ELSIF loBit<=0 THEN RETURN x (* nothing was rounded *)
|
||||
ELSE mask:={loBit..31}; num:=S.VAL(SET,x); (* truncation bit mask and number as SET *)
|
||||
x:=S.VAL(REAL,num*mask); (* truncated result *)
|
||||
IF loBit-1 IN num THEN (* check if result should be rounded *)
|
||||
|
|
@ -311,7 +318,7 @@ BEGIN loBit:=places-n;
|
|||
END
|
||||
END
|
||||
END round;
|
||||
|
||||
|
||||
PROCEDURE synthesize*(expart: INTEGER; frapart: REAL): REAL;
|
||||
(*
|
||||
The value of the call synthesize(expart,frapart) shall be a value of
|
||||
|
|
@ -322,13 +329,14 @@ PROCEDURE synthesize*(expart: INTEGER; frapart: REAL): REAL;
|
|||
BEGIN
|
||||
RETURN scale(frapart, expart)
|
||||
END synthesize;
|
||||
*)
|
||||
|
||||
PROCEDURE setMode*(m: Modes);
|
||||
(*
|
||||
The call setMode(m) shall set status flags from the value of `m',
|
||||
appropriate to the underlying implementation of the corresponding real
|
||||
number type.
|
||||
|
||||
number type.
|
||||
|
||||
NOTES
|
||||
3 -- Many implementations of floating point provide options for
|
||||
setting flags within the system which control details of the handling
|
||||
|
|
@ -346,12 +354,12 @@ PROCEDURE setMode*(m: Modes);
|
|||
4 -- The effects of `setMode' on operation on values of the
|
||||
corresponding real number type in coroutines other than the calling
|
||||
coroutine is not defined. Implementations are not require to preserve
|
||||
the status flags (if any) with the coroutine state.
|
||||
the status flags (if any) with the coroutine state.
|
||||
*)
|
||||
BEGIN
|
||||
(* hardware dependent mode setting of coprocessor *)
|
||||
END setMode;
|
||||
|
||||
|
||||
PROCEDURE currentMode*(): Modes;
|
||||
(*
|
||||
The value of the call currentMode() shall be the current status flags
|
||||
|
|
@ -365,9 +373,9 @@ PROCEDURE currentMode*(): Modes;
|
|||
BEGIN
|
||||
RETURN {}
|
||||
END currentMode;
|
||||
|
||||
|
||||
PROCEDURE IsLowException*(): BOOLEAN;
|
||||
(*
|
||||
(*
|
||||
Returns TRUE if the current coroutine is in the exceptional execution state
|
||||
because of the raising of the LowReal exception; otherwise returns FALSE.
|
||||
*)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue