1(* 2 Title: Standard Basis Library: IEEEReal Structure. 3 Author: David Matthews 4 Copyright David Matthews 2000, 2005, 2018 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 20(* G&R 2004 status: updated. *) 21 22structure IEEEReal: IEEE_REAL = 23struct 24 exception Unordered 25 26 datatype real_order = LESS | EQUAL | GREATER | UNORDERED 27 28 datatype float_class 29 = NAN 30 | INF 31 | ZERO 32 | NORMAL 33 | SUBNORMAL 34 35 datatype rounding_mode 36 = TO_NEAREST 37 | TO_NEGINF 38 | TO_POSINF 39 | TO_ZERO 40 41 local 42 val setRoundCall: int -> int = RunCall.rtsCallFast1 "PolySetRoundingMode" 43 in 44 fun setRoundingMode (r: rounding_mode) : unit = 45 let 46 (* Although the datatype values are almost certainly integers it's 47 much safer to map them to known values here. *) 48 (* The Basis library documentation does not define what exception is 49 raised here in the event of an error. convReal in the Real 50 structure expects this to be Fail so will need to be changed 51 if any other exception is raised. *) 52 val rv = 53 case r of 54 TO_NEAREST => 0 55 | TO_NEGINF => 1 56 | TO_POSINF => 2 57 | TO_ZERO => 3 58 in 59 if setRoundCall rv < 0 60 then raise Fail "setRoundingMode failed" 61 else () 62 end 63 end; 64 65 local 66 val getRoundCall : unit -> int = RunCall.rtsCallFast1 "PolyGetRoundingMode" 67 in 68 fun getRoundingMode () = 69 case getRoundCall () of 70 0 => TO_NEAREST 71 | 1 => TO_NEGINF 72 | 2 => TO_POSINF 73 | 3 => TO_ZERO 74 | _ => raise Fail "getRoundingMode failed" (* No longer returned. *) 75 end 76 77 type decimal_approx = 78 { class : float_class, sign : bool, digits : int list, exp : int } 79 80 local 81 fun dodigits [] = "" 82 | dodigits (a::b) = Int.toString a ^ dodigits b 83 in 84 fun toString {class, sign=true, digits, exp} = (* Sign bit set *) 85 "~" ^ toString {class=class, sign=false, digits=digits, exp=exp} 86 | toString {class=NAN, ...} = "nan" 87 | toString {class=INF, ...} = "inf" 88 | toString {class=ZERO, ...} = "0.0" 89 | toString {digits, exp, ...} = (* NORMAL or SUBNORMAL *) 90 "0." ^ dodigits digits ^ 91 (if exp = 0 then "" else "E"^(Int.toString exp)) 92 end 93 94 95 fun 'a scan (getc: (char, 'a) StringCvt.reader) (src: 'a) : (decimal_approx *'a) option = 96 let 97 fun checkString (src, match: substring) = 98 (* Check the string matches and return the rest of the 99 input if it does. *) 100 case Substring.getc match of 101 NONE => (* Finished *) SOME src (* Return rest *) 102 | SOME (ch, rest) => 103 (case getc src of 104 NONE => NONE 105 | SOME (ch', src') => 106 if ch = Char.toUpper ch' 107 then checkString(src', rest) 108 else NONE 109 ) 110 111 (* Return a list of digits. *) 112 fun getdigits inp src = 113 case getc src of 114 NONE => (List.rev inp, src) 115 | SOME(ch, src') => 116 if ch >= #"0" andalso ch <= #"9" 117 then getdigits ((Char.ord ch - Char.ord #"0") :: inp) src' 118 else (List.rev inp, src) 119 120 (* Return the signed exponent. If this doesn't represent a 121 valid integer return NONE since we shouldn't take off the E. 122 Int.scan accepts and removes leading space but we don't allow 123 space here so return NONE if we find any. *) 124 fun getExponent src = 125 case getc src of 126 NONE => NONE 127 | SOME(ch, _) => 128 if Char.isSpace ch 129 then NONE 130 else Int.scan StringCvt.DEC getc src 131 132 fun readNumber sign (src: 'a): (decimal_approx *'a) option = 133 case getc src of 134 NONE => NONE 135 | SOME (ch, _) => 136 if ch >= #"0" andalso ch <= #"9" orelse ch = #"." 137 then (* Digits or decimal. *) 138 let 139 (* Get the digits before the decimal point (if any) *) 140 val (intPart, src2) = getdigits [] src 141 (* Get the digits after the decimal point. If there is a decimal 142 point with no digits after it we don't swallow the dp. *) 143 val (decimals, src3) = 144 case getc src2 of 145 SOME (#".", src3a) => 146 ( 147 case getdigits [] src3a of 148 ([], _) => ([], src2) 149 | (digs, s) => (digs, s) 150 ) 151 | _=> ([], src2) 152 (* Get the exponent, returning zero if it doesn't match. *) 153 val (exponent, src4) = 154 case getc src3 of 155 NONE => (0, src3) 156 | SOME (ch, src4a) => 157 if ch = #"e" orelse ch = #"E" 158 then ( 159 case getExponent src4a of 160 NONE => (0, src3) 161 | SOME x => x 162 ) 163 else (0, src3) 164 (* Trim leading zeros from the part before the decimal and 165 trailing zeros from the part after. *) 166 fun trimLeadingZeros [] = [] 167 | trimLeadingZeros (0 :: l) = trimLeadingZeros l 168 | trimLeadingZeros l = l 169 val trimTrailingZeros = List.rev o trimLeadingZeros o List.rev 170 val leading = trimLeadingZeros intPart 171 val trailing = trimTrailingZeros decimals 172 in 173 (* If both the leading and trailing parts are empty the number is zero, 174 except that if there were no digits at all we have a malformed number. *) 175 case (intPart, decimals, leading, trailing) of 176 ([], [], _, _) => NONE 177 | (_, _, [], []) => 178 SOME ({class=ZERO, sign=sign, digits=[], exp=0}, src4) 179 | _ => 180 SOME ({class=NORMAL, sign=sign, 181 digits=List.@(leading, trailing), 182 exp=exponent + List.length leading}, src4) 183 end 184 else ( (* Could be INFINITY, INF or NAN. Check INFINITY before INF. *) 185 case checkString (src, Substring.full "INFINITY") of 186 SOME src' => SOME ({class=INF, sign=sign, digits=[], exp=0}, src') 187 | NONE => ( 188 case checkString (src, Substring.full "INF") of 189 SOME src' => SOME ({class=INF, sign=sign, digits=[], exp=0}, src') 190 | NONE => ( 191 case checkString (src, Substring.full "NAN") of 192 SOME src' => SOME ({class=NAN, sign=sign, digits=[], exp=0}, src') 193 | NONE => NONE 194 ) 195 ) 196 ) 197 in 198 case getc src of 199 NONE => NONE 200 | SOME(ch, src') => 201 if Char.isSpace ch (* Skip white space. *) 202 then scan getc src' (* Recurse *) 203 else if ch = #"+" 204 then readNumber false src' (* Skip it *) 205 else if ch = #"-" orelse ch = #"~" 206 then readNumber true src' (* Skip it and ignore sign *) 207 else readNumber false src 208 end (* scan *) 209 210 fun fromString (s: string): decimal_approx option = StringCvt.scanString scan s 211 212end; 213