Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2014,2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2007 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 | functor Const (S: CONST_STRUCTS): CONST = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | structure ConstType = ConstType (struct | |
16 | structure RealSize = RealX.RealSize | |
17 | structure WordSize = WordX.WordSize | |
18 | end) | |
19 | ||
20 | structure IntInfRep = | |
21 | struct | |
22 | structure WordSize = WordX.WordSize | |
23 | datatype t = Big of WordXVector.t | Small of WordX.t | |
24 | fun fromIntInf (i: IntInf.t) : t = | |
25 | let | |
26 | val sws = WordSize.smallIntInfWord () | |
27 | val sws' = WordSize.fromBits (Bits.- (WordSize.bits sws, Bits.one)) | |
28 | in | |
29 | if WordSize.isInRange (sws', i, {signed = true}) | |
30 | then Small (WordX.orb (WordX.one sws, | |
31 | WordX.lshift (WordX.fromIntInf (i, sws), WordX.one sws))) | |
32 | else let | |
33 | val bws = WordSize.bigIntInfWord () | |
34 | val bbws = Bits.toWord (WordSize.bits bws) | |
35 | val mask = IntInf.- (WordSize.cardinality bws, IntInf.one) | |
36 | fun loop (i, acc) = | |
37 | if IntInf.isZero i | |
38 | then Big (WordXVector.fromListRev ({elementSize = bws}, acc)) | |
39 | else let | |
40 | val quot = IntInf.~>> (i, bbws) | |
41 | val rem = IntInf.andb (i, mask) | |
42 | in | |
43 | loop (quot, (WordX.fromIntInf (rem, bws)) :: acc) | |
44 | end | |
45 | in | |
46 | loop (if IntInf.>= (i, IntInf.zero) | |
47 | then (i, [WordX.zero bws]) | |
48 | else (IntInf.~ i, [WordX.one bws])) | |
49 | end | |
50 | end | |
51 | fun smallToIntInf (w: WordX.t): IntInf.t option = | |
52 | let | |
53 | val sws = WordSize.smallIntInfWord () | |
54 | val one = WordX.one sws | |
55 | in | |
56 | if WordSize.equals (WordX.size w, sws) | |
57 | andalso WordX.isOne (WordX.andb (w, one)) | |
58 | then SOME (WordX.toIntInfX (WordX.rshift (w, one, {signed = true}))) | |
59 | else NONE | |
60 | end | |
61 | fun bigToIntInf (v: WordXVector.t): IntInf.t option = | |
62 | let | |
63 | val bws = WordSize.bigIntInfWord () | |
64 | val bbws = Bits.toWord (WordSize.bits bws) | |
65 | in | |
66 | if WordSize.equals (WordXVector.elementSize v, bws) | |
67 | andalso WordXVector.length v >= 2 | |
68 | then let | |
69 | val v0 = WordXVector.sub (v, 0) | |
70 | fun mag () = | |
71 | WordXVector.foldFrom | |
72 | (v, 1, IntInf.zero, fn (w, i) => | |
73 | IntInf.andb (IntInf.<< (i, bbws), WordX.toIntInf w)) | |
74 | in | |
75 | if WordX.isZero v0 | |
76 | then SOME (mag ()) | |
77 | else if WordX.isOne v0 | |
78 | then SOME (IntInf.~ (mag ())) | |
79 | else NONE | |
80 | end | |
81 | else NONE | |
82 | end | |
83 | end | |
84 | ||
85 | datatype t = | |
86 | IntInf of IntInf.t | |
87 | | Null | |
88 | | Real of RealX.t | |
89 | | Word of WordX.t | |
90 | | WordVector of WordXVector.t | |
91 | ||
92 | val intInf = IntInf | |
93 | val null = Null | |
94 | val real = Real | |
95 | val word = Word | |
96 | val wordVector = WordVector | |
97 | ||
98 | local | |
99 | fun make (s, deOpt : t -> 'a option) = | |
100 | let | |
101 | fun de (t: t): 'a = | |
102 | case deOpt t of | |
103 | SOME z => z | |
104 | | NONE => Error.bug ("Const.de" ^ s) | |
105 | val is: t -> bool = isSome o deOpt | |
106 | in | |
107 | (deOpt, de, is) | |
108 | end | |
109 | in | |
110 | val (deWordOpt,deWord,_) = make ("Word", fn Word ws => SOME ws | _ => NONE) | |
111 | end | |
112 | ||
113 | val string = wordVector o WordXVector.fromString | |
114 | ||
115 | fun layout c = | |
116 | case c of | |
117 | IntInf i => IntInf.layout i | |
118 | | Null => Layout.str "NULL" | |
119 | | Real r => RealX.layout r | |
120 | | Word w => WordX.layout w | |
121 | | WordVector v => WordXVector.layout v | |
122 | ||
123 | val toString = Layout.toString o layout | |
124 | ||
125 | fun hash (c: t): word = | |
126 | case c of | |
127 | IntInf i => IntInf.hash i | |
128 | | Null => 0wx0 | |
129 | | Real r => RealX.hash r | |
130 | | Word w => WordX.hash w | |
131 | | WordVector v => WordXVector.hash v | |
132 | ||
133 | fun equals (c, c') = | |
134 | case (c, c') of | |
135 | (IntInf i, IntInf i') => IntInf.equals (i, i') | |
136 | | (Null, Null) => true | |
137 | | (Real r, Real r') => RealX.equals (r, r') | |
138 | | (Word w, Word w') => WordX.equals (w, w') | |
139 | | (WordVector v, WordVector v') => WordXVector.equals (v, v') | |
140 | | _ => false | |
141 | ||
142 | val equals = Trace.trace2 ("Const.equals", layout, layout, Bool.layout) equals | |
143 | ||
144 | val lookup: ({default: string option, name: string} * ConstType.t -> t) ref = | |
145 | ref (fn _ => Error.bug "Const.lookup: not set") | |
146 | ||
147 | end |