1(* 2 Title: Standard Basis Library: Real Signature and structure. 3 Author: David Matthews 4 Copyright David Matthews 2000, 2005, 2008, 2016-18 5 6 This library is free software; you can redistribute it and/or 7 modify it under the terms of the GNU Lesser General Public 8 License version 2.1 as published by the Free Software Foundation. 9 10 This library is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 Lesser General Public License for more details. 14 15 You should have received a copy of the GNU Lesser General Public 16 License along with this library; if not, write to the Free Software 17 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18*) 19 20structure Real: REAL = 21struct 22 open IEEEReal 23 val fromLargeInt: LargeInt.int -> real = Real.rtsCallFastI_R "PolyFloatArbitraryPrecision" 24 25 val fromInt: int -> real = 26 (* We have to select the appropriate conversion. This will be 27 reduced down to the appropriate function but has to be 28 type-correct whether int is arbitrary precision or fixed 29 precision. Hence the "o Large/FixedInt.fromInt". *) 30 if Bootstrap.intIsArbitraryPrecision 31 then fromLargeInt o LargeInt.fromInt 32 else Real.fromFixedInt o FixedInt.fromInt 33 34 (* These are needed because we don't yet have conversion from string 35 to real. They are filtered out by the signature. *) 36 val zero = fromInt 0 and one = fromInt 1 and four = fromInt 4 37 38 type real = real (* Pick up from globals. *) 39 40 structure Math: MATH = 41 struct 42 type real = real (* Pick up from globals. *) 43 val sqrt = Real.rtsCallFastR_R "PolyRealSqrt" 44 and sin = Real.rtsCallFastR_R "PolyRealSin" 45 and cos = Real.rtsCallFastR_R "PolyRealCos" 46 and atan = Real.rtsCallFastR_R "PolyRealArctan" 47 and exp = Real.rtsCallFastR_R "PolyRealExp" 48 and ln = Real.rtsCallFastR_R "PolyRealLog" 49 and tan = Real.rtsCallFastR_R "PolyRealTan" 50 and asin = Real.rtsCallFastR_R "PolyRealArcSin" 51 and acos = Real.rtsCallFastR_R "PolyRealArcCos" 52 and log10 = Real.rtsCallFastR_R "PolyRealLog10" 53 and sinh = Real.rtsCallFastR_R "PolyRealSinh" 54 and cosh = Real.rtsCallFastR_R "PolyRealCosh" 55 and tanh = Real.rtsCallFastR_R "PolyRealTanh" 56 57 val atan2 = Real.rtsCallFastRR_R "PolyRealAtan2" 58 val pow = Real.rtsCallFastRR_R "PolyRealPow" 59 60 (* Derived values. *) 61 val e = exp one 62 val pi = four * atan one 63 64 end; 65 66 67 infix 4 == != ?=; 68 69 val op == = Real.== 70 val op != : real * real -> bool = not o op == 71 72 local 73 (* The General call is now only used to get constants. *) 74 val doRealReal : int*unit->real = RunCall.rtsCallFull2 "PolyRealGeneral" 75 and doRealInt : int*unit->int = RunCall.rtsCallFull2 "PolyRealGeneral" 76 fun callReal n x = doRealReal(n, x) 77 and callRealToInt n x = doRealInt(n, x) 78 in 79 val radix : int = callRealToInt 11 () 80 val precision : int = callRealToInt 12 () 81 val maxFinite : real = callReal 13 () 82 val minNormalPos : real = callReal 14 () 83 val minPos: real = callReal 15 () 84 end 85 86 val posInf : real = one/zero; 87 val negInf : real = ~one/zero; 88 89 (* Real is LargeReal. *) 90 fun toLarge (x: real) : (*LargeReal.*)real =x 91 fun fromLarge (_ : IEEEReal.rounding_mode) (x: (*LargeReal.*)real): real = x 92 93 local 94 open Real 95 in 96 (* isNan can be defined in terms of unordered. *) 97 fun isNan x = unordered(x, x) 98 99 (* NAN values do not match and infinities when multiplied by 0 produce NAN. *) 100 fun isFinite x = x * zero == zero 101 102 val copySign : (real * real) -> real = Real.rtsCallFastRR_R "PolyRealCopySign" 103 104 (* Get the sign bit by copying the sign onto a finite value and then 105 testing. This works for non-finite values and zeros. *) 106 fun signBit r = copySign(one, r) < zero 107 108 (* If we assume that all functions produce normalised results where 109 possible, the only subnormal values will be those smaller than 110 minNormalPos. *) 111 fun isNormal x = isFinite x andalso abs x >= minNormalPos 112 113 fun class x = 114 if isFinite x then if x == zero then ZERO 115 else if abs x >= minNormalPos then NORMAL 116 else SUBNORMAL 117 else if isNan x then NAN 118 else (* not finite and not Nan *) INF 119 120 fun sign x = 121 if isNan x then raise General.Domain 122 else if x == zero then 0 else if x < zero then ~1 else 1 123 end 124 125 fun sameSign (x, y) = signBit x = signBit y 126 127 (* Returns the minimum. In the case where one is a NaN it returns the 128 other. In that case the comparison will be false. *) 129 fun min (a: real, b: real): real = if a < b orelse isNan b then a else b 130 (* Similarly for max. *) 131 fun max (a: real, b: real): real = if a > b orelse isNan b then a else b 132 133 fun checkFloat x = 134 if isFinite x then x 135 else if isNan x then raise General.Div else raise General.Overflow 136 137 local 138 val frExp: real -> int * real = RunCall.rtsCallFull1 "PolyRealFrexp" 139 val fromManAndExp: real*int -> real = Real.rtsCallFastRI_R "PolyRealLdexp" 140 141 open Real 142 in 143 fun toManExp r = 144 if not (isFinite r) orelse r == zero 145 (* Nan, infinities and +/-0 all return r in the mantissa. 146 We include 0 to preserve its sign. *) 147 then {man=r, exp=0} 148 else 149 let 150 val (exp, man) = frExp r 151 in 152 {man=man, exp=exp} 153 end 154 155 fun fromManExp {man, exp} = 156 if not (isFinite man) orelse man == zero 157 (* Nan, infinities and +/-0 in the mantissa all return 158 their argument. *) 159 then man 160 else if LibrarySupport.isShortInt exp 161 then fromManAndExp(man, exp) 162 else (* Long arbitrary precision *) 163 copySign(if Int.>(exp, 0) then posInf else zero, man) 164 end 165 166 (* Convert to integer. *) 167 local 168 (* The RTS function converts to at most a 64-bit value (even on 169 32-bits). That will convert all the bits of the mantissa 170 but if the exponent is large we may have to multiply by 171 some power of two. *) 172 val realToInt: real -> LargeInt.int = RunCall.rtsCallFull1 "PolyRealBoxedToLongInt" 173 (* These are defined to raise Domain rather than Overflow on Nans. *) 174 fun checkNan x = if isNan x then raise Domain else x 175 in 176 val realFloor = Real.rtsCallFastR_R "PolyRealFloor" 177 and realCeil = Real.rtsCallFastR_R "PolyRealCeil" 178 and realTrunc = Real.rtsCallFastR_R "PolyRealTrunc" 179 and realRound = Real.rtsCallFastR_R "PolyRealRound" 180 181 fun toArbitrary x = 182 if isNan x then raise General.Domain 183 else if not (isFinite x) then raise General.Overflow 184 else 185 let 186 val { man, exp } = toManExp x 187 in 188 if exp <= precision 189 then realToInt x 190 else IntInf.<< (realToInt(fromManExp{man=man, exp=precision}), Word.fromInt(exp - precision)) 191 end 192 193 fun toLargeInt IEEEReal.TO_NEGINF = toArbitrary o realFloor 194 | toLargeInt IEEEReal.TO_POSINF = toArbitrary o realCeil 195 | toLargeInt IEEEReal.TO_ZERO = toArbitrary o realTrunc 196 | toLargeInt IEEEReal.TO_NEAREST = toArbitrary o realRound 197 198 (* Conversions to FixedInt are put in by the compiler. If int is fixed we can 199 use them otherwise we use the long versions. 200 N.B. FixedInt.toInt is a no-op but is needed so this is type-correct when 201 int is arbitrary. *) 202 val floor = 203 if Bootstrap.intIsArbitraryPrecision 204 then LargeInt.toInt o toArbitrary o realFloor else FixedInt.toInt o Real.floorFix o checkNan 205 and ceil = 206 if Bootstrap.intIsArbitraryPrecision 207 then LargeInt.toInt o toArbitrary o realCeil else FixedInt.toInt o Real.ceilFix o checkNan 208 and trunc = 209 if Bootstrap.intIsArbitraryPrecision 210 then LargeInt.toInt o toArbitrary o realTrunc else FixedInt.toInt o Real.truncFix o checkNan 211 and round = 212 if Bootstrap.intIsArbitraryPrecision 213 then LargeInt.toInt o toArbitrary o realRound else FixedInt.toInt o Real.roundFix o checkNan 214 215 fun toInt IEEEReal.TO_NEGINF = floor 216 | toInt IEEEReal.TO_POSINF = ceil 217 | toInt IEEEReal.TO_ZERO = trunc 218 | toInt IEEEReal.TO_NEAREST = round 219 end; 220 221 local 222 val realConv: string->real = RunCall.rtsCallFull1 "PolyRealBoxedFromString" 223 224 val posNan = abs(zero / zero) 225 val negNan = ~posNan 226 in 227 fun fromDecimal { class = INF, sign=true, ...} = SOME negInf 228 | fromDecimal { class = INF, sign=false, ...} = SOME posInf 229 | fromDecimal { class = ZERO, sign=true, ...} = SOME (~ zero) 230 | fromDecimal { class = ZERO, sign=false, ...} = SOME zero 231 (* Generate signed Nans ignoring the digits and mantissa. There 232 was code here to set the mantissa but there's no reference to 233 that in the current version of the Basis library. *) 234 | fromDecimal { class = NAN, sign=true, ... } = SOME negNan 235 | fromDecimal { class = NAN, sign=false, ... } = SOME posNan 236 237 | fromDecimal { class = _ (* NORMAL or SUBNORMAL *), sign, digits, exp} = 238 (let 239 fun toChar x = 240 if x < 0 orelse x > 9 then raise General.Domain 241 else Char.chr (x + Char.ord #"0") 242 (* Turn the number into a string. *) 243 val str = "0." ^ String.implode(List.map toChar digits) ^"E" ^ 244 Int.toString exp 245 (* Convert it to a real using the RTS conversion function. 246 Change any Conversion exceptions into Domain. *) 247 val result = realConv str handle RunCall.Conversion _ => raise General.Domain 248 in 249 if sign then SOME (~result) else SOME result 250 end 251 handle General.Domain => NONE 252 ) 253 end 254 255 local 256 val dtoa: real*int*int -> string*int*int = RunCall.rtsCallFull3 "PolyRealBoxedToString" 257 open StringCvt 258 259 fun addZeros n = 260 if n <= 0 then "" else "0" ^ addZeros (n-1) 261 262 fun fixFmt ndigs r = 263 if isNan r then "nan" 264 else if not (isFinite r) 265 then if r < zero then "~inf" else "inf" 266 else 267 let 268 (* Try to get ndigs past the decimal point. *) 269 val (str, exp, sign) = dtoa(r, 3, ndigs) 270 val strLen = String.size str 271 (* If the exponents is negative or zero we need to put a zero 272 before the decimal point. If the exponent is positive and 273 less than the number of digits we can take that 274 many characters off, otherwise we have to pad with zeros. *) 275 val numb = 276 if exp <= 0 277 then (* Exponent is zero or negative - all significant digits are 278 after the decimal point. Put in any zeros before 279 the significant digits, then the significant digits 280 and then any trailing zeros. *) 281 if ndigs = 0 then "0" 282 else "0." ^ addZeros(~exp) ^ str ^ addZeros(ndigs-strLen+exp) 283 else if strLen <= exp 284 then (* Exponent is not less than the length of the string - 285 all significant digits are before the decimal point. Add 286 any extra zeros before the decimal point then zeros after it. *) 287 str ^ addZeros(exp-strLen) ^ 288 (if ndigs = 0 then "" else "." ^ addZeros ndigs) 289 else (* Significant digits straddle the decimal point - insert the 290 decimal point and add any trailing zeros. *) 291 String.substring(str, 0, exp) ^ "." ^ 292 String.substring(str, exp, strLen-exp) ^ 293 addZeros(ndigs-strLen+exp) 294 in 295 if sign <> 0 then "~" ^ numb else numb 296 end 297 298 fun sciFmt ndigs r = 299 if isNan r then "nan" 300 else if not (isFinite r) 301 then if r < zero then "~inf" else "inf" 302 else 303 let 304 (* Try to get ndigs+1 digits. 1 before the decimal point and ndigs after. *) 305 val (str, exp, sign) = dtoa(r, 2, ndigs+1) 306 val strLen = String.size str 307 fun addZeros n = 308 if n <= 0 then "" else "0" ^ addZeros (n-1) 309 val numb = 310 if strLen = 0 311 then "0" ^ (if ndigs = 0 then "" else "." ^ addZeros ndigs) ^ "E0" 312 else 313 (if strLen = 1 314 then str ^ (if ndigs = 0 then "" else "." ^ addZeros ndigs) 315 else String.substring(str, 0, 1) ^ "." ^ 316 String.substring(str, 1, strLen-1) ^ addZeros (ndigs-strLen+1) 317 ) ^ "E" ^ Int.toString (exp-1) 318 in 319 if sign <> 0 then "~" ^ numb else numb 320 end 321 322 fun genFmt ndigs r = 323 if isNan r then "nan" 324 else if not (isFinite r) 325 then if r < zero then "~inf" else "inf" 326 else 327 let 328 (* Try to get ndigs digits. *) 329 val (str, exp, sign) = dtoa(r, 2, ndigs) 330 val strLen = String.size str 331 val numb = 332 (* Have to use scientific notation if exp > ndigs. Also use it 333 if the exponent is small (TODO: adjust this) *) 334 if exp > ndigs orelse exp < ~5 335 then (* Scientific format *) 336 (if strLen = 1 then str 337 else String.substring(str, 0, 1) ^ "." ^ 338 String.substring(str, 1, strLen-1) 339 ) ^ "E" ^ Int.toString (exp-1) 340 341 else (* Fixed format (N.B. no trailing zeros are added after the 342 decimal point apart from one if necessary) *) 343 if exp <= 0 344 then (* Exponent is zero or negative - all significant digits are 345 after the decimal point. Put in any zeros before 346 the significant digits, then the significant digits 347 and then any trailing zeros. *) 348 "0." ^ addZeros(~exp) ^ str 349 else if strLen <= exp 350 then (* Exponent is not less than the length of the string - 351 all significant digits are before the decimal point. Add 352 any extra zeros before the decimal point. Insert .0 at the 353 end to make it a valid real number. *) 354 str ^ addZeros(exp-strLen) ^ ".0" 355 else (* Significant digits straddle the decimal point - insert the 356 decimal point. *) 357 String.substring(str, 0, exp) ^ "." ^ 358 String.substring(str, exp, strLen-exp) 359 in 360 if sign <> 0 then "~" ^ numb else numb 361 end 362 363 fun strToDigitList str = 364 let 365 fun getDigs i l = 366 if i < 0 then l 367 else getDigs (i-1) 368 ((Char.ord(String.sub(str, i)) - Char.ord #"0") :: l) 369 in 370 getDigs (String.size str - 1) [] 371 end 372 in 373 fun toDecimal r = 374 let 375 val sign = signBit r 376 val kind = class r 377 in 378 case kind of 379 ZERO => { class = ZERO, sign = sign, digits=[], exp = 0 } 380 | INF => { class = INF, sign = sign, digits=[], exp = 0 } 381 | NAN => { class = NAN, sign = sign, digits=[], exp = 0 } 382 | _ => (* NORMAL/SUBNORMAL *) 383 let 384 val (str, exp, sign) = dtoa(r, 0, 0) 385 val digits = strToDigitList str 386 in 387 { class = kind, sign = sign <> 0, digits = digits, exp = exp } 388 end 389 end 390 391 (* Note: The definition says, reasonably, that negative values 392 for the number of digits raises Size. The tests also check 393 for a very large value for the number of digits and seem to 394 expect Size to be raised in that case. Note that the exception 395 is raised when fmt spec is evaluated and before it is applied 396 to an actual real argument. 397 In all cases, even EXACT format, this should produce "nan" for a NaN 398 and ignore the sign bit. *) 399 fun fmt (SCI NONE) = sciFmt 6 400 | fmt (SCI (SOME d) ) = 401 if d < 0 orelse d > 200 then raise General.Size 402 else sciFmt d 403 | fmt (FIX NONE) = fixFmt 6 404 | fmt (FIX (SOME d) ) = 405 if d < 0 orelse d > 200 then raise General.Size 406 else fixFmt d 407 | fmt (GEN NONE) = genFmt 12 408 | fmt (GEN (SOME d) ) = 409 if d < 1 orelse d > 200 then raise General.Size 410 else genFmt d 411 | fmt EXACT = (fn r => if isNan r then "nan" else IEEEReal.toString(toDecimal r)) 412 413 val toString = fmt (GEN NONE) 414 end 415 416 417 fun scan getc src = 418 let 419 (* Return a list of digits. *) 420 fun getdigits inp src = 421 case getc src of 422 NONE => (List.rev inp, src) 423 | SOME(ch, src') => 424 if ch >= #"0" andalso ch <= #"9" 425 then getdigits ((Char.ord ch - Char.ord #"0") :: inp) src' 426 else (List.rev inp, src) 427 428 (* Read an unsigned integer. Returns NONE if no digits have been read. *) 429 fun getNumber sign digits acc src = 430 case getc src of 431 NONE => if digits = 0 then NONE else SOME(if sign then ~acc else acc, src) 432 | SOME(ch, src') => 433 if ch >= #"0" andalso ch <= #"9" 434 then getNumber sign (digits+1) (acc*10 + Char.ord ch - Char.ord #"0") src' 435 else if digits = 0 then NONE else SOME(if sign then ~acc else acc, src') 436 437 (* Return the signed exponent. *) 438 fun getExponent src = 439 case getc src of 440 NONE => NONE 441 | SOME(ch, src') => 442 if ch = #"+" 443 then getNumber false 0 0 src' 444 else if ch = #"-" orelse ch = #"~" 445 then getNumber true 0 0 src' 446 else getNumber false 0 0 src 447 448 fun read_number sign src = 449 case getc src of 450 NONE => NONE 451 | SOME(ch, _) => 452 if not (ch >= #"0" andalso ch <= #"9" orelse ch = #".") 453 then NONE (* Bad *) 454 else (* Digits or decimal. *) 455 let 456 (* Get the digits before the decimal point (if any) *) 457 val (intPart, srcAfterDigs) = getdigits [] src 458 (* Get the digits after the decimal point (if any). 459 If there is a decimal point we only accept it if 460 there is at least one digit after it. *) 461 val (decimals, srcAfterMant) = 462 case getc srcAfterDigs of 463 NONE => ([], srcAfterDigs) 464 | SOME (#".", srcAfterDP) => 465 ( (* Check that the next character is a digit. *) 466 case getc srcAfterDP of 467 NONE => ([], srcAfterDigs) 468 | SOME(ch, _) => 469 if ch >= #"0" andalso ch <= #"9" 470 then getdigits [] srcAfterDP 471 else ([], srcAfterDigs) 472 ) 473 | SOME (_, _) => ([], srcAfterDigs) 474 (* The exponent is optional. If it doesn't form a valid 475 exponent we return zero as the value and the 476 continuation is the beginning of the "exponent". *) 477 val (exponent, srcAfterExp) = 478 case getc srcAfterMant of 479 NONE => (0, srcAfterMant) 480 | SOME (ch, src'''') => 481 if ch = #"e" orelse ch = #"E" 482 then 483 ( 484 case getExponent src'''' of 485 NONE => (0, srcAfterMant) 486 | SOME x => x 487 ) 488 else (0, srcAfterMant) 489 (* Generate a decimal representation ready for conversion. 490 We don't bother to strip off leading or trailing zeros. *) 491 val decimalRep = {class=NORMAL, sign=sign, 492 digits=List.@(intPart, decimals), 493 exp=exponent + List.length intPart} 494 in 495 case fromDecimal decimalRep of 496 SOME r => SOME(r, srcAfterExp) 497 | NONE => NONE 498 end 499 in 500 case getc src of 501 NONE => NONE 502 | SOME(ch, src') => 503 if Char.isSpace ch (* Skip white space. *) 504 then scan getc src' (* Recurse *) 505 else if ch = #"+" (* Remove the + sign *) 506 then read_number false src' 507 else if ch = #"-" orelse ch = #"~" 508 then read_number true src' 509 else (* See if it's a valid digit. *) 510 read_number false src 511 end 512 513 val fromString = StringCvt.scanString scan 514 515 (* Converter to real values. This replaces the basic conversion 516 function for reals installed in the bootstrap process. 517 For more information see convInt in Int. *) 518 local 519 fun convReal (s: string) : real = 520 let 521 (* Set the rounding mode to TO_NEAREST whatever the current 522 rounding mode. Otherwise the result of compiling a piece of 523 code with a literal constant could depend on what the rounding 524 mode was set to. 525 We should always support TO_NEAREST. *) 526 val oldRounding = IEEEReal.getRoundingMode() 527 val () = IEEEReal.setRoundingMode IEEEReal.TO_NEAREST 528 val scanResult = StringCvt.scanString scan s 529 val () = IEEEReal.setRoundingMode oldRounding 530 in 531 case scanResult of 532 NONE => raise RunCall.Conversion "Invalid real constant" 533 | SOME res => res 534 end 535 in 536 (* Install this as a conversion function for real literals. *) 537 val (): unit = RunCall.addOverload convReal "convReal" 538 end 539 540 open Real (* Get the other definitions. *) 541 542 fun compare (r1, r2) = 543 if r1 == r2 then General.EQUAL 544 else if r1 < r2 then General.LESS 545 else if r1 > r2 then General.GREATER 546 else raise Unordered 547 548 fun compareReal (r1, r2) = 549 if r1 == r2 then EQUAL 550 else if r1 < r2 then LESS 551 else if r1 > r2 then GREATER 552 else UNORDERED 553 554 (* This seems to be similar to == except that where == always returns false 555 if either argument is a NaN this returns true. The implementation of == 556 treats the unordered case specially so it would be possible to implement 557 this in the same way. *) 558 fun op ?= (x, y) = unordered(x, y) orelse x == y 559 560 (* Although these may be built in in some architectures it's 561 probably not worth treating them specially at the moment. *) 562 fun *+ (x: real, y: real, z: real): real = x*y+z 563 and *- (x: real, y: real, z: real): real = x*y-z 564 565 val rem = Real.rtsCallFastRR_R "PolyRealRem" 566 567 (* Split a real into whole and fractional parts. The fractional part must have 568 the same sign as the number even if it is zero. *) 569 fun split r = 570 let 571 val whole = realTrunc r 572 val frac = r - whole 573 in 574 { whole = whole, 575 frac = 576 if not (isFinite r) 577 then if isNan r then r else (* Infinity *) if r < zero then ~zero else zero 578 else if frac == zero then if signBit r then ~zero else zero 579 else frac } 580 end 581 582 (* Get the fractional part of a real. *) 583 fun realMod r = #frac(split r) 584 585 (* nextAfter: This was previously implemented in ML but, at the very least, 586 needed to work with rounding to something other than TO_NEAREST. *) 587 val nextAfter = Real.rtsCallFastRR_R "PolyRealNextAfter" 588 589end; 590 591structure Math = Real.Math; 592 593structure LargeReal: REAL = Real; 594 595(* Values available unqualified at the top-level. *) 596val real : int -> real = Real.fromInt 597val trunc : real -> int = Real.trunc 598val floor : real -> int = Real.floor 599val ceil : real -> int = Real.ceil 600val round : real -> int =Real.round; 601 602(* Install print function. *) 603local 604 fun print_real _ _ (r: real) = 605 PolyML.PrettyString(Real.fmt (StringCvt.GEN(SOME 10)) r) 606in 607 val () = PolyML.addPrettyPrinter print_real; 608end; 609