| 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 |