1(*
2    Title:      Rebuild the basis library: Real and StringCvt
3    Copyright   David C.J. Matthews 2016
4
5    This library is free software; you can redistribute it and/or
6    modify it under the terms of the GNU Lesser General Public
7    License version 2.1 as published by the Free Software Foundation.
8    
9    This library is distributed in the hope that it will be useful,
10    but WITHOUT ANY WARRANTY; without even the implied warranty of
11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12    Lesser General Public License for more details.
13    
14    You should have received a copy of the GNU Lesser General Public
15    License along with this library; if not, write to the Free Software
16    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
17*)
18
19(* Real *)
20useBasis "IEEE_REAL.sml";
21structure IEEEReal: IEEE_REAL =
22struct
23    open IEEEReal
24    type decimal_approx =
25        { class : float_class, sign : bool, digits : int list, exp : int }
26    
27    local
28        fun toNewDA {class, sign, digits, exp } : decimal_approx =
29            {class=class, sign=sign, digits = map FixedInt.toLarge digits, exp = FixedInt.toLarge exp }
30        and fromNewDA ({class, sign, digits, exp } : decimal_approx) =
31            {class=class, sign=sign, digits = map FixedInt.fromLarge digits, exp = FixedInt.fromLarge exp }
32    in
33        val toString = toString o fromNewDA 
34        val scan = fn getc => fn src => Option.map(fn (v, c) => (toNewDA v, c)) (scan getc src)
35        and fromString = (Option.map toNewDA) o fromString
36    end
37end;
38
39(* There's a complication.  We need access to both the old and new versions of
40   the StringCvt.realfmt datatype. *)
41local
42    structure OldStringCvt = StringCvt
43in
44    structure StringCvt: STRING_CVT =
45    struct
46        open StringCvt
47
48        datatype realfmt
49          = SCI of int option
50          | FIX of int option
51          | GEN of int option
52          | EXACT
53
54        val padRight = fn c => fn i => padRight c (FixedInt.fromInt i)
55        and padLeft  = fn c => fn i => padLeft c (FixedInt.fromInt i)
56    end;
57
58    structure Real =
59    struct
60        open Real
61        val radix = FixedInt.toLarge radix
62        val precision = FixedInt.toLarge precision
63        val sign = FixedInt.toLarge o sign
64        val toManExp = fn r => let val {man, exp} = toManExp r in {man=man, exp= FixedInt.toLarge exp} end
65        and fromManExp = fn {man, exp} => fromManExp{man=man, exp=FixedInt.fromLarge exp }
66        val toInt = toLargeInt
67        and fromInt = fromLargeInt
68
69        val floor = toLargeInt IEEEReal.TO_NEGINF
70        and ceil = toLargeInt IEEEReal.TO_POSINF
71        and trunc = toLargeInt IEEEReal.TO_ZERO
72        and round = toLargeInt IEEEReal.TO_NEAREST
73
74        val toDecimal =
75            fn r =>
76                let
77                    val {class, sign, digits, exp } = toDecimal r
78                in
79                    {class=class, sign=sign, digits = map FixedInt.toLarge digits, exp = FixedInt.toLarge exp }
80                end
81    
82        val fromDecimal =
83            fn {class, sign, digits, exp } =>
84                fromDecimal {class=class, sign=sign, digits = map FixedInt.fromLarge digits, exp = FixedInt.fromLarge exp }
85
86        local
87            fun rfmt (StringCvt.SCI(SOME s)) r = fmt (OldStringCvt.SCI(SOME(FixedInt.fromLarge s))) r
88            |   rfmt (StringCvt.SCI NONE) r = fmt (OldStringCvt.SCI NONE) r
89            |   rfmt (StringCvt.FIX(SOME s)) r = fmt (OldStringCvt.FIX(SOME(FixedInt.fromLarge s))) r
90            |   rfmt (StringCvt.FIX NONE) r = fmt (OldStringCvt.FIX NONE) r
91            |   rfmt (StringCvt.GEN(SOME s)) r = fmt (OldStringCvt.GEN(SOME(FixedInt.fromLarge s))) r
92            |   rfmt (StringCvt.GEN NONE) r = fmt (OldStringCvt.GEN NONE) r
93            |   rfmt StringCvt.EXACT r = fmt OldStringCvt.EXACT r
94        in
95            val fmt = rfmt
96        end
97    end
98end;
99
100useBasis "RealSignature.sml"; (* This uses IEEEReal and the new StringCvt and decimal_approx *)
101structure Real: REAL = Real;
102structure LargeReal = Real;
103
104val real : int -> real = Real.fromInt 
105val trunc : real -> int = Real.trunc 
106val floor : real -> int = Real.floor 
107val ceil : real -> int = Real.ceil 
108val round : real -> int =Real.round;
109