mlton/atoms/const.fun

   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