swflib/cpool.ml

   1 open Base
   2 open AbcType
   3
   4 type namespace = [
   5   `Namespace of string
   6 | `PackageNamespace of string
   7 | `PackageInternalNamespace of string
   8 | `ProtectedNamespace of string
   9 | `ExplicitNamespace of string
  10 | `StaticProtectedNamespace of string
  11 | `PrivateNamespace of string ]
  12
  13 type namespace_set = namespace list
  14
  15 type multiname = [
  16   `QName of namespace * string
  17 | `Multiname of string * namespace_set
  18 ]
  19
  20 type entry = [
  21 | `Int of int
  22 | `UInt of int
  23 | `Double of float
  24 | `String of string
  25 | namespace
  26 | multiname
  27 ]
  28
  29 type t = {
  30   int: int RevList.t;
  31   uint: int RevList.t;
  32   double: float RevList.t;
  33   string: string RevList.t;
  34   namespace: namespace RevList.t;
  35   namespace_set: namespace_set RevList.t;
  36   multiname: multiname RevList.t;
  37 }
  38
  39 let empty =
  40   {int           = RevList.empty;
  41    uint          = RevList.empty;
  42    double        = RevList.empty;
  43    string        = RevList.empty;
  44    namespace     = RevList.empty;
  45    namespace_set = RevList.empty;
  46    multiname     = RevList.empty}
  47
  48 let ns_name =
  49   function
  50       `Namespace name
  51     | `PackageNamespace name
  52     | `PackageInternalNamespace name
  53     | `ProtectedNamespace name
  54     | `ExplicitNamespace name
  55     | `StaticProtectedNamespace name
  56     | `PrivateNamespace name ->
  57         name
  58
  59 let add x xs=
  60   if RevList.mem x xs then
  61     xs
  62   else
  63     RevList.add x xs
  64
  65 let add_list xs ys =
  66   RevList.add_list (List.filter (fun x -> not (RevList.mem x ys)) xs) ys
  67
  68 let add_namespace ns cpool =
  69   {cpool with
  70      string = cpool.string
  71       +> add (ns_name ns);
  72      namespace = add ns cpool.namespace }
  73
  74 let add_multiname name cpool =
  75   match name with
  76       `QName (ns,str) ->
  77         let cpool =
  78           {cpool with
  79              string    = cpool.string
  80               +> add str;
  81              multiname = add name cpool.multiname } in
  82           add_namespace ns cpool
  83     | `Multiname (str,ns_set) ->
  84         {cpool with
  85            string        = cpool.string
  86             +> add_list (List.map ns_name ns_set)
  87             +> add str;
  88            namespace     = add_list ns_set cpool.namespace;
  89            namespace_set = add ns_set cpool.namespace_set;
  90            multiname     = add name cpool.multiname }
  91
  92 let add cpool entry =
  93   match entry with
  94       `Int n ->
  95         { cpool with int= add n cpool.int }
  96     | `UInt n ->
  97         { cpool with uint= add n cpool.uint }
  98     | `String s ->
  99         { cpool with string = add s cpool.string }
 100     | `Double d ->
 101         { cpool with double = add d cpool.double }
 102     | #namespace as ns ->
 103         add_namespace ns cpool
 104     | #multiname as m ->
 105         add_multiname m cpool
 106
 107 (* conversion *)
 108 (*
 109   assumption:
 110   - list has only unique element
 111 *)
 112 let rindex x set =
 113   1 + RevList.index x set
 114
 115 let index cpool entry =
 116   match entry with
 117       `Int n ->
 118         rindex n cpool.int
 119     | `UInt n ->
 120         rindex n cpool.uint
 121     | `Double d ->
 122         rindex d cpool.double
 123     | `String s ->
 124         rindex s cpool.string
 125     | #namespace as ns ->
 126         rindex ns cpool.namespace
 127     | #multiname as m ->
 128         rindex m cpool.multiname
 129
 130 let of_namespace {string=string} (ns : namespace) =
 131   let i =
 132     rindex (ns_name ns) string in
 133     match ns with
 134         `Namespace _ ->
 135           Namespace i
 136       | `PackageNamespace _ ->
 137           PackageNamespace i
 138       | `PackageInternalNamespace _ ->
 139           PackageInternalNamespace i
 140       | `ProtectedNamespace _ ->
 141           ProtectedNamespace i
 142       | `ExplicitNamespace _ ->
 143           ExplicitNamespace i
 144       | `StaticProtectedNamespace _ ->
 145           StaticProtectedNamespace i
 146       | `PrivateNamespace _ ->
 147           PrivateNamespace i
 148
 149 let of_namespace_set {namespace=namespace} nss =
 150   List.map (fun ns -> rindex ns namespace) nss
 151
 152 let of_multiname {namespace=namespace; namespace_set=namespace_set; string=string} =
 153   function
 154       `QName (ns,s) ->
 155         QName (rindex ns namespace, rindex s string)
 156     | `Multiname (s,nss) ->
 157         Multiname (rindex s string,rindex nss namespace_set)
 158
 159 let to_abc cpool =
 160   { AbcType.int   =
 161       RevList.to_list cpool.int;
 162     uint          =
 163       RevList.to_list cpool.uint;
 164     double        =
 165       RevList.to_list cpool.double;
 166     string        =
 167       RevList.to_list cpool.string;
 168     namespace     =
 169       cpool.namespace
 170       +> RevList.to_list
 171       +> List.map (of_namespace cpool);
 172     namespace_set =
 173       cpool.namespace_set
 174       +> RevList.to_list
 175       +> List.map (of_namespace_set cpool);
 176     multiname     =
 177       cpool.multiname
 178       +> RevList.to_list
 179       +> List.map (of_multiname cpool)
 180   }
 181
 182 let add_list cpool xs =
 183   List.fold_left add cpool xs