Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/PervEnv/Basis/real-format.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/PervEnv/Basis/real-format.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 168 - (view) (download)

1 : monnier 89 (* real-format.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * Code for converting from real (IEEE 64-bit floating-point) to string.
6 :     * This ought to be replaced with David Gay's conversion algorithm.
7 :     *
8 :     *)
9 :    
10 :     structure RealFormat : sig
11 :    
12 :     val fmtReal : StringCvt.realfmt -> real -> string
13 :     (** The type should be:
14 :     val fmtReal : StringCvt.realfmt -> LargeReal.real -> string
15 :     **)
16 :    
17 :     end = struct
18 :     infix 4 == !=
19 :    
20 :     val op + = InlineT.Real64.+
21 :     val op - = InlineT.Real64.-
22 :     val op * = InlineT.Real64.*
23 :     val op / = InlineT.Real64./
24 :     val op ~ = InlineT.Real64.~
25 :     val op < = InlineT.Real64.<
26 :     val op > = InlineT.Real64.>
27 :     val op >= = InlineT.Real64.>=
28 :     val op == = InlineT.Real64.==
29 :     fun floor x = if x < 1073741824.0 andalso x >= ~1073741824.0
30 :     then Assembly.A.floor x
31 :     else raise General.Overflow
32 :     val real = InlineT.real
33 :    
34 :     val op ^ = String.^
35 :     val implode = String.implode
36 :     val concat = String.concat
37 :     val size = String.size
38 :    
39 :     structure I = InlineT.DfltInt
40 :     fun inc i = I.+(i, 1)
41 :     fun dec i = I.-(i, 1)
42 :     fun min (i, j) = if I.<(i, j) then i else j
43 :     fun max (i, j) = if I.>(i, j) then i else j
44 :    
45 :     val atoi = (NumFormat.fmtInt StringCvt.DEC) o InlineT.Int32.fromInt
46 :    
47 :     fun zeroLPad (s, wid) = StringCvt.padLeft #"0" wid s
48 :     fun zeroRPad (s, wid) = StringCvt.padRight #"0" wid s
49 :    
50 :     fun mkDigit d = InlineT.CharVector.sub("0123456789abcdef", d)
51 :    
52 :     (* decompose a non-zero real into a list of at most maxPrec significant digits
53 :     * (the first digit non-zero), and integer exponent. The return value
54 :     * (a::b::c..., exp)
55 :     * is produced from real argument
56 :     * a.bc... * (10 ^^ exp)
57 :     * If the list would consist of all 9's, the list consisting of 1 followed by
58 :     * all 0's is returned instead.
59 :     *)
60 :     val maxPrec = 15
61 :     fun decompose (f, e, precisionFn) = let
62 :     fun scaleUp (x, e) =
63 :     if (x < 1.0) then scaleUp(10.0*x, dec e) else (x, e)
64 :     fun scaleDn (x, e) =
65 :     if (x >= 10.0) then scaleDn(0.1*x, inc e) else (x, e)
66 : monnier 167 fun mkdigits (f, 0, odd) = ([], if f < 5.0 then 0
67 :     else if f > 5.0 then 1
68 :     else odd)
69 :     | mkdigits (f, i, _) = let
70 : monnier 89 val d = floor f
71 : monnier 167 val (digits, carry) = mkdigits (10.0 * (f - real d), dec i,
72 :     I.mod(d,2))
73 : monnier 89 val (digit, c) = (case (d, carry)
74 :     of (9, 1) => (0, 1)
75 :     | _ => (I.+(d, carry), 0)
76 :     (* end case *))
77 :     in
78 :     (digit::digits, c)
79 :     end
80 :     val (f, e) = if (f < 1.0)
81 :     then scaleUp (f, e)
82 :     else if (f >= 10.0)
83 :     then scaleDn (f, e)
84 :     else (f, e)
85 : monnier 167 val (digits, carry) = mkdigits(f, max(0, min(precisionFn e, maxPrec)),0)
86 : monnier 89 in
87 :     case carry
88 :     of 0 => (digits, e)
89 :     | _ => (1::digits, inc e)
90 :     (* end case *)
91 :     end
92 :    
93 :     fun realFFormat (r, prec) = let
94 :     fun pf e = I.+(e, inc prec)
95 :     fun rtoa (digits, e) = let
96 :     fun doFrac (_, 0, n, l) = PreString.revImplode(n, l)
97 :     | doFrac ([], p, n, l) = doFrac([], dec p, inc n, #"0"::l)
98 :     | doFrac (hd::tl, p, n, l) =
99 :     doFrac(tl, dec p, inc n, (mkDigit hd) :: l)
100 :     fun doWhole ([], e, n, l) = if I.>=(e, 0)
101 :     then doWhole ([], dec e, inc n, #"0" :: l)
102 :     else if prec = 0
103 :     then PreString.revImplode(n, l)
104 :     else doFrac ([], prec, inc n, #"." :: l)
105 :     | doWhole (arg as (hd::tl), e, n, l) = if I.>=(e, 0)
106 :     then doWhole(tl, dec e, inc n, (mkDigit hd) :: l)
107 :     else if prec = 0
108 :     then PreString.revImplode(n, l)
109 :     else doFrac(arg, prec, inc n, #"." :: l)
110 :     fun doZeros (_, 0, n, l) = PreString.revImplode(n, l)
111 :     | doZeros (1, p, n, l) = doFrac(digits, p, n, l)
112 :     | doZeros (e, p, n, l) = doZeros(dec e, dec p, inc n, #"0" :: l)
113 :     in
114 :     if I.>=(e, 0)
115 :     then doWhole(digits, e, 0, [])
116 :     else if (prec = 0)
117 :     then "0"
118 :     else doZeros (I.~ e, prec, 2, [#".", #"0"])
119 :     end
120 :     in
121 :     if I.<(prec, 0) then raise General.Size else ();
122 :     if (r < 0.0)
123 :     then {sign = "~", mantissa = rtoa(decompose(~r, 0, pf))}
124 :     else if (r > 0.0)
125 :     then {sign="", mantissa = rtoa(decompose(r, 0, pf))}
126 :     else if (prec = 0)
127 :     then {sign="", mantissa = "0"}
128 :     else {sign="", mantissa = zeroRPad("0.", I.+(prec, 2))}
129 :     end (* realFFormat *)
130 :    
131 :     fun realEFormat (r, prec) = let
132 :     fun pf _ = inc prec
133 :     fun rtoa (sign, (digits, e)) = let
134 :     fun mkRes (m, e) = {sign = sign, mantissa = m, exp = e}
135 :     fun doFrac (_, 0, l) = implode(List.rev l)
136 :     | doFrac ([], n, l) = zeroRPad(implode(List.rev l), n)
137 :     | doFrac (hd::tl, n, l) = doFrac (tl, dec n, (mkDigit hd) :: l)
138 :     in
139 :     if (prec = 0)
140 :     then mkRes(String.str(mkDigit(List.hd digits)), e)
141 :     else mkRes(
142 :     doFrac(List.tl digits, prec, [#".", mkDigit(List.hd digits)]), e)
143 :     end
144 :     in
145 :     if I.<(prec, 0) then raise General.Size else ();
146 :     if (r < 0.0)
147 :     then rtoa ("~", decompose(~r, 0, pf))
148 :     else if (r > 0.0)
149 :     then rtoa ("", decompose(r, 0, pf))
150 :     else if (prec = 0)
151 :     then {sign = "", mantissa = "0", exp = 0}
152 :     else {sign = "", mantissa = zeroRPad("0.", I.+(prec, 2)), exp = 0}
153 :     end (* realEFormat *)
154 :    
155 :     fun realGFormat (r, prec) = let
156 :     fun pf _ = prec
157 :     fun rtoa (sign, (digits, e)) = let
158 :     fun mkRes (w, f, e) = {sign = sign, whole = w, frac = f, exp = e}
159 :     fun doFrac [] = []
160 :     | doFrac (0::tl) = (case doFrac tl
161 :     of [] => []
162 :     | rest => #"0" :: rest
163 :     (* end case *))
164 :     | doFrac (hd::tl) = (mkDigit hd) :: (doFrac tl)
165 :     fun doWhole ([], e, wh) =
166 :     if I.>=(e, 0)
167 :     then doWhole([], dec e, #"0"::wh)
168 :     else mkRes(implode(List.rev wh), "", NONE)
169 :     | doWhole (arg as (hd::tl), e, wh) =
170 :     if I.>=(e, 0)
171 :     then doWhole(tl, dec e, (mkDigit hd)::wh)
172 :     else mkRes(implode(List.rev wh), implode(doFrac arg), NONE)
173 :     in
174 :     if I.<(e, ~4) orelse I.>=(e, prec)
175 :     then mkRes(
176 :     String.str(mkDigit(List.hd digits)),
177 :     implode(doFrac(List.tl digits)), SOME e)
178 :     else if I.>=(e, 0)
179 :     then doWhole(digits, e, [])
180 :     else let
181 :     val frac = implode(doFrac digits)
182 :     in
183 :     mkRes("0", zeroLPad(frac, I.+(size frac, I.-(~1, e))), NONE)
184 :     end
185 :     end
186 :     in
187 :     if I.<(prec, 1) then raise General.Size else ();
188 :     if (r < 0.0)
189 :     then rtoa("~", decompose(~r, 0, pf))
190 :     else if (r > 0.0)
191 :     then rtoa("", decompose(r, 0, pf))
192 :     else {sign="", whole="0", frac="", exp=NONE}
193 :     end (* realGFormat *)
194 :    
195 :     val infinity = let fun bigger x = let val y = x*x
196 :     in if y>x then bigger y else x
197 :     end
198 :     in bigger 100.0
199 :     end
200 :    
201 :     fun fmtInfNan x =
202 :     if x==infinity then "inf"
203 :     else if x == ~infinity then "~inf"
204 :     else "nan"
205 :    
206 :     (* convert a real number to a string of the form [~]d.dddE[~]dd, where
207 :     * the precision (number of fractional digits) is specified by the
208 :     * second argument.
209 :     *)
210 :     fun realToSciStr prec r =
211 :     if ~infinity < r andalso r < infinity
212 :     then let
213 :     val {sign, mantissa, exp} = realEFormat (r, prec)
214 :     in
215 : monnier 167 (* minimum size exponent string, no padding *)
216 : monnier 89 concat[sign, mantissa, "E", atoi exp]
217 :     end
218 :     else fmtInfNan r
219 :    
220 :     (* convert a real number to a string of the form [~]ddd.ddd, where
221 :     * the precision (number of fractional digits) is specified by the
222 :     * second argument.
223 :     *)
224 :     fun realToFixStr prec x =
225 :     if ~infinity < x andalso x < infinity
226 :     then let
227 :     val {sign, mantissa} = realFFormat (x, prec)
228 :     in
229 :     sign^mantissa
230 :     end
231 :     else fmtInfNan x
232 :    
233 :     fun realToGenStr prec r =
234 :     if ~infinity < r andalso r < infinity
235 :     then let
236 :     val {sign, whole, frac, exp} = realGFormat(r, prec)
237 :     val (frac,expStr) = (case exp
238 :     of NONE => if (frac = "")
239 :     then (".0", "")
240 :     else ("." ^ frac, "")
241 :     | (SOME e) => let
242 :     val expStr = if I.<(e, 0)
243 : monnier 167 then "E~" ^ zeroLPad(atoi(I.~ e), 2)
244 :     else "E" ^ zeroLPad(atoi e, 2)
245 : monnier 89 in
246 :     ((if (frac = "") then "" else ("." ^ frac)), expStr)
247 :     end
248 :     (* end case *))
249 :     in
250 :     concat[sign, whole, frac, expStr]
251 :     end
252 :     else fmtInfNan r
253 :    
254 :     fun fmtReal (StringCvt.SCI NONE) = realToSciStr 6
255 :     | fmtReal (StringCvt.SCI(SOME prec)) = realToSciStr prec
256 :     | fmtReal (StringCvt.FIX NONE) = realToFixStr 6
257 :     | fmtReal (StringCvt.FIX(SOME prec)) = realToFixStr prec
258 :     | fmtReal (StringCvt.GEN NONE) = realToGenStr 12
259 :     | fmtReal (StringCvt.GEN(SOME prec)) = realToGenStr prec
260 :    
261 :     end
262 :    
263 :     (*
264 : monnier 167 * $Log: real-format.sml,v $
265 :     * Revision 1.1.1.1 1998/04/08 18:40:04 george
266 :     * Version 110.5
267 :     *
268 : monnier 89 *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0