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