traits

diff --git a/src/asm.ml b/src/asm.ml
index fa05e72..2f62021 100644 (file)
--- a/src/asm.ml
+++ b/src/asm.ml
@@ -2,6 +2,9 @@ open Base
 open Cpool
 open Bytes
 
+type trait_body = Slot of int
+type trait = string * trait_body
+
 type instruction =
 #include "opcode.ml"
  and meth = {
@@ -10,9 +13,9 @@ type instruction =
   return: int;
   flags:int;
   instructions:instruction list;
-  traits: int list;
+  traits: trait list;
   exceptions: int list;
-} 
+}
 
 type mmap = meth Pool.map
 type config = {
@@ -40,6 +43,33 @@ let default = {
 
 #include "match.ml"
 
+(* collect info for cpool *)
+ let make_qname name = 
+   Cpool.QName (Cpool.Namespace "",name)
+
+let collect_traits xs = 
+  List.fold_left Cpool.append Cpool.empty @@
+    List.map (fun (name,_) -> Cpool.multiname (make_qname name)) xs
+
+let rec collect ({instructions=insts;traits=traits} as meth) =
+  let meth_and_const inst =
+    let {meth=m;const=c} =
+      get_config inst in
+      match m with
+         Some child ->
+           let m',c' =
+             collect child in
+             Pool.add child m',Cpool.append c c'
+       | None ->
+           Pool.empty,c in
+  let meths,consts =
+    List.fold_left 
+      (fun (m0,c0) (m,c) -> Pool.append m m0,Cpool.append c c0) 
+      (Pool.empty,Cpool.empty) @@ List.map meth_and_const insts in
+  let traits' =
+    collect_traits traits in
+    Pool.add meth meths,Cpool.append traits' consts
+
 (* convert instruction *)
 let add (max,current) n = 
   let current' =
@@ -49,7 +79,15 @@ let add (max,current) n =
     else
       (max,current')
 
-let method_asm map index m =
+let asm_trait (map,_) (name,trait) =
+  let i = 
+    Cpool.multiname_nget (make_qname name) map in
+  let data = 
+    match trait with
+       Slot n -> Abc.SlotTrait (n,0,0,0) in
+    {Abc.t_name=i;Abc.data=data}
+
+let asm_method map index m =
   let configs =
     List.map get_config m.instructions in
   let init =
@@ -79,23 +117,9 @@ let method_asm map index m =
       Abc.max_scope_depth=max_scope;
       Abc.code=List.concat @@ List.rev bytes;
       Abc.exceptions=[]; 
-      Abc.trait_m=[] } in
+      Abc.trait_m=List.map (asm_trait map) m.traits } in
       info,body
 
-let rec collect ({instructions=insts} as meth) =
-  let meth_and_const inst =
-    let {meth=m;const=c} =
-      get_config inst in
-      match m with
-         Some child ->
-           let m',c' =
-             collect child in
-             Pool.add child m',Cpool.append c c'
-       | None ->
-           Pool.empty,c in
-    List.fold_left (fun (m0,c0) (m,c) -> Pool.append m m0,Cpool.append c c0) (Pool.add meth Pool.empty,Cpool.empty) 
-    @@ List.map meth_and_const insts
-
 let assemble meth =
   let meths,consts = 
     collect meth in
@@ -108,5 +132,5 @@ let assemble meth =
   let meths' =
     Pool.to_list meths in
   let info,body =
-    ExtList.List.split @@ ExtList.List.mapi (fun i x-> method_asm (cmap,mmap) i x) meths' in
+    ExtList.List.split @@ ExtList.List.mapi (fun i x-> asm_method (cmap,mmap) i x) meths' in
     cpool,info,body

diff --git a/src/asm.mli b/src/asm.mli
index 7993a9a..2f9257a 100644 (file)
--- a/src/asm.mli
+++ b/src/asm.mli
@@ -1,4 +1,7 @@
 
+type trait_body = Slot of int
+type trait = string * trait_body
+
 type instruction =
 #include "opcode.ml"
  and meth = {
@@ -7,7 +10,7 @@ type instruction =
   return: int;
   flags:int;
   instructions:instruction list;
-  traits: int list;
+  traits: trait list;
   exceptions: int list;
 }
 

diff --git a/src/ast.ml b/src/ast.ml
index 94864cd..aa1e0d4 100644 (file)
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -43,7 +43,6 @@ let is_bind name (_,env) =
 let make_qname x = 
   Cpool.QName ((Cpool.Namespace ""),x)
 
-
 let make_meth ?(args=[]) name body = 
   let inst =
     [GetLocal_0;PushScope] @
@@ -54,7 +53,7 @@ let make_meth ?(args=[]) name body =
     return=0;
     flags =0;
     exceptions=[];
-    traits=[];
+    traits=["a",Slot 1];
     instructions=inst}
 
 let rec generate_expr ast env = 
@@ -160,7 +159,7 @@ let generate_method program =
 
 let generate program =
   let m = 
-    generate_method (Method ("",[],program)) in
+    generate_method program in
   let cpool,info,body =
     assemble m in
     { Abc.cpool=cpool;

diff --git a/src/cpool.ml b/src/cpool.ml
index eaf38ba..4791203 100644 (file)
--- a/src/cpool.ml
+++ b/src/cpool.ml
@@ -105,6 +105,10 @@ let cpool_entry v map =
 let string_get str (_,{string=map}) = 
   cpool_entry str map
 
+let string_nget str (_,{string=map}) = 
+  pool_get str map
+
+
 let int_get n (_,{int=map}) = 
   cpool_entry n map
 
@@ -114,6 +118,9 @@ let uint_get n (_,{uint=map}) =
 let multiname_get name (_,{multiname=map}) =
   cpool_entry name map
 
+let multiname_nget name (_,{multiname=map}) =
+  pool_get name map
+
 (* conversion *)
 let pack x =
   lift1 {app=fun x _ -> Pool.uniq x} x;;

diff --git a/src/cpool.mli b/src/cpool.mli
index 202461b..e7ee510 100644 (file)
--- a/src/cpool.mli
+++ b/src/cpool.mli
@@ -21,7 +21,9 @@ val multiname: multiname -> t
 val int_get       : int -> cmap -> Bytes.t
 val uint_get      : int -> cmap -> Bytes.t
 val string_get    : string -> cmap -> Bytes.t
+val string_nget    : string -> cmap -> int
 val multiname_get : multiname -> cmap -> Bytes.t
+val multiname_nget : multiname -> cmap -> int
 
 val to_cmap  : t -> cmap
 val to_cpool : cmap -> Abc.cpool

diff --git a/src/init.ml b/src/init.ml
index fe6f3b2..cabf071 100644 (file)
--- a/src/init.ml
+++ b/src/init.ml
@@ -8,7 +8,5 @@
 #load "abc.cmo";;
 #load "pool.cmo";;
 #load "cpool.cmo";;
-#load "opcode.cmo";;
-#load "match.cmo";;
 #load "asm.cmo";;