link/link.ml

   1 open Base
   2 open Swflib.AbcType
   3
   4 let reloc ctx f xs =
   5   List.map (f ctx) xs
   6
   7 let link f ctx x y =
   8   x @ reloc ctx f y
   9
  10 (* cpool *)
  11 let reloc_ns ctx ns =
  12   let n =
  13     ctx#str in
  14     match ns with
  15         Namespace name ->
  16           Namespace (name + n)
  17       | PackageNamespace name ->
  18           PackageNamespace (name + n)
  19       | PackageInternalNamespace name ->
  20           PackageInternalNamespace (name + n)
  21       | ProtectedNamespace name ->
  22           ProtectedNamespace (name + n)
  23       | ExplicitNamespace name ->
  24           ExplicitNamespace (name + n)
  25       | StaticProtectedNamespace name ->
  26           StaticProtectedNamespace (name + n)
  27       | PrivateNamespace name ->
  28           PrivateNamespace (name + n)
  29
  30 let reloc_nss ctx =
  31   List.map (fun ns-> ns + ctx#ns)
  32
  33 let reloc_multi ctx = function
  34     QName (ns, name) ->
  35       QName (ns + ctx#ns, name + ctx#str)
  36   | QNameA (ns, name) ->
  37       QNameA (ns + ctx#ns, name + ctx#str)
  38   | RTQName name ->
  39       RTQName (name + ctx#str)
  40   | RTQNameA name ->
  41       RTQNameA (name + ctx#str)
  42   | RTQNameL | RTQNameLA as n ->
  43       n
  44   | Multiname (name, nss) ->
  45       Multiname (name + ctx#str, nss + ctx#nss)
  46   | MultinameA (name, nss) ->
  47       MultinameA (name + ctx#str, nss + ctx#nss)
  48   | MultinameL name ->
  49       MultinameL (name + ctx#str)
  50   | MultinameLA name ->
  51       MultinameLA (name + ctx#str)
  52
  53 let link_cpool c1 c2 =
  54   let ctx = {|
  55       str = List.length c1.string;
  56       ns  = List.length c1.namespace;
  57       nss =List.length c1.namespace_set
  58   |} in {
  59       int           = c1.int           @ c2.int;
  60       uint          = c1.uint          @ c2.uint;
  61       double        = c1.double        @ c2.double;
  62       string        = c1.string        @ c2.string;
  63       namespace     = link reloc_ns    ctx c1.namespace     c2.namespace;
  64       namespace_set = link reloc_nss   ctx c1.namespace_set c2.namespace_set;
  65       multiname     = link reloc_multi ctx c1.multiname     c2.multiname;
  66     }
  67
  68 let reloc_name ctx name =
  69   if name = 0 then
  70     0
  71   else
  72     name + ctx#cpool#multiname
  73
  74 (* trait *)
  75 let reloc_trait_data ctx = function
  76     SlotTrait (id,name,vindex,vkind) ->
  77       SlotTrait (id, reloc_name ctx name, vindex, vkind)
  78   | ConstTrait (id,name,vindex,vkind) ->
  79       ConstTrait (id, reloc_name ctx name, vindex, vkind)
  80   | ClassTrait (id, classi) ->
  81       ClassTrait (id, classi + ctx#classes)
  82   | MethodTrait (id, methodi,attrs) ->
  83       MethodTrait (id, methodi + ctx#methods,attrs)
  84   | SetterTrait (id, methodi,attrs) ->
  85       SetterTrait (id, methodi + ctx#methods,attrs)
  86   | GetterTrait (id, methodi,attrs) ->
  87       GetterTrait (id, methodi + ctx#methods,attrs)
  88   | FunctionTrait (id, funi) ->
  89       FunctionTrait (id, funi+ctx#methods)
  90
  91 let reloc_traits ctx =
  92   reloc ctx begin fun ctx t -> {
  93     t with
  94       trait_name = reloc_name ctx t.trait_name;
  95       data = reloc_trait_data ctx t.data
  96   } end
  97
  98
  99 (* method *)
 100 let reloc_code ctx : Swflib.LowInst.t -> Swflib.LowInst.t = function
 101     `PushString i ->
 102       `PushString (i + ctx#cpool#string)
 103   | `PushInt i ->
 104       `PushInt (i + ctx#cpool#int)
 105   | `PushUInt i ->
 106       `PushUInt (i + ctx#cpool#uint)
 107   | `PushDouble i ->
 108       `PushDouble (i + ctx#cpool#double)
 109   | `GetLex i ->
 110       `GetLex (reloc_name ctx i)
 111   | `GetProperty i ->
 112       `GetProperty (reloc_name ctx i)
 113   | `SetProperty  i ->
 114       `SetProperty (reloc_name ctx i)
 115   | `InitProperty i ->
 116       `InitProperty (reloc_name ctx i)
 117   | `FindPropStrict i ->
 118       `FindPropStrict (reloc_name ctx i)
 119   | `CallProperty (i,count) ->
 120       `CallProperty (reloc_name ctx i, count)
 121   | `CallPropLex (i,count) ->
 122       `CallPropLex (reloc_name ctx i, count)
 123   | `ConstructProp (i,count) ->
 124       `ConstructProp (reloc_name ctx i, count)
 125   | `NewClass i ->
 126       `NewClass (i + ctx#classes)
 127   | `NewFunction i ->
 128       `NewFunction (i + ctx#methods)
 129   | _ as i ->
 130       i
 131
 132 let reloc_method_info ctx m =
 133   { m with
 134       method_name = reloc_name ctx m.method_name }
 135
 136 let reloc_method ctx m =
 137   { m with
 138       method_sig = m.method_sig + ctx#methods;
 139       code       = reloc ctx reloc_code m.code;
 140       method_traits = reloc_traits ctx m.method_traits
 141   }
 142
 143 (* class *)
 144 let reloc_class ctx c =
 145   {
 146       cinit = c.cinit + ctx#methods;
 147       class_traits = reloc_traits ctx c.class_traits
 148   }
 149
 150 let reloc_instance ctx i =
 151   {i with
 152      instance_name   = reloc_name ctx i.instance_name;
 153      super_name      = reloc_name ctx i.super_name;
 154      iinit           = i.iinit + ctx#methods;
 155      instance_traits = reloc_traits ctx i.instance_traits }
 156
 157 (* script *)
 158 let reloc_script ctx s =
 159   {
 160     init = s.init + ctx#methods;
 161     script_traits = reloc_traits ctx s.script_traits
 162   }
 163
 164 let link a1 a2 =
 165   let ctx = {|
 166       cpool = {|
 167           int    = List.length a1.cpool.int;
 168           uint   = List.length a1.cpool.uint;
 169           double = List.length a1.cpool.double;
 170           string = List.length a1.cpool.string;
 171           multiname = List.length a1.cpool.multiname
 172       |};
 173       methods = List.length a1.method_info;
 174       classes = List.length a1.classes
 175   |} in
 176     { a1 with
 177         cpool         = link_cpool                 a1.cpool         a2.cpool;
 178         method_info   = link reloc_method_info ctx a1.method_info   a2.method_info;
 179         method_bodies = link reloc_method      ctx a1.method_bodies a2.method_bodies;
 180         classes       = link reloc_class       ctx a1.classes       a2.classes;
 181         instances     = link reloc_instance    ctx a1.instances     a2.instances;
 182         scripts       = link reloc_script      ctx a1.scripts       a2.scripts
 183     }