From: mzp Date: Sun, 8 Nov 2009 10:27:33 +0000 (+0900) Subject: use structual subtyping X-Git-Url: http://git.osdn.net/view?a=commitdiff_plain;h=1bf1d8fea74b9fe596e5c82e68ce4a8dd0a928fe;p=happyabc%2Fhappyabc.git use structual subtyping --- diff --git a/link/compact.ml b/link/compact.ml index 4a9705f..7c9e106 100644 --- a/link/compact.ml +++ b/link/compact.ml @@ -1,3 +1,21 @@ +open ExtList + open Base +open Swflib.AbcType + +let nth xs i = + List.nth xs (i+1) + + +let compact_cpool cpool = + {cpool with + int = List.unique cpool.int; + uint = List.unique cpool.uint; + double = List.unique cpool.double; + string = List.unique cpool.string; + } -let compact _ = undef +let compact abc = { + abc with + cpool = compact_cpool abc.cpool +} diff --git a/link/reloc.ml b/link/reloc.ml index f019a63..77c4d78 100644 --- a/link/reloc.ml +++ b/link/reloc.ml @@ -3,162 +3,151 @@ open Swflib open Swflib.AbcType type reloc = int -> int -type t = { - int : reloc; - uint : reloc; - double : reloc; - string : reloc; - namespace : reloc; - namespace_set : reloc; - multiname : reloc; - methods : reloc; - classes : reloc -} - -let reloc_ns {string} = + +let reloc_ns relocs = function Namespace name -> - Namespace (string name) + Namespace (relocs#string name) | PackageNamespace name -> - PackageNamespace (string name) + PackageNamespace (relocs#string name) | PackageInternalNamespace name -> - PackageInternalNamespace (string name) + PackageInternalNamespace (relocs#string name) | ProtectedNamespace name -> - ProtectedNamespace (string name) + ProtectedNamespace (relocs#string name) | ExplicitNamespace name -> - ExplicitNamespace (string name) + ExplicitNamespace (relocs#string name) | StaticProtectedNamespace name -> - StaticProtectedNamespace (string name) + StaticProtectedNamespace (relocs#string name) | PrivateNamespace name -> - PrivateNamespace (string name) + PrivateNamespace (relocs#string name) -let reloc_nss { namespace } = - List.map namespace +let reloc_nss relocs = + List.map relocs#namespace -let reloc_multi {namespace; namespace_set; string} = function +let reloc_multi relocs = function QName (ns, name) -> - QName (namespace ns, string name) + QName (relocs#namespace ns, relocs#string name) | QNameA (ns, name) -> - QNameA (namespace ns, string name) + QNameA (relocs#namespace ns, relocs#string name) | RTQName name -> - RTQName (string name) + RTQName (relocs#string name) | RTQNameA name -> - RTQNameA (string name) + RTQNameA (relocs#string name) | RTQNameL | RTQNameLA as n -> n | Multiname (name, nss) -> - Multiname (string name, namespace_set nss) + Multiname (relocs#string name, relocs#namespace_set nss) | MultinameA (name, nss) -> - MultinameA (string name, namespace_set nss) + MultinameA (relocs#string name, relocs#namespace_set nss) | MultinameL name -> - MultinameL (string name) + MultinameL (relocs#string name) | MultinameLA name -> - MultinameLA (string name) + MultinameLA (relocs#string name) -let rmap f ctx x = - List.map (f ctx) x +let rmap f relocs x = + List.map (f relocs) x -let reloc_cpool ctx cpool = +let reloc_cpool relocs cpool = { cpool with - AbcType.namespace = rmap reloc_ns ctx cpool.AbcType.namespace; - namespace_set = rmap reloc_nss ctx cpool.AbcType.namespace_set; - multiname = rmap reloc_multi ctx cpool.AbcType.multiname } + namespace = rmap reloc_ns relocs cpool.namespace; + namespace_set = rmap reloc_nss relocs cpool.namespace_set; + multiname = rmap reloc_multi relocs cpool.multiname } (* trait *) -let reloc_trait_data {multiname; classes; methods} = function +let reloc_trait_data relocs = function SlotTrait (id,name,vindex,vkind) -> - SlotTrait (id, multiname name, vindex, vkind) + SlotTrait (id, relocs#multiname name, vindex, vkind) | ConstTrait (id,name,vindex,vkind) -> - ConstTrait (id, multiname name, vindex, vkind) + ConstTrait (id, relocs#multiname name, vindex, vkind) | ClassTrait (id, classi) -> - ClassTrait (id, classes classi) + ClassTrait (id, relocs#classes classi) | MethodTrait (id, methodi,attrs) -> - MethodTrait (id, methods methodi,attrs) + MethodTrait (id, relocs#methods methodi,attrs) | SetterTrait (id, methodi,attrs) -> - SetterTrait (id, methods methodi, attrs) + SetterTrait (id, relocs#methods methodi, attrs) | GetterTrait (id, methodi,attrs) -> - GetterTrait (id, methods methodi, attrs) + GetterTrait (id, relocs#methods methodi, attrs) | FunctionTrait (id, funi) -> - FunctionTrait (id, methods funi) + FunctionTrait (id, relocs#methods funi) -let reloc_traits ctx = - rmap begin fun ctx t -> { +let reloc_traits relocs = + rmap begin fun relocs t -> { t with - trait_name = ctx.multiname t.trait_name; - data = reloc_trait_data ctx t.data - } end ctx + trait_name = relocs#multiname t.trait_name; + data = reloc_trait_data relocs t.data + } end relocs (* method *) -let reloc_code ctx : Swflib.LowInst.t -> Swflib.LowInst.t = function +let reloc_code relocs : Swflib.LowInst.t -> Swflib.LowInst.t = function `PushString i -> - `PushString (ctx.string i) + `PushString (relocs#string i) | `PushInt i -> - `PushInt (ctx.int i) + `PushInt (relocs#int i) | `PushUInt i -> - `PushUInt (ctx.uint i) + `PushUInt (relocs#uint i) | `PushDouble i -> - `PushDouble (ctx.double i) + `PushDouble (relocs#double i) | `GetLex i -> - `GetLex (ctx.multiname i) + `GetLex (relocs#multiname i) | `GetProperty i -> - `GetProperty (ctx.multiname i) + `GetProperty (relocs#multiname i) | `SetProperty i -> - `SetProperty (ctx.multiname i) + `SetProperty (relocs#multiname i) | `InitProperty i -> - `InitProperty (ctx.multiname i) + `InitProperty (relocs#multiname i) | `FindPropStrict i -> - `FindPropStrict (ctx.multiname i) + `FindPropStrict (relocs#multiname i) | `CallProperty (i,count) -> - `CallProperty (ctx.multiname i, count) + `CallProperty (relocs#multiname i, count) | `CallPropLex (i,count) -> - `CallPropLex (ctx.multiname i, count) + `CallPropLex (relocs#multiname i, count) | `ConstructProp (i,count) -> - `ConstructProp (ctx.multiname i, count) + `ConstructProp (relocs#multiname i, count) | `NewClass i -> - `NewClass (ctx.classes i) + `NewClass (relocs#classes i) | `NewFunction i -> - `NewFunction (ctx.methods i) + `NewFunction (relocs#methods i) | _ as i -> i -let reloc_method_info {multiname} m = +let reloc_method_info relocs m = { m with - method_name = multiname m.method_name } + method_name = relocs#multiname m.method_name } -let reloc_method ctx m = +let reloc_method relocs m = { m with - code = rmap reloc_code ctx m.code; - method_traits = reloc_traits ctx m.method_traits + code = rmap reloc_code relocs m.code; + method_traits = reloc_traits relocs m.method_traits } (* class *) -let reloc_class ctx c = +let reloc_class relocs c = { - cinit = ctx.methods c.cinit; - class_traits = reloc_traits ctx c.class_traits + cinit = relocs#methods c.cinit; + class_traits = reloc_traits relocs c.class_traits } -let reloc_instance ctx i = +let reloc_instance relocs i = {i with - instance_name = ctx.multiname i.instance_name; - super_name = ctx.multiname i.super_name; - iinit = ctx.methods i.iinit; - instance_traits = reloc_traits ctx i.instance_traits } + instance_name = relocs#multiname i.instance_name; + super_name = relocs#multiname i.super_name; + iinit = relocs#methods i.iinit; + instance_traits = reloc_traits relocs i.instance_traits } (* script *) -let reloc_script ctx s = +let reloc_script relocs s = { - init = ctx.methods s.init; - script_traits = reloc_traits ctx s.script_traits + init = relocs#methods s.init; + script_traits = reloc_traits relocs s.script_traits } -let reloc ctx abc = +let reloc relocs abc = { abc with - cpool = reloc_cpool ctx abc.cpool; - method_info = rmap reloc_method_info ctx abc.method_info; - method_bodies = rmap reloc_method ctx abc.method_bodies; - AbcType.classes = rmap reloc_class ctx abc.AbcType.classes; - instances = rmap reloc_instance ctx abc.instances; - scripts = rmap reloc_script ctx abc.scripts + cpool = reloc_cpool relocs abc.cpool; + method_info = rmap reloc_method_info relocs abc.method_info; + method_bodies = rmap reloc_method relocs abc.method_bodies; + classes = rmap reloc_class relocs abc.AbcType.classes; + instances = rmap reloc_instance relocs abc.instances; + scripts = rmap reloc_script relocs abc.scripts } diff --git a/link/reloc.mli b/link/reloc.mli index 3a6e10e..db658d9 100644 --- a/link/reloc.mli +++ b/link/reloc.mli @@ -1,14 +1,6 @@ type reloc = int -> int -type t = { - int : reloc; - uint : reloc; - double : reloc; - string : reloc; - namespace : reloc; - namespace_set : reloc; - multiname : reloc; - methods : reloc; - classes : reloc -} -val reloc : t -> Swflib.Abc.t -> Swflib.Abc.t +val reloc_cpool : + < string: reloc; namespace : reloc; namespace_set : reloc; ..> -> Swflib.AbcType.cpool -> Swflib.AbcType.cpool +val reloc : + < int : reloc; uint : reloc; double : reloc; string : reloc; namespace : reloc; namespace_set : reloc; multiname : reloc; classes : reloc; methods : reloc;.. > -> Swflib.Abc.t -> Swflib.Abc.t diff --git a/link/relocTest.ml b/link/relocTest.ml index c3f2896..879488b 100644 --- a/link/relocTest.ml +++ b/link/relocTest.ml @@ -5,7 +5,7 @@ open EmptyAbc open Reloc let plus n x = n + x -let ctx = { +let ctx = {| int = plus 1; uint = plus 2; double = plus 3; @@ -15,20 +15,21 @@ let ctx = { multiname = plus 7; methods = plus 8; classes = plus 9 -} +|} let ok x y = assert_equal x @@ reloc ctx y let _ = begin "reloc.ml" >::: [ "cpool" >:: begin fun () -> - ok - {abc with cpool = { cpool with - Swflib.AbcType.namespace = [Namespace 4]; - namespace_set = [[6;7]]; - multiname = [QName (6,5)]; }} - {abc with cpool = { cpool with - Swflib.AbcType.namespace = [Namespace 0]; - namespace_set = [[1;2]]; - multiname = [QName(1,1)] }} + assert_equal + { cpool with + namespace = [Namespace 4]; + namespace_set = [[6;7]]; + multiname = [QName (6,5)]; } + @@ reloc_cpool ctx + { cpool with + namespace = [Namespace 0]; + namespace_set = [[1;2]]; + multiname = [QName(1,1)] } end; "method_info" >:: begin fun () -> ok