From: mzp <mzpppp@gmail.com>
Date: Sat, 12 Sep 2009 02:39:05 +0000 (+0900)
Subject: implements compiler module
X-Git-Url: http://git.osdn.net/view?a=commitdiff_plain;h=ed18997324f66a33310129670c8d539d6ef23ec5;p=happyabc%2Fhappyabc.git

implements compiler module
---

diff --git a/swflib/compile.ml b/swflib/compile.ml
index 584861b..dee549c 100644
--- a/swflib/compile.ml
+++ b/swflib/compile.ml
@@ -1,5 +1,6 @@
 open Base
 open AbcType
+open ExtList
 
 type 'a t = {
   cpool:         Cpool.t;
@@ -45,8 +46,8 @@ type 'a class_ = {
 
 class type ['a] context = object
   method cpool:   Cpool.t
-  method methods: 'a method_ RevList.t
-  method classes: 'a class_ RevList.t
+  method methods: 'a method_ list
+  method classes: 'a class_ list
 end
 
 module type Inst = sig
@@ -77,16 +78,16 @@ module Make(Inst : Inst) = struct
 
   let methods ({code=code} as m) =
     List.concat [
-      [m];
       filter_map Inst.method_ code;
       HList.concat_map methods_of_class @@ filter_map Inst.class_ code;
+      [m];
     ]
 
   let classes ms =
     methods_map (filter_map Inst.class_) ms
 
   (* cpool *)
-  let cpool ms cs =
+  let consts ms cs =
     let entries x =
       (x :> Cpool.entry list) in
     let inst_const =
@@ -103,16 +104,103 @@ module Make(Inst : Inst) = struct
 	meth_const;
 	class_const]
 
+  (* methods *)
+  let method_info cpool {method_name  = name;
+			 params       = params;
+			 return       = return;
+			 method_flags = flags} =
+    {
+      AbcType.params = params;
+      return         = return;
+      method_name    = Cpool.index cpool name;
+      method_flags   = flags
+    }
+
+  let method_body ctx i {params=params; code=code} =
+    let max_value f xs  =
+      snd @@ List.fold_left
+	(fun (c,m) x ->
+	   let c' = c + f x in
+	     (c',max c' m))
+	(0,0) xs in
+      {
+	AbcType.method_sig = i;
+	max_stack          = max_value Inst.stack code;
+	local_count        = List.length params + 1;
+	init_scope_depth   = 0;
+	max_scope_depth    = max_value Inst.scope code;
+	code               = List.map (Inst.inst ctx) code;
+	exceptions         = [];
+	method_traits      = [];
+      }
+
+  let index x xs =
+    fst @@ List.findi (fun _ y -> x = y) xs
+
+  let table xs =
+    fun x ->
+      List.assoc x xs
+
+  let method_trait ctx ({method_name=name; method_attrs=attrs} as m) =
+    let attrs' =
+     List.map (table [`Override, AbcType.ATTR_Override;
+	              `Final   , AbcType.ATTR_Final])
+       attrs in
+    {
+      AbcType.trait_name = Cpool.index ctx#cpool name;
+      data               = AbcType.MethodTrait (0,index m ctx#methods,attrs')
+    }
+
+  let attr_trait ctx i name = {
+    AbcType.trait_name = Cpool.index ctx#cpool name;
+    data               = AbcType.SlotTrait (i+1,0,0,0)
+  }
+
+  let class_info ctx {cinit=m; static_methods=sms} = {
+    AbcType.cinit = index m ctx#methods;
+    class_traits  = List.map (method_trait ctx) sms;
+  }
+
+  let instance_info ctx c =
+    let flag =
+      function
+	| `ProtectedNs ns -> AbcType.ProtectedNs (Cpool.index ctx#cpool ns)
+	| _ as x ->
+	    table [`Sealed,AbcType.Sealed;
+		   `Final,AbcType.Final;
+		   `Interface,AbcType.Interface] x in
+    {
+      AbcType.instance_name =
+	Cpool.index ctx#cpool c.class_name;
+      super_name        =
+	Cpool.index ctx#cpool c.super;
+      instance_flags    =
+	List.map flag c.class_flags;
+      interface         =
+	List.map (flip index ctx#classes) c.interface;
+      iinit             =
+	index c.iinit ctx#methods;
+      instance_traits   =
+	List.concat [
+	  List.map  (method_trait ctx) c.instance_methods;
+	  List.mapi (attr_trait ctx)   c.attrs
+	]
+    }
+
   let to_abc top_method =
     let ms =
       methods top_method in
     let cs =
       classes ms in
+    let cpool =
+      consts ms cs in
+    let ctx =
+      {| cpool = cpool; methods = ms; classes = cs |} in
       {
-	cpool=cpool ms cs;
-	method_info=[];
-	method_body=[];
-	class_info=[];
-	instance_info=[];
+	cpool         = cpool;
+	method_info   = List.map  (method_info cpool) ms;
+	method_body   = List.mapi (method_body ctx)   ms;
+	class_info    = List.map  (class_info ctx)    cs;
+	instance_info = List.map  (instance_info ctx) cs;
       }
 end