| 1 | (* Copyright (C) 2009 Matthew Fluet. |
| 2 | * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
| 3 | * Jagannathan, and Stephen Weeks. |
| 4 | * Copyright (C) 1997-2000 NEC Research Institute. |
| 5 | * |
| 6 | * MLton is released under a BSD-style license. |
| 7 | * See the file MLton-LICENSE for details. |
| 8 | *) |
| 9 | |
| 10 | (* SML/NJ uses an old version of datatype IEEEReal.float_class. *) |
| 11 | signature REAL = |
| 12 | sig |
| 13 | type real |
| 14 | |
| 15 | structure Math: MATH where type real = real |
| 16 | |
| 17 | val != : real * real -> bool |
| 18 | val * : real * real -> real |
| 19 | val *+ : real * real * real -> real |
| 20 | val *- : real * real * real -> real |
| 21 | val + : real * real -> real |
| 22 | val - : real * real -> real |
| 23 | val / : real * real -> real |
| 24 | val < : real * real -> bool |
| 25 | val <= : real * real -> bool |
| 26 | val == : real * real -> bool |
| 27 | val > : real * real -> bool |
| 28 | val >= : real * real -> bool |
| 29 | val ?= : real * real -> bool |
| 30 | val abs: real -> real |
| 31 | val checkFloat: real -> real |
| 32 | val class: real -> IEEEReal.float_class |
| 33 | val compare: real * real -> order |
| 34 | val compareReal: real * real -> IEEEReal.real_order |
| 35 | val copySign: real * real -> real |
| 36 | val fmt: StringCvt.realfmt -> real -> string |
| 37 | val fromDecimal: IEEEReal.decimal_approx -> real option |
| 38 | val fromInt: int -> real |
| 39 | val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real |
| 40 | val fromLargeInt: LargeInt.int -> real |
| 41 | val fromManExp: {man: real, exp: int} -> real |
| 42 | val fromString: string -> real option |
| 43 | val isFinite: real -> bool |
| 44 | val isNan: real -> bool |
| 45 | val isNormal: real -> bool |
| 46 | val max: real * real -> real |
| 47 | val maxFinite: real |
| 48 | val min: real * real -> real |
| 49 | val minNormalPos: real |
| 50 | val minPos: real |
| 51 | val negInf: real |
| 52 | val nextAfter: real * real -> real |
| 53 | val posInf: real |
| 54 | val precision: int |
| 55 | val radix: int |
| 56 | val realCeil: real -> real |
| 57 | val realFloor: real -> real |
| 58 | val realMod: real -> real |
| 59 | val realRound: real -> real |
| 60 | val realTrunc: real -> real |
| 61 | val rem: real * real -> real |
| 62 | val round: real -> Int.int |
| 63 | val sameSign: real * real -> bool |
| 64 | val scan: (char, 'a) StringCvt.reader -> (real, 'a) StringCvt.reader |
| 65 | val sign: real -> int |
| 66 | val signBit: real -> bool |
| 67 | val split: real -> {whole: real, frac: real} |
| 68 | val toDecimal: real -> IEEEReal.decimal_approx |
| 69 | val toInt: IEEEReal.rounding_mode -> real -> int |
| 70 | val toLarge: real -> LargeReal.real |
| 71 | val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int |
| 72 | val toManExp: real -> {man: real, exp: int} |
| 73 | val toString: real -> string |
| 74 | val unordered: real * real -> bool |
| 75 | val ~ : real -> real |
| 76 | val ceil: real -> Int.int |
| 77 | val floor: real -> Int.int |
| 78 | val trunc: real -> Int.int |
| 79 | end |
| 80 | |
| 81 | functor FixReal(PReal: sig include PERVASIVE_REAL val zero : real end) : REAL = |
| 82 | struct |
| 83 | open PReal |
| 84 | |
| 85 | local |
| 86 | datatype z = datatype IEEEReal.float_class |
| 87 | structure P = Pervasive.IEEEReal |
| 88 | fun toGoodFC c = |
| 89 | case c of |
| 90 | P.NAN _ => NAN |
| 91 | | P.INF => INF |
| 92 | | P.ZERO => ZERO |
| 93 | | P.NORMAL => NORMAL |
| 94 | | P.SUBNORMAL => SUBNORMAL |
| 95 | fun toBadFC c = |
| 96 | case c of |
| 97 | NAN => P.NAN P.QUIET |
| 98 | | INF => P.INF |
| 99 | | ZERO => P.ZERO |
| 100 | | NORMAL => P.NORMAL |
| 101 | | SUBNORMAL => P.SUBNORMAL |
| 102 | fun toGoodDA {digits, exp, kind, sign} = |
| 103 | {digits = digits, exp = exp, kind = toGoodFC kind, sign = sign} |
| 104 | fun toBadDA {digits, exp, kind, sign} = |
| 105 | {digits = digits, exp = exp, kind = toBadFC kind, sign = sign} |
| 106 | in |
| 107 | val class = toGoodFC o class |
| 108 | val fromDecimal = SOME o fromDecimal o toBadDA |
| 109 | val toDecimal = toGoodDA o toDecimal |
| 110 | end |
| 111 | |
| 112 | (* SML/NJ doesn't support EXACT |
| 113 | * and doesn't include a leading "~" for ~0.0. |
| 114 | *) |
| 115 | fun fmt f = |
| 116 | let |
| 117 | val fmt = |
| 118 | PReal.fmt |
| 119 | (let |
| 120 | datatype z = datatype StringCvt.realfmt |
| 121 | in |
| 122 | case f of |
| 123 | EXACT => StringCvt.GEN NONE |
| 124 | | FIX io => StringCvt.FIX io |
| 125 | | GEN io => StringCvt.GEN io |
| 126 | | SCI io => StringCvt.SCI io |
| 127 | end) |
| 128 | in |
| 129 | fn r => |
| 130 | if == (zero, r) andalso signBit r |
| 131 | then "~" ^ (fmt r) |
| 132 | else fmt r |
| 133 | end |
| 134 | |
| 135 | (* SML/NJ doesn't handle "[+~-]?(inf|infinity|nan)" |
| 136 | * and raises Overflow on large exponents. |
| 137 | *) |
| 138 | fun fromString s = |
| 139 | case s of |
| 140 | "inf" => SOME posInf |
| 141 | | "infinity" => SOME posInf |
| 142 | | "+inf" => SOME posInf |
| 143 | | "+infinity" => SOME posInf |
| 144 | | "~inf" => SOME negInf |
| 145 | | "~infinity" => SOME negInf |
| 146 | | "-inf" => SOME negInf |
| 147 | | "-infinity" => SOME negInf |
| 148 | | "nan" => SOME (negInf + posInf) |
| 149 | | "+nan" => SOME (negInf + posInf) |
| 150 | | "~nan" => SOME (negInf + posInf) |
| 151 | | "-nan" => SOME (negInf + posInf) |
| 152 | | _ => |
| 153 | (case SOME (PReal.fromString s) handle Overflow => NONE of |
| 154 | NONE => |
| 155 | let |
| 156 | val manexp = |
| 157 | String.tokens |
| 158 | (fn c => c = #"e" orelse c = #"E") |
| 159 | s |
| 160 | fun isNeg s = |
| 161 | String.sub (s, 0) = #"~" |
| 162 | orelse String.sub (s, 0) = #"+" |
| 163 | fun isNonzero s = |
| 164 | CharVector.exists |
| 165 | (fn c => Char.<= (#"1", c) andalso Char.<= (c, #"9")) |
| 166 | s |
| 167 | in |
| 168 | case manexp of |
| 169 | [man,exp] => |
| 170 | if isNeg exp |
| 171 | then SOME zero |
| 172 | else if isNonzero man |
| 173 | then SOME posInf |
| 174 | else SOME zero |
| 175 | | _ => NONE |
| 176 | end |
| 177 | | SOME ro => ro) |
| 178 | end |
| 179 | |
| 180 | structure LargeReal = FixReal(struct open Pervasive.LargeReal val zero : real = 0.0 end) |
| 181 | structure Real = FixReal(struct open Pervasive.Real val zero : real = 0.0 end) |
| 182 | structure Real64 = FixReal(struct open Pervasive.Real64 val zero : real = 0.0 end) |
| 183 | structure Real32 = Real64 |
| 184 | |
| 185 | (* Dummy implementation that will not be used at run-time. *) |
| 186 | structure PackReal32Big : PACK_REAL where type real = Real32.real = struct |
| 187 | type real = Real32.real |
| 188 | val bytesPerElem = 0 |
| 189 | val isBigEndian = false |
| 190 | fun toBytes _ = raise Fail "PackReal32Big.toBytes" |
| 191 | fun fromBytes _ = raise Fail "PackReal32Big.fromBytes" |
| 192 | fun subVec _ = raise Fail "PackReal32Big.subVec" |
| 193 | fun subArr _ = raise Fail "PackReal32Big.subArr" |
| 194 | fun update _ = raise Fail "PackReal32Big.update" |
| 195 | end |
| 196 | (* Dummy implementation that will not be used at run-time. *) |
| 197 | structure PackReal32Little : PACK_REAL where type real = Real32.real = struct |
| 198 | type real = Real32.real |
| 199 | val bytesPerElem = 0 |
| 200 | val isBigEndian = false |
| 201 | fun toBytes _ = raise Fail "PackReal32Little.toBytes" |
| 202 | fun fromBytes _ = raise Fail "PackReal32Little.fromBytes" |
| 203 | fun subVec _ = raise Fail "PackReal32Little.subVec" |
| 204 | fun subArr _ = raise Fail "PackReal32Little.subArr" |
| 205 | fun update _ = raise Fail "PackReal32Little.update" |
| 206 | end |
| 207 | |
| 208 | (* Dummy implementation that will not be used at run-time. *) |
| 209 | structure PackReal64Big : PACK_REAL where type real = Real64.real = struct |
| 210 | type real = Real64.real |
| 211 | val bytesPerElem = 0 |
| 212 | val isBigEndian = false |
| 213 | fun toBytes _ = raise Fail "PackReal64Big.toBytes" |
| 214 | fun fromBytes _ = raise Fail "PackReal64Big.fromBytes" |
| 215 | fun subVec _ = raise Fail "PackReal64Big.subVec" |
| 216 | fun subArr _ = raise Fail "PackReal64Big.subArr" |
| 217 | fun update _ = raise Fail "PackReal64Big.update" |
| 218 | end |
| 219 | (* Dummy implementation that will not be used at run-time. *) |
| 220 | structure PackReal64Little : PACK_REAL where type real = Real64.real = struct |
| 221 | type real = Real64.real |
| 222 | val bytesPerElem = 0 |
| 223 | val isBigEndian = false |
| 224 | fun toBytes _ = raise Fail "PackReal64Little.toBytes" |
| 225 | fun fromBytes _ = raise Fail "PackReal64Little.fromBytes" |
| 226 | fun subVec _ = raise Fail "PackReal64Little.subVec" |
| 227 | fun subArr _ = raise Fail "PackReal64Little.subArr" |
| 228 | fun update _ = raise Fail "PackReal64Little.update" |
| 229 | end |