1(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. 2Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) 3 4MODULE ethReals; (** portable *) 5 6(** Implementation of the non-portable components of IEEE REAL and 7LONGREAL manipulation. The routines here are required to do conversion 8of reals to strings and back. 9Implemented by Bernd Moesli, Seminar for Applied Mathematics, 10Swiss Federal Institute of Technology Z�rich. 11*) 12 13IMPORT SYSTEM, Modules; 14 15(* Bernd Moesli 16 Seminar for Applied Mathematics 17 Swiss Federal Institute of Technology Zurich 18 Copyright 1993 19 20 Support module for IEEE floating-point numbers 21 22 Please change constant definitions of H, L depending on byte ordering 23 Use bm.TestReals.Do for testing the implementation. 24 25 Expo, ExpoL return the shifted binary exponent (0 <= e < 256 (2048 resp.)) 26 SetExpo, SetExpoL set the shifted binary exponent 27 Real, RealL convert hexadecimals to reals 28 Int, IntL convert reals to hexadecimals 29 Ten returns 10^e (e <= 308, 308 < e delivers NaN) 30 31 1993.4.22 IEEE format only, 32-bits LONGINTs only 32 30.8.1993 mh: changed RealX to avoid compiler warnings; 33 7.11.1995 jt: dynamic endianess test 34 22.01.97 pjm: NaN stuff (using quiet NaNs only to avoid traps) 35 05.01.98 prk: NaN with INF support 36 17.02.16 dcb: Adapt for 32 bit INTEGER and 64 bit LONGINT. 37*) 38 39VAR 40 DefaultFCR*: SET; 41 tene: ARRAY 23 OF LONGREAL; (* e = 0..22: exact values of 10^e *) 42 ten: ARRAY 27 OF LONGREAL; 43 eq, gr: ARRAY 20 OF SET; 44 H, L: INTEGER; 45 46(** Returns the shifted binary exponent (0 <= e < 256). *) 47PROCEDURE Expo* (x: REAL): LONGINT; 48BEGIN 49 IF SIZE(INTEGER) = 4 THEN 50 RETURN SHORT(ASH(SYSTEM.VAL(INTEGER, x), -23)) MOD 256 51 ELSIF SIZE(LONGINT) = 4 THEN 52 RETURN SHORT(ASH(SYSTEM.VAL(LONGINT, x), -23)) MOD 256 53 ELSE Modules.Halt(-15); 54 END 55END Expo; 56 57(** Returns the shifted binary exponent (0 <= e < 2048). *) 58PROCEDURE ExpoL* (x: LONGREAL): LONGINT; 59 VAR i: LONGINT; 60BEGIN 61 IF SIZE(LONGINT) = 8 THEN 62 RETURN ASH(SYSTEM.VAL(LONGINT, x), -50) MOD 256 63 ELSE 64 SYSTEM.GET(SYSTEM.ADR(x) + H, i); RETURN ASH(i, -20) MOD 2048 65 END 66END ExpoL; 67 68(** Sets the shifted binary exponent. *) 69PROCEDURE SetExpo* (e: INTEGER; VAR x: REAL); 70 VAR i: INTEGER; l: LONGINT; 71BEGIN 72 IF SIZE(LONGINT) = 4 THEN 73 SYSTEM.GET(SYSTEM.ADR(x), l); 74 l := ASH(ASH(ASH(l, -31), 8) + e MOD 256, 23) + l MOD ASH(1, 23); 75 SYSTEM.PUT(SYSTEM.ADR(x), l) 76 ELSIF SIZE(INTEGER) = 4 THEN 77 SYSTEM.GET(SYSTEM.ADR(x), i); 78 i := SHORT(ASH(ASH(ASH(i, -31), 8) + e MOD 256, 23) + i MOD ASH(1, 23)); 79 SYSTEM.PUT(SYSTEM.ADR(x), i) 80 ELSE Modules.Halt(-15) 81 END 82END SetExpo; 83 84(** Sets the shifted binary exponent. *) 85PROCEDURE SetExpoL* (e: LONGINT; VAR x: LONGREAL); 86 VAR i: INTEGER; l: LONGINT; 87BEGIN 88 IF SIZE(LONGINT) = 4 THEN 89 SYSTEM.GET(SYSTEM.ADR(x) + H, l); 90 l := ASH(ASH(ASH(l, -31), 11) + e MOD 2048, 20) + l MOD ASH(1, 20); 91 SYSTEM.PUT(SYSTEM.ADR(x) + H, l) 92 ELSIF SIZE(INTEGER) = 4 THEN 93 SYSTEM.GET(SYSTEM.ADR(x) + H, i); 94 i := SHORT(ASH(ASH(ASH(i, -31), 11) + e MOD 2048, 20) + i MOD ASH(1, 20)); 95 SYSTEM.PUT(SYSTEM.ADR(x) + H, i) 96 ELSE Modules.Halt(-15) 97 END 98END SetExpoL; 99 100(** Convert hexadecimal to REAL. *) 101PROCEDURE Real* (h: LONGINT): REAL; 102 VAR x: REAL; 103BEGIN 104 IF SIZE(LONGINT) = 4 THEN 105 SYSTEM.PUT(SYSTEM.ADR(x), h) 106 ELSIF SIZE(INTEGER) = 4 THEN 107 SYSTEM.PUT(SYSTEM.ADR(x), SYSTEM.VAL(INTEGER, h)) 108 ELSE Modules.Halt(-15) 109 END; 110 RETURN x 111END Real; 112 113(** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*) 114PROCEDURE RealL* (h, l: LONGINT): LONGREAL; 115 VAR x: LONGREAL; 116BEGIN 117 IF SIZE(LONGINT) = 4 THEN 118 SYSTEM.PUT(SYSTEM.ADR(x) + H, h); 119 SYSTEM.PUT(SYSTEM.ADR(x) + L, l) 120 ELSIF SIZE(INTEGER) = 4 THEN 121 SYSTEM.PUT(SYSTEM.ADR(x) + H, SYSTEM.VAL(INTEGER, h)); 122 SYSTEM.PUT(SYSTEM.ADR(x) + L, SYSTEM.VAL(INTEGER, l)) 123 ELSE Modules.Halt(-15) 124 END; 125 RETURN x 126END RealL; 127 128(** Convert REAL to hexadecimal. *) 129PROCEDURE Int* (x: REAL): LONGINT; 130 VAR i: INTEGER; l: LONGINT; 131BEGIN 132 IF SIZE(LONGINT) = 4 THEN 133 SYSTEM.PUT(SYSTEM.ADR(l), x); RETURN l 134 ELSIF SIZE(INTEGER) = 4 THEN 135 SYSTEM.PUT(SYSTEM.ADR(i), x); RETURN i 136 ELSE Modules.Halt(-15) 137 END 138END Int; 139 140(** Convert LONGREAL to hexadecimal. h and l are the high and low parts. *) 141PROCEDURE IntL* (x: LONGREAL; VAR h, l: LONGINT); 142 VAR i: INTEGER; 143BEGIN 144 IF SIZE(LONGINT) = 4 THEN 145 SYSTEM.GET(SYSTEM.ADR(x) + H, h); 146 SYSTEM.GET(SYSTEM.ADR(x) + L, l) 147 ELSIF SIZE(INTEGER) = 4 THEN 148 SYSTEM.GET(SYSTEM.ADR(x) + H, i); h := i; 149 SYSTEM.GET(SYSTEM.ADR(x) + L, i); l := i 150 ELSE Modules.Halt(-15) 151 END 152END IntL; 153 154(** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *) 155PROCEDURE Ten* (e: LONGINT): LONGREAL; 156 VAR E: LONGINT; r: LONGREAL; 157BEGIN 158 IF e < -307 THEN RETURN 0 ELSIF 308 < e THEN RETURN RealL(2146435072, 0) END; 159 INC(e, 307); r:= ten[e DIV 23] * tene[e MOD 23]; 160 IF e MOD 32 IN eq[e DIV 32] THEN RETURN r 161 ELSE 162 E:= ExpoL(r); SetExpoL(1023+52, r); 163 IF e MOD 32 IN gr[e DIV 32] THEN r:= r-1 ELSE r:= r+1 END; 164 SetExpoL(E, r); RETURN r 165 END 166END Ten; 167 168(** Returns the NaN code (0 <= c < 8399608) or -1 if not NaN/Infinite. *) 169PROCEDURE NaNCode* (x: REAL): LONGINT; 170 VAR e: LONGINT; 171BEGIN 172 IF Expo(x) = 255 THEN (* Infinite or NaN *) 173 RETURN SYSTEM.VAL(LONGINT, x) MOD 800000H (* lowest 23 bits *) 174 ELSE 175 RETURN -1 176 END 177END NaNCode; 178 179(** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *) 180PROCEDURE NaNCodeL* (x: LONGREAL; VAR h, l: LONGINT); 181BEGIN 182 IntL(x, h, l); 183 IF ASH(h, -20) MOD 2048 = 2047 THEN (* Infinite or NaN *) 184 h := h MOD 100000H (* lowest 20 bits *) 185 ELSE 186 h := -1; l := -1 187 END 188END NaNCodeL; 189 190(* 191PROCEDURE fcr(): SET; 192CODE {SYSTEM.i386, SYSTEM.FPU} 193 PUSH 0 194 FSTCW [ESP] 195 FWAIT 196 POP EAX 197END fcr; 198*) (* commented out -- noch *) 199(** Return state of the floating-point control register. *) 200(*PROCEDURE FCR*(): SET; 201BEGIN 202 IF Kernel.copro THEN 203 RETURN fcr() 204 ELSE 205 RETURN DefaultFCR 206 END 207END FCR; 208*) 209(*PROCEDURE setfcr(s: SET); 210CODE {SYSTEM.i386, SYSTEM.FPU} 211 FLDCW s[EBP] 212END setfcr; 213*) 214(** Set state of floating-point control register. Traps reset this to the default & ENTIER resets the rounding mode. *) 215(*PROCEDURE SetFCR*(s: SET); 216BEGIN 217 IF Kernel.copro THEN setfcr(s) END 218END SetFCR; 219*) 220 221 222PROCEDURE RealX (v: HUGEINT; VAR lr: LONGREAL); 223BEGIN lr := SYSTEM.VAL(LONGREAL, v) 224END RealX; 225 226BEGIN 227 RealX(03FF0000000000000H, tene[0]); 228 RealX(04024000000000000H, tene[1]); (* 1 *) 229 RealX(04059000000000000H, tene[2]); (* 2 *) 230 RealX(0408F400000000000H, tene[3]); (* 3 *) 231 RealX(040C3880000000000H, tene[4]); (* 4 *) 232 RealX(040F86A0000000000H, tene[5]); (* 5 *) 233 RealX(0412E848000000000H, tene[6]); (* 6 *) 234 RealX(0416312D000000000H, tene[7]); (* 7 *) 235 RealX(04197D78400000000H, tene[8]); (* 8 *) 236 RealX(041CDCD6500000000H, tene[9]); (* 9 *) 237 RealX(04202A05F20000000H, tene[10]); (* 10 *) 238 RealX(042374876E8000000H, tene[11]); (* 11 *) 239 RealX(0426D1A94A2000000H, tene[12]); (* 12 *) 240 RealX(042A2309CE5400000H, tene[13]); (* 13 *) 241 RealX(042D6BCC41E900000H, tene[14]); (* 14 *) 242 RealX(0430C6BF526340000H, tene[15]); (* 15 *) 243 RealX(04341C37937E08000H, tene[16]); (* 16 *) 244 RealX(04376345785D8A000H, tene[17]); (* 17 *) 245 RealX(043ABC16D674EC800H, tene[18]); (* 18 *) 246 RealX(043E158E460913D00H, tene[19]); (* 19 *) 247 RealX(04415AF1D78B58C40H, tene[20]); (* 20 *) 248 RealX(0444B1AE4D6E2EF50H, tene[21]); (* 21 *) 249 RealX(04480F0CF064DD592H, tene[22]); (* 22 *) 250 251 RealX(00031FA182C40C60DH, ten[0]); (* -307 *) 252 RealX(004F7CAD23DE82D7BH, ten[1]); (* -284 *) 253 RealX(009BF7D228322BAF5H, ten[2]); (* -261 *) 254 RealX(00E84D6695B193BF8H, ten[3]); (* -238 *) 255 RealX(0134B9408EEFEA839H, ten[4]); (* -215 *) 256 RealX(018123FF06EEA847AH, ten[5]); (* -192 *) 257 RealX(01CD8274291C6065BH, ten[6]); (* -169 *) 258 RealX(0219FF779FD329CB9H, ten[7]); (* -146 *) 259 RealX(02665275ED8D8F36CH, ten[8]); (* -123 *) 260 RealX(02B2BFF2EE48E0530H, ten[9]); (* -100 *) 261 RealX(02FF286D80EC190DCH, ten[10]); (* -77 *) 262 RealX(034B8851A0B548EA4H, ten[11]); (* -54 *) 263 RealX(0398039D665896880H, ten[12]); (* -31 *) 264 RealX(03E45798EE2308C3AH, ten[13]); (* -8 *) 265 RealX(0430C6BF526340000H, ten[14]); (* 15 *) 266 RealX(047D2CED32A16A1B1H, ten[15]); (* 38 *) 267 RealX(04C98E45E1DF3B015H, ten[16]); (* 61 *) 268 RealX(0516078E111C3556DH, ten[17]); (* 84 *) 269 RealX(05625CCFE3D35D80EH, ten[18]); (* 107 *) 270 RealX(05AECDA62055B2D9EH, ten[19]); (* 130 *) 271 RealX(05FB317E5EF3AB327H, ten[20]); (* 153 *) 272 RealX(0647945145230B378H, ten[21]); (* 176 *) 273 RealX(06940B8E0ACAC4EAFH, ten[22]); (* 199 *) 274 RealX(06E0621B1C28AC20CH, ten[23]); (* 222 *) 275 RealX(072CD4A7BEBFA31ABH, ten[24]); (* 245 *) 276 RealX(0779362149CBD3226H, ten[25]); (* 268 *) 277 RealX(07C59A742461887F6H, ten[26]); (* 291 *) 278 279 eq[0]:= {0, 3, 4, 5, 9, 16, 23, 25, 26, 28, 31}; 280 eq[1]:= {2, 5, 6, 8, 9, 10, 11, 12, 13, 14, 15, 17, 18, 19, 20, 21, 23, 24, 25, 27, 28, 29, 30, 31}; 281 eq[2]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28}; 282 eq[3]:= {0, 1, 2, 3, 5, 6, 7, 8, 9, 11, 14, 15, 16, 17, 18, 19, 20, 22, 27, 28, 29, 30, 31}; 283 eq[4]:= {0, 6, 7, 10, 11, 12, 13, 14, 15, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; 284 eq[5]:= {0, 1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; 285 eq[6]:= {0, 1, 4, 5, 7, 8, 10, 14, 15, 16, 18, 20, 21, 23, 24, 25, 26, 28, 29, 30, 31}; 286 eq[7]:= {0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 18, 19, 23, 24, 26, 28, 29, 30, 31}; 287 eq[8]:= {0, 1, 2, 3, 4, 5, 6, 8, 9, 10, 11, 14, 16, 17, 18, 19, 20, 21, 24, 25, 26, 29}; 288 eq[9]:= {1, 2, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; 289 eq[10]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30}; 290 eq[11]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 13, 14, 15, 16, 19, 20, 21, 22, 23, 27, 28, 29, 30}; 291 eq[12]:= {0, 1, 2, 3, 4, 5, 7, 8, 9, 10, 12, 14, 15, 16, 17, 18, 19, 20, 21, 23, 26, 27, 29, 30, 31}; 292 eq[13]:= {0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 13, 14, 15, 16, 17, 18, 20, 21, 23, 24, 27, 28, 29, 30, 31}; 293 eq[14]:= {0, 1, 2, 3, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31}; 294 eq[15]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 28}; 295 eq[16]:= {1, 2, 4, 11, 13, 16, 17, 18, 19, 22, 24, 25, 26, 27, 28, 29, 30, 31}; 296 eq[17]:= {1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 14, 15, 18, 19, 20, 21, 23, 25, 26, 27, 28, 29, 31}; 297 eq[18]:= {0, 2, 4, 5, 6, 8, 9, 11, 12, 13, 14, 16, 17, 19, 20, 22, 23, 24, 26, 27, 28, 29}; 298 eq[19]:= {2, 3, 4, 5, 6, 7}; 299 300 gr[0]:= {24, 27, 29, 30}; 301 gr[1]:= {0, 1, 3, 4, 7}; 302 gr[2]:= {29, 30, 31}; 303 gr[3]:= {4, 10, 12, 13, 21, 23, 24, 25, 26}; 304 gr[4]:= {1, 2, 3, 4, 5, 8, 9, 16, 17}; 305 gr[5]:= {2, 3, 4, 18}; 306 gr[6]:= {2, 3, 6, 9, 11, 12, 13, 17, 19, 22, 27}; 307 gr[7]:= {2}; 308 gr[8]:= {7, 12, 13, 15, 22, 23, 27, 28, 30, 31}; 309 gr[9]:= {0, 3, 5, 7, 8}; 310 gr[10]:= {}; 311 gr[11]:= {}; 312 gr[12]:= {11, 13, 22, 24, 25, 28}; 313 gr[13]:= {22, 25, 26}; 314 gr[14]:= {4, 5}; 315 gr[15]:= {10, 14, 27, 29, 30, 31}; 316 gr[16]:= {0, 3, 5, 6, 7, 8, 9, 10, 12, 14, 15, 20, 21, 23}; 317 gr[17]:= {0, 10, 12, 13, 16, 17, 22, 24, 30}; 318 gr[18]:= {}; 319 gr[19]:= {} 320END ethReals. 321