Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2012 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 | structure IEEEReal: IEEE_REAL_EXTRA = | |
11 | struct | |
12 | val op + = Int.+ | |
13 | val op - = Int.- | |
14 | val op * = Int.* | |
15 | ||
16 | exception Unordered | |
17 | datatype real_order = LESS | EQUAL | GREATER | UNORDERED | |
18 | ||
19 | structure Prim = PrimitiveFFI.IEEEReal | |
20 | ||
21 | datatype float_class = | |
22 | INF | |
23 | | NAN | |
24 | | NORMAL | |
25 | | SUBNORMAL | |
26 | | ZERO | |
27 | ||
28 | structure RoundingMode = | |
29 | struct | |
30 | datatype t = | |
31 | TO_NEAREST | |
32 | | TO_NEGINF | |
33 | | TO_POSINF | |
34 | | TO_ZERO | |
35 | ||
36 | fun fromInt (i: C_Int.int): t = | |
37 | let | |
38 | open Prim.RoundingMode | |
39 | in | |
40 | if i = FE_TONEAREST | |
41 | then TO_NEAREST | |
42 | else if i = FE_DOWNWARD | |
43 | then TO_NEGINF | |
44 | else if i = FE_UPWARD | |
45 | then TO_POSINF | |
46 | else if i = FE_TOWARDZERO | |
47 | then TO_ZERO | |
48 | else raise Fail "IEEEReal.RoundingMode.fromInt" | |
49 | end | |
50 | ||
51 | fun toInt (m: t): C_Int.int = | |
52 | let | |
53 | open Prim.RoundingMode | |
54 | val i = | |
55 | case m of | |
56 | TO_NEAREST => FE_TONEAREST | |
57 | | TO_NEGINF => FE_DOWNWARD | |
58 | | TO_POSINF => FE_UPWARD | |
59 | | TO_ZERO => FE_TOWARDZERO | |
60 | in | |
61 | if i = FE_NOSUPPORT | |
62 | then raise Fail "IEEEReal rounding mode not supported" | |
63 | else i | |
64 | end | |
65 | end | |
66 | ||
67 | datatype rounding_mode = datatype RoundingMode.t | |
68 | ||
69 | fun setRoundingMode (m: rounding_mode): unit = | |
70 | if Prim.setRoundingMode (RoundingMode.toInt m) = 0 | |
71 | then () | |
72 | else | |
73 | raise PosixError.raiseSys PosixError.inval | |
74 | ||
75 | val getRoundingMode = RoundingMode.fromInt o Prim.getRoundingMode | |
76 | ||
77 | fun withRoundingMode (m: rounding_mode, th: unit -> 'a): 'a = | |
78 | let | |
79 | val m' = getRoundingMode () | |
80 | val _ = setRoundingMode m | |
81 | val res = th () | |
82 | val _ = setRoundingMode m' | |
83 | in | |
84 | res | |
85 | end | |
86 | ||
87 | structure DecimalApprox = | |
88 | struct | |
89 | type t = {class: float_class, | |
90 | digits: int list, | |
91 | exp: int, | |
92 | sign: bool} | |
93 | ||
94 | val inf: t = {class = INF, | |
95 | digits = [], | |
96 | exp = 0, | |
97 | sign = false} | |
98 | ||
99 | val zero: t = {class = ZERO, | |
100 | digits = [], | |
101 | exp = 0, | |
102 | sign = false} | |
103 | end | |
104 | ||
105 | type decimal_approx = DecimalApprox.t | |
106 | ||
107 | fun 'a scan reader (state: 'a) = | |
108 | let | |
109 | val state = StringCvt.skipWS reader state | |
110 | fun readc (c, state, f) = | |
111 | case reader state of | |
112 | NONE => NONE | |
113 | | SOME (c', state') => | |
114 | if c = Char.toLower c' | |
115 | then f state' | |
116 | else NONE | |
117 | fun readString (s, state, failure, success) = | |
118 | let | |
119 | val n = String.size s | |
120 | fun loop (i, state) = | |
121 | if i = n | |
122 | then success state | |
123 | else | |
124 | case reader state of | |
125 | NONE => failure () | |
126 | | SOME (c, state) => | |
127 | if Char.toLower c = String.sub (s, i) | |
128 | then loop (i + 1, state) | |
129 | else failure () | |
130 | in | |
131 | loop (0, state) | |
132 | end | |
133 | fun charToDigit c = Char.ord c - Char.ord #"0" | |
134 | fun digitStar (ds: int list, state) = | |
135 | let | |
136 | fun done () = (rev ds, state) | |
137 | in | |
138 | case reader state of | |
139 | NONE => done () | |
140 | | SOME (c, state) => | |
141 | if Char.isDigit c | |
142 | then digitStar (charToDigit c :: ds, state) | |
143 | else done () | |
144 | end | |
145 | fun digitPlus (state, failure, success) = | |
146 | case reader state of | |
147 | NONE => failure () | |
148 | | SOME (c, state) => | |
149 | if Char.isDigit c | |
150 | then success (digitStar ([charToDigit c], state)) | |
151 | else failure () | |
152 | (* [+~-]?[0-9]+ *) | |
153 | type exp = {digits: int list, negate: bool} | |
154 | fun 'b afterE (state: 'a, | |
155 | failure: unit -> 'b, | |
156 | success: exp * 'a -> 'b) : 'b = | |
157 | case reader state of | |
158 | NONE => failure () | |
159 | | SOME (c, state) => | |
160 | let | |
161 | fun neg () = | |
162 | digitPlus (state, failure, | |
163 | fn (ds, state) => | |
164 | success ({digits = ds, negate = true}, | |
165 | state)) | |
166 | in | |
167 | case c of | |
168 | #"+" => digitPlus (state, failure, | |
169 | fn (ds, state) => | |
170 | success ({digits = ds, | |
171 | negate = false}, | |
172 | state)) | |
173 | | #"~" => neg () | |
174 | | #"-" => neg () | |
175 | | _ => | |
176 | if Char.isDigit c | |
177 | then | |
178 | let | |
179 | val (ds, state) = | |
180 | digitStar ([charToDigit c], state) | |
181 | in | |
182 | success ({digits = ds, negate = false}, | |
183 | state) | |
184 | end | |
185 | else failure () | |
186 | end | |
187 | (* e[+~-]?[0-9]+)? *) | |
188 | fun exp (state: 'a, failure, success) = | |
189 | case reader state of | |
190 | NONE => failure () | |
191 | | SOME (c, state) => | |
192 | case Char.toLower c of | |
193 | #"e" => afterE (state, failure, success) | |
194 | | _ => failure () | |
195 | (* (\.[0-9]+)(e[+~-]?[0-9]+)? *) | |
196 | fun 'b afterDot (state: 'a, | |
197 | failure: unit -> 'b, | |
198 | success: int list * exp * 'a -> 'b) = | |
199 | digitPlus (state, failure, | |
200 | fn (frac, state) => | |
201 | exp (state, | |
202 | fn () => success (frac, | |
203 | {digits = [], negate = false}, | |
204 | state), | |
205 | fn (e, state) => success (frac, e, state))) | |
206 | fun stripLeadingZeros (ds: int list): int * int list = | |
207 | let | |
208 | fun loop (i, ds) = | |
209 | case ds of | |
210 | [] => (i, []) | |
211 | | d :: ds' => | |
212 | if d = 0 | |
213 | then loop (i + 1, ds') | |
214 | else (i, ds) | |
215 | in | |
216 | loop (0, ds) | |
217 | end | |
218 | fun stripTrailingZeros ds = | |
219 | case ds of | |
220 | [] => [] | |
221 | | _ => | |
222 | case List.last ds of | |
223 | 0 => rev (#2 (stripLeadingZeros (rev ds))) | |
224 | | _ => ds | |
225 | fun done (whole: int list, | |
226 | frac: int list, | |
227 | {digits: int list, negate: bool}, | |
228 | state: 'a) = | |
229 | let | |
230 | val (_, il) = stripLeadingZeros whole | |
231 | val fl = stripTrailingZeros frac | |
232 | datatype exp = | |
233 | Int of int | |
234 | | Overflow of DecimalApprox.t | |
235 | val exp = | |
236 | case (SOME (let | |
237 | val i = | |
238 | List.foldl (fn (d, n) => n * 10 + d) | |
239 | 0 digits | |
240 | in | |
241 | if negate then Int.~ i else i | |
242 | end) | |
243 | handle General.Overflow => NONE) of | |
244 | NONE => Overflow (if negate | |
245 | then DecimalApprox.zero | |
246 | else DecimalApprox.inf) | |
247 | | SOME i => Int i | |
248 | val da = | |
249 | case il of | |
250 | [] => | |
251 | (case fl of | |
252 | [] => DecimalApprox.zero | |
253 | | _ => | |
254 | case exp of | |
255 | Int e => | |
256 | let | |
257 | val (m, fl) = stripLeadingZeros fl | |
258 | in | |
259 | {class = NORMAL, | |
260 | digits = fl, | |
261 | exp = e - m, | |
262 | sign = false} | |
263 | end | |
264 | | Overflow da => da) | |
265 | | _ => | |
266 | case exp of | |
267 | Int e => | |
268 | {class = NORMAL, | |
269 | digits = stripTrailingZeros (il @ fl), | |
270 | exp = e + length il, | |
271 | sign = false} | |
272 | | Overflow da => da | |
273 | in | |
274 | SOME (da, state) | |
275 | end | |
276 | fun normal' (c, state) = | |
277 | case Char.toLower c of | |
278 | #"i" => readc (#"n", state, fn state => | |
279 | readc (#"f", state, fn state => | |
280 | let | |
281 | fun res state = | |
282 | SOME ({class = INF, | |
283 | digits = [], | |
284 | exp = 0, | |
285 | sign = false}, | |
286 | state) | |
287 | in | |
288 | readString ("inity", state, | |
289 | fn () => res state, | |
290 | res) | |
291 | end)) | |
292 | | #"n" => readc (#"a", state, fn state => | |
293 | readc (#"n", state, fn state => | |
294 | SOME ({class = NAN, | |
295 | digits = [], | |
296 | exp = 0, | |
297 | sign = false}, | |
298 | state))) | |
299 | (* (([0-9]+(\.[0-9]+)?)|(\.[0-9]+))(e[+~-]?[0-9]+)? *) | |
300 | | #"." => afterDot (state, | |
301 | fn () => NONE, | |
302 | fn (frac, exp, state) => | |
303 | done ([], frac, exp, state)) | |
304 | | _ => | |
305 | if Char.isDigit c | |
306 | then | |
307 | (* ([0-9]+(\.[0-9]+)?)(e[+~-]?[0-9]+)? *) | |
308 | let | |
309 | val (whole, state) = | |
310 | digitStar ([charToDigit c], state) | |
311 | fun no () = done (whole, [], | |
312 | {digits = [], negate = false}, | |
313 | state) | |
314 | in | |
315 | case reader state of | |
316 | NONE => no () | |
317 | | SOME (c, state) => | |
318 | case Char.toLower c of | |
319 | #"." => | |
320 | afterDot (state, no, | |
321 | fn (frac, e, state) => | |
322 | done (whole, frac, e, state)) | |
323 | | #"e" => | |
324 | afterE (state, no, | |
325 | fn (e, state) => | |
326 | done (whole, [], e, state)) | |
327 | | _ => no () | |
328 | end | |
329 | else NONE | |
330 | fun normal state = | |
331 | case reader state of | |
332 | NONE => NONE | |
333 | | SOME z => normal' z | |
334 | fun negate state = | |
335 | case normal state of | |
336 | NONE => NONE | |
337 | | SOME ({class, digits, exp, ...}, state) => | |
338 | SOME ({class = class, | |
339 | digits = digits, | |
340 | exp = exp, | |
341 | sign = true}, | |
342 | state) | |
343 | in | |
344 | case reader state of | |
345 | NONE => NONE | |
346 | | SOME (c, state) => | |
347 | case c of | |
348 | #"~" => negate state | |
349 | | #"-" => negate state | |
350 | | #"+" => normal state | |
351 | | _ => normal' (c, state) | |
352 | end | |
353 | ||
354 | fun fromString s = StringCvt.scanString scan s | |
355 | ||
356 | fun toString {class, sign, digits, exp}: string = | |
357 | let | |
358 | fun digitStr () = implode (map StringCvt.digitToChar digits) | |
359 | fun norm () = | |
360 | let val num = "0." ^ digitStr() | |
361 | in if exp = 0 | |
362 | then num | |
363 | else concat [num, "E", Int.toString exp] | |
364 | end | |
365 | val num = | |
366 | case class of | |
367 | ZERO => "0.0" | |
368 | | NORMAL => norm () | |
369 | | SUBNORMAL => norm () | |
370 | | INF => "inf" | |
371 | | NAN => "nan" | |
372 | in if sign | |
373 | then "~" ^ num | |
374 | else num | |
375 | end | |
376 | end |