From: mzp Date: Sun, 8 Nov 2009 07:06:04 +0000 (+0900) Subject: reimplement link.ml X-Git-Url: http://git.sourceforge.jp/view?a=commitdiff_plain;h=2a3f6291d21be99cd0341962b8c363ab2cc7c584;p=happyabc%2Fhappyabc.git reimplement link.ml --- diff --git a/link/OMakefile b/link/OMakefile index afd4049..22d1066 100644 --- a/link/OMakefile +++ b/link/OMakefile @@ -33,7 +33,7 @@ OCamlProgram($(PROGRAM), main $(FILES)) # Test # ------------------------------ OUnitTest(cmdOpt, cmdOpt $(ROOT)/config) -OUnitTest(link, link) +OUnitTest(link, link reloc) OUnitTest(reloc, reloc) # ------------------------------ diff --git a/link/link.ml b/link/link.ml index 96efcf3..53113a1 100644 --- a/link/link.ml +++ b/link/link.ml @@ -1,183 +1,36 @@ open Base open Swflib.AbcType -let reloc ctx f xs = - List.map (f ctx) xs - -let link f ctx x y = - x @ reloc ctx f y - -(* cpool *) -let reloc_ns ctx ns = - let n = - ctx#str in - match ns with - Namespace name -> - Namespace (name + n) - | PackageNamespace name -> - PackageNamespace (name + n) - | PackageInternalNamespace name -> - PackageInternalNamespace (name + n) - | ProtectedNamespace name -> - ProtectedNamespace (name + n) - | ExplicitNamespace name -> - ExplicitNamespace (name + n) - | StaticProtectedNamespace name -> - StaticProtectedNamespace (name + n) - | PrivateNamespace name -> - PrivateNamespace (name + n) - -let reloc_nss ctx = - List.map (fun ns-> ns + ctx#ns) - -let reloc_multi ctx = function - QName (ns, name) -> - QName (ns + ctx#ns, name + ctx#str) - | QNameA (ns, name) -> - QNameA (ns + ctx#ns, name + ctx#str) - | RTQName name -> - RTQName (name + ctx#str) - | RTQNameA name -> - RTQNameA (name + ctx#str) - | RTQNameL | RTQNameLA as n -> - n - | Multiname (name, nss) -> - Multiname (name + ctx#str, nss + ctx#nss) - | MultinameA (name, nss) -> - MultinameA (name + ctx#str, nss + ctx#nss) - | MultinameL name -> - MultinameL (name + ctx#str) - | MultinameLA name -> - MultinameLA (name + ctx#str) - -let link_cpool c1 c2 = - let ctx = {| - str = List.length c1.string; - ns = List.length c1.namespace; - nss =List.length c1.namespace_set - |} in { - int = c1.int @ c2.int; - uint = c1.uint @ c2.uint; - double = c1.double @ c2.double; - string = c1.string @ c2.string; - namespace = link reloc_ns ctx c1.namespace c2.namespace; - namespace_set = link reloc_nss ctx c1.namespace_set c2.namespace_set; - multiname = link reloc_multi ctx c1.multiname c2.multiname; - } - -let reloc_name ctx name = - if name = 0 then - 0 - else - name + ctx#cpool#multiname - -(* trait *) -let reloc_trait_data ctx = function - SlotTrait (id,name,vindex,vkind) -> - SlotTrait (id, reloc_name ctx name, vindex, vkind) - | ConstTrait (id,name,vindex,vkind) -> - ConstTrait (id, reloc_name ctx name, vindex, vkind) - | ClassTrait (id, classi) -> - ClassTrait (id, classi + ctx#classes) - | MethodTrait (id, methodi,attrs) -> - MethodTrait (id, methodi + ctx#methods,attrs) - | SetterTrait (id, methodi,attrs) -> - SetterTrait (id, methodi + ctx#methods,attrs) - | GetterTrait (id, methodi,attrs) -> - GetterTrait (id, methodi + ctx#methods,attrs) - | FunctionTrait (id, funi) -> - FunctionTrait (id, funi+ctx#methods) - -let reloc_traits ctx = - reloc ctx begin fun ctx t -> { - t with - trait_name = reloc_name ctx t.trait_name; - data = reloc_trait_data ctx t.data - } end - - -(* method *) -let reloc_code ctx : Swflib.LowInst.t -> Swflib.LowInst.t = function - `PushString i -> - `PushString (i + ctx#cpool#string) - | `PushInt i -> - `PushInt (i + ctx#cpool#int) - | `PushUInt i -> - `PushUInt (i + ctx#cpool#uint) - | `PushDouble i -> - `PushDouble (i + ctx#cpool#double) - | `GetLex i -> - `GetLex (reloc_name ctx i) - | `GetProperty i -> - `GetProperty (reloc_name ctx i) - | `SetProperty i -> - `SetProperty (reloc_name ctx i) - | `InitProperty i -> - `InitProperty (reloc_name ctx i) - | `FindPropStrict i -> - `FindPropStrict (reloc_name ctx i) - | `CallProperty (i,count) -> - `CallProperty (reloc_name ctx i, count) - | `CallPropLex (i,count) -> - `CallPropLex (reloc_name ctx i, count) - | `ConstructProp (i,count) -> - `ConstructProp (reloc_name ctx i, count) - | `NewClass i -> - `NewClass (i + ctx#classes) - | `NewFunction i -> - `NewFunction (i + ctx#methods) - | _ as i -> - i - -let reloc_method_info ctx m = - { m with - method_name = reloc_name ctx m.method_name } - -let reloc_method ctx m = - { m with - method_sig = m.method_sig + ctx#methods; - code = reloc ctx reloc_code m.code; - method_traits = reloc_traits ctx m.method_traits - } - -(* class *) -let reloc_class ctx c = - { - cinit = c.cinit + ctx#methods; - class_traits = reloc_traits ctx c.class_traits - } - -let reloc_instance ctx i = - {i with - instance_name = reloc_name ctx i.instance_name; - super_name = reloc_name ctx i.super_name; - iinit = i.iinit + ctx#methods; - instance_traits = reloc_traits ctx i.instance_traits } - -(* script *) -let reloc_script ctx s = - { - init = s.init + ctx#methods; - script_traits = reloc_traits ctx s.script_traits - } +let method_sigs n ms = + List.map (fun m -> {m with method_sig= n + m.method_sig} ) ms let link a1 a2 = - let ctx = {| - cpool = {| - int = List.length a1.cpool.int; - uint = List.length a1.cpool.uint; - double = List.length a1.cpool.double; - string = List.length a1.cpool.string; - multiname = List.length a1.cpool.multiname - |}; - methods = List.length a1.method_info; - classes = List.length a1.classes - |} in - { a1 with - cpool = link_cpool a1.cpool a2.cpool; - method_info = link reloc_method_info ctx a1.method_info a2.method_info; - method_bodies = link reloc_method ctx a1.method_bodies a2.method_bodies; - classes = link reloc_class ctx a1.classes a2.classes; - instances = link reloc_instance ctx a1.instances a2.instances; - scripts = link reloc_script ctx a1.scripts a2.scripts + let ctx = { + Reloc.int = (+) @@ List.length a1.cpool.int; + uint = (+) @@ List.length a1.cpool.uint; + double = (+) @@ List.length a1.cpool.double; + string = (+) @@ List.length a1.cpool.string; + namespace = (+) @@ List.length a1.cpool.namespace; + namespace_set = (+) @@ List.length a1.cpool.namespace_set; + multiname = (fun i -> if i = 0 then 0 else i + List.length a1.cpool.multiname); + methods = (+) @@ List.length a1.method_info; + classes = (+) @@ List.length a1.classes + } in + let a2 = + Reloc.reloc ctx a2 in + {a1 with + cpool = { + int = a1.cpool.int @ a2.cpool.int; + uint = a1.cpool.uint @ a2.cpool.uint; + double = a1.cpool.double @ a2.cpool.double; + string = a1.cpool.string @ a2.cpool.string; + namespace = a1.cpool.namespace @ a2.cpool.namespace; + namespace_set = a1.cpool.namespace_set @ a2.cpool.namespace_set; + multiname = a1.cpool.multiname @ a2.cpool.multiname + }; + method_info = a1.method_info @ a2.method_info; + method_bodies = a1.method_bodies @ method_sigs (List.length a1.method_info) a2.method_bodies; + scripts = a1.scripts @ a2.scripts; + classes = a1.classes @ a2.classes; + instances = a1.instances @ a2.instances; }