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
.
6 * MLton is released under a BSD
-style license
.
7 * See the file MLton
-LICENSE for details
.
10 structure IEEEReal
: IEEE_REAL_EXTRA
=
17 datatype real_order
= LESS | EQUAL | GREATER | UNORDERED
19 structure Prim
= PrimitiveFFI
.IEEEReal
21 datatype float_class
=
28 structure RoundingMode
=
36 fun fromInt (i
: C_Int
.int): t
=
38 open Prim
.RoundingMode
42 else if i
= FE_DOWNWARD
46 else if i
= FE_TOWARDZERO
48 else raise Fail
"IEEEReal.RoundingMode.fromInt"
51 fun toInt (m
: t
): C_Int
.int =
53 open Prim
.RoundingMode
56 TO_NEAREST
=> FE_TONEAREST
57 | TO_NEGINF
=> FE_DOWNWARD
58 | TO_POSINF
=> FE_UPWARD
59 | TO_ZERO
=> FE_TOWARDZERO
62 then raise Fail
"IEEEReal rounding mode not supported"
67 datatype rounding_mode
= datatype RoundingMode
.t
69 fun setRoundingMode (m
: rounding_mode
): unit
=
70 if Prim
.setRoundingMode (RoundingMode
.toInt m
) = 0
73 raise PosixError
.raiseSys PosixError
.inval
75 val getRoundingMode
= RoundingMode
.fromInt
o Prim
.getRoundingMode
77 fun withRoundingMode (m
: rounding_mode
, th
: unit
-> 'a
): 'a
=
79 val m
' = getRoundingMode ()
80 val _
= setRoundingMode m
82 val _
= setRoundingMode m
'
87 structure DecimalApprox
=
89 type t
= {class
: float_class
,
94 val inf
: t
= {class
= INF
,
99 val zero
: t
= {class
= ZERO
,
105 type decimal_approx
= DecimalApprox
.t
107 fun 'a scan
reader (state
: 'a
) =
109 val state
= StringCvt.skipWS reader state
110 fun readc (c
, state
, f
) =
113 |
SOME (c
', state
') =>
114 if c
= Char.toLower c
'
117 fun readString (s
, state
, failure
, success
) =
119 val n
= String.size s
120 fun loop (i
, state
) =
127 if Char.toLower c
= String.sub (s
, i
)
128 then loop (i
+ 1, state
)
133 fun charToDigit c
= Char.ord c
- Char.ord #
"0"
134 fun digitStar (ds
: int list
, state
) =
136 fun done () = (rev ds
, state
)
142 then digitStar (charToDigit c
:: ds
, state
)
145 fun digitPlus (state
, failure
, success
) =
150 then success (digitStar ([charToDigit c
], state
))
153 type exp
= {digits
: int list
, negate
: bool}
154 fun 'b
afterE (state
: 'a
,
156 success
: exp
* 'a
-> 'b
) : 'b
=
162 digitPlus (state
, failure
,
164 success ({digits
= ds
, negate
= true},
168 #
"+" => digitPlus (state
, failure
,
170 success ({digits
= ds
,
180 digitStar ([charToDigit c
], state
)
182 success ({digits
= ds
, negate
= false},
187 (* e
[+~
-]?
[0-9]+)?
*)
188 fun exp (state
: 'a
, failure
, success
) =
192 case Char.toLower c
of
193 #
"e" => afterE (state
, failure
, success
)
195 (* (\
.[0-9]+)(e
[+~
-]?
[0-9]+)?
*)
196 fun 'b
afterDot (state
: 'a
,
198 success
: int list
* exp
* 'a
-> 'b
) =
199 digitPlus (state
, failure
,
202 fn () => success (frac
,
203 {digits
= [], negate
= false},
205 fn (e
, state
) => success (frac
, e
, state
)))
206 fun stripLeadingZeros (ds
: int list
): int * int list
=
213 then loop (i
+ 1, ds
')
218 fun stripTrailingZeros ds
=
223 0 => rev (#
2 (stripLeadingZeros (rev ds
)))
225 fun done (whole
: int list
,
227 {digits
: int list
, negate
: bool},
230 val (_
, il
) = stripLeadingZeros whole
231 val fl
= stripTrailingZeros frac
234 | Overflow
of DecimalApprox
.t
238 List.foldl (fn (d
, n
) => n
* 10 + d
)
241 if negate
then Int.~ i
else i
243 handle General
.Overflow
=> NONE
) of
244 NONE
=> Overflow (if negate
245 then DecimalApprox
.zero
246 else DecimalApprox
.inf
)
252 [] => DecimalApprox
.zero
257 val (m
, fl
) = stripLeadingZeros fl
269 digits
= stripTrailingZeros (il @ fl
),
276 fun normal
' (c
, state
) =
277 case Char.toLower c
of
278 #
"i" => readc (#
"n", state
, fn state
=>
279 readc (#
"f", state
, fn state
=>
288 readString ("inity", state
,
292 | #
"n" => readc (#
"a", state
, fn state
=>
293 readc (#
"n", state
, fn state
=>
299 (* (([0-9]+(\
.[0-9]+)?
)|
(\
.[0-9]+))(e
[+~
-]?
[0-9]+)?
*)
300 | #
"." => afterDot (state
,
302 fn (frac
, exp
, state
) =>
303 done ([], frac
, exp
, state
))
307 (* ([0-9]+(\
.[0-9]+)?
)(e
[+~
-]?
[0-9]+)?
*)
310 digitStar ([charToDigit c
], state
)
311 fun no () = done (whole
, [],
312 {digits
= [], negate
= false},
318 case Char.toLower c
of
321 fn (frac
, e
, state
) =>
322 done (whole
, frac
, e
, state
))
326 done (whole
, [], e
, state
))
333 | SOME z
=> normal
' z
337 |
SOME ({class
, digits
, exp
, ...}, state
) =>
338 SOME ({class
= class
,
349 | #
"-" => negate state
350 | #
"+" => normal state
351 | _
=> normal
' (c
, state
)
354 fun fromString s
= StringCvt.scanString scan s
356 fun toString
{class
, sign
, digits
, exp
}: string =
358 fun digitStr () = implode (map
StringCvt.digitToChar digits
)
360 let val num
= "0." ^
digitStr()
363 else concat
[num
, "E", Int.toString exp
]
369 | SUBNORMAL
=> norm ()