[REFACOTR]codegen

diff --git a/test/test_closuretrans.ml b/test/test_closuretrans.ml
index 451170f..730dc7b 100644 (file)
--- a/test/test_closuretrans.ml
+++ b/test/test_closuretrans.ml
@@ -2,22 +2,29 @@ open Base
 open Ast
 open Util
 open ClosureTrans
+open OUnit
 
 let ok x y =
   OUnit.assert_equal
     ~printer:(fun x-> (Std.dump (List.map Ast.to_string_stmt x) ^ "\n"))
     x y
 
-test closure_with_args =
-  ok
-    [Define ("f",Lambda (["x"],(Let (["x",Var "x"],Block [Lambda ([],Block [Var "x"])]))))]
-    (trans @@ compile_string "(define (f x) (lambda () x))")
-
-test closure_with_class =
-  ok [
-    Class ("Foo",("","Object"),[],
-          ["init",["self"],
-             Let (["self",Var "self"],
-                  Block [Lambda ([],Block [Var "self"])])])] @@
-    trans @@ compile_string "(define-class Foo (Object) ())  (define-method init ((self Foo)) (lambda () self))"
-
+let _ = 
+  ("closure trans" >::: [
+     "arguments" >::
+       (fun () ->
+         ok [Define ("f",
+                     Lambda (["x"],
+                             (Let (["x",Var "x"],
+                                   Block [Lambda ([],Block [Var "x"])]))))] @@
+           trans @@ compile_string "(define (f x) (lambda () x))");
+     "class" >::
+       (fun () ->
+         ok [
+           Class ("Foo",("","Object"),[],
+                  ["init",["self"],
+                   Let (["self",Var "self"],
+                        Block [Lambda ([],Block [Var "self"])])])] @@
+           trans @@ compile_string "(define-class Foo (Object) ())
+(define-method init ((self Foo)) (lambda () self))")
+   ]) +> run_test_tt

diff --git a/test/test_codegen.ml b/test/test_codegen.ml
index d740903..6f021e4 100644 (file)
--- a/test/test_codegen.ml
+++ b/test/test_codegen.ml
@@ -4,6 +4,7 @@ open Ast
 open Cpool
 open Codegen
 open Util
+open OUnit
 
 (** util function *)
 let string_of_insts xs =
@@ -11,7 +12,7 @@ let string_of_insts xs =
     String.concat "; \n\t" @@ List.map string_of_instruction xs in
     Printf.sprintf "[\n\t%s ]\n" ys
 
-let assert_equal lhs rhs =
+let ok lhs rhs =
   OUnit.assert_equal ~printer:Std.dump ~msg:"name"
     lhs.name         rhs.name;
   OUnit.assert_equal ~printer:Std.dump ~msg:"params"
@@ -56,183 +57,6 @@ let qname name =
 let compile x =
   (generate_script [Expr x])
 
-(** test *)
-test lib_call =
-    assert_equal 
-      (expr [FindPropStrict (qname "print");
-                PushString "Hello";
-                CallPropLex ((qname "print"),1)])
-      (compile (Call [Var "print";String "Hello"]))
-
-(* literal *)
-test int = 
-  assert_equal 
-    (expr [PushByte 42])
-    (compile (Int 42))
-
-test int_opt =
-  assert_equal
-    (expr [PushByte 42])
-    (compile (Int 42));
-  assert_equal
-    (expr [PushInt 300])
-    (compile (Int 300))
-
-test string =
-  assert_equal
-    (expr [PushString "Thanks for All the Fish"])
-    (compile (String "Thanks for All the Fish"))
-
-(* builtin operator *)
-test add = 
-  assert_equal
-    (expr [PushByte 1;PushByte 2;Add_i;])
-    (compile (Call [Var "+";Int 1;Int 2]))
-
-test boolean = 
-  assert_equal
-    (expr [PushByte 1;PushByte 2;Equals])
-    (compile (Call [Var "=";Int 1;Int 2]))
-
-(* complex expression *)
-test block =
-  assert_equal
-    (expr [PushByte 1;Pop;PushByte 2])
-    (compile (Block [Int 1;Int 2]))
-
-test if_ =
-  let a =
-    Label.peek 0 in
-  let b = Label.peek 1 in
-  assert_equal
-    (expr [PushByte 10; PushByte 20;  
-              IfNe a; PushByte 0; Jump b;
-              Label a;PushByte 1; Label b])
-    (compile (If ((Call [Var "=";Int 10;Int 20]),Int 0,Int 1)))
-
-(* scope *)
-test let_ =
-  assert_equal
-    (expr [PushString "x"; PushByte 1;
-          PushString "y"; PushByte 2;
-          NewObject 2;
-          PushWith;
-          GetScopeObject 1;
-          GetProperty (qname "x");
-          Pop;
-          GetScopeObject 1;
-          GetProperty (qname "y");
-          PopScope])
-    (compile (Let (["x",Int 1;"y",Int 2],
-                  Block [Var "x";Var "y"])))
-
-test letrec =
-    assert_equal
-      (expr [NewObject 0;
-                PushWith;
-                GetScopeObject 1;
-                PushByte 42;
-                SetProperty (qname "x");
-                PushByte 10;
-                PopScope])
-      (compile (LetRec (["x",Int 42],Block [Int 10])))
-
-test letrec =
-    assert_equal
-      (expr [NewObject 0;
-            PushWith;
-            GetScopeObject 1;
-
-            GetScopeObject 1;
-            GetProperty (qname "x");
-
-            SetProperty (qname "x");
-
-            PushByte 42;
-            PopScope])
-      (compile (LetRec (["x",Var "x"],Block [Int 42])))
-
-test define =
-    assert_equal 
-      (toplevel [NewFunction (inner [] [PushByte 42]);
-                GetScopeObject 0;
-                Swap;
-                SetProperty (qname "f")])
-      (generate_script @@ compile_string "(define (f) 42)")
-
-test define_not_hidden =
-    assert_equal 
-      (toplevel [NewFunction (inner [] [PushByte 42]);GetScopeObject 0;Swap;SetProperty (qname "f");
-                NewFunction (inner [] [PushByte 30]);GetScopeObject 0;Swap;SetProperty (qname "g")])
-      (generate_script @@ compile_string "(define (f) 42) (define (g) 30)")
-
-test define_hidden =
-    assert_equal 
-      (toplevel [NewFunction (inner [] [PushByte 42]);GetScopeObject 0;Swap;SetProperty (qname "f");
-                NewObject 0;PushWith;
-                NewFunction (inner [] [PushByte 30]);GetScopeObject 1;Swap;SetProperty (qname "f")])
-      (generate_script @@ compile_string "(define (f) 42) (define (f) 30)")
-
-test closure =
-    assert_equal 
-      (toplevel [NewFunction (inner [] [NewFunction (inner [] [GetLex (qname "x")])]);
-                GetScopeObject 0;
-                Swap;
-                SetProperty (qname "f")])
-      (generate_script @@ compile_string "(define (f) (lambda () x))")
-
-(* function call *)
-test call =
-  assert_equal 
-    (expr [NewFunction (inner [] [PushByte 42]) ])
-    (compile (Lambda ([],Block [Int 42])))
-
-test call_with_args =
-  assert_equal 
-    (expr [NewFunction (inner [0;0] [GetLocal 2])])
-    (compile (Lambda (["x";"y"],Block [Var "y"])))
-
-test closure_lambda =
-  assert_equal 
-    (expr [PushString "z"; PushByte 42;
-          NewObject 1;
-          PushWith;
-          NewFunction (inner [] [GetLex (qname "z")]);
-          PopScope])
-    (compile (Let (["z",Int 42],
-                  Lambda ([],Block [Var "z"]))))
-
-
-test new_ = 
-  assert_equal 
-    (expr [FindPropStrict (make_qname "Foo");ConstructProp (make_qname "Foo",0)])
-    (generate_script @@ compile_string "(new Foo)")
-
-test new_ = 
-  assert_equal 
-    (expr [FindPropStrict (make_qname "Foo");PushByte 42;ConstructProp (make_qname "Foo",1)])
-    (generate_script @@ compile_string "(new Foo 42)")
-
-test invoke =
-  assert_equal
-    (expr [GetLex (make_qname "x");PushByte 10;CallProperty (make_qname "foo",1)])
-    (generate_script @@ compile_string "(. x (foo 10))")
-
-test slotref =
-  assert_equal
-    (expr [GetLex (make_qname "obj");GetProperty (make_qname "x")])
-    (generate_script @@ compile_string "(slot-ref obj x)")
-
-test slotsef =
-  assert_equal
-    (expr [PushByte 42; 
-          GetLex (make_qname "obj");
-          Swap;
-          SetProperty (make_qname "x");
-          PushUndefined])
-    (generate_script @@ compile_string "(slot-set! obj x 42)")
-
-
 let new_class klass = 
   (toplevel [
      GetLex klass.Asm.sname;
@@ -264,145 +88,292 @@ let cinit =
       Asm.Class (make_qname "Foo");
      instructions =
       [ReturnVoid] }
-    
-test klass =
-    assert_equal 
-      (new_class
-        {Asm.cname = make_qname "Foo"; 
-         sname     = make_qname "Object";
-         flags_k   = [Asm.Sealed];
-         attributes = [];
-         cinit     = cinit;
-         iinit     = {init with
-                        instructions = prefix@[PushByte 10;Pop]@[ReturnVoid] };
-         interface = [];
-         methods   = []})
-      (generate_script @@ compile_string 
-        "(define-class Foo (Object) ())
-          (define-method init ((self Foo)) 10)")
-
-test klass_empty =
-    assert_equal 
-      (new_class
-        {Asm.cname = make_qname "Foo"; 
-         sname     = make_qname "Object";
-         flags_k   = [Asm.Sealed];
-         attributes = [];
-         cinit     = cinit;
-         iinit     = init;
-         interface = [];
-         methods   = []})
-      (generate_script @@ compile_string "(define-class Foo (Object) ())")
-
-test klass_f =
-    assert_equal 
-      (new_class
-        {Asm.cname = make_qname "Foo"; 
-         sname     = make_qname "Object";
-         flags_k   = [Asm.Sealed];
-         attributes = [];
-         cinit     = cinit;
-         iinit     = init;
-         interface = [];
-         methods   = [{ Asm.empty_method with
-                          name = make_qname "f";
-                          fun_scope = Asm.Class (make_qname "Foo");
-                          instructions = [PushByte 42;ReturnValue] }]})
-      (generate_script @@ compile_string 
-        "(define-class Foo (Object) ())
-          (define-method f ((self Foo)) 42)")
-
-test klass_with_ns =
-      let make ns x =
-       QName ((Namespace ns),x) in
-       assert_equal 
-         (new_class 
-            {Asm.cname = 
-                make_qname "Foo"; 
-             sname =
-                make "flash.text" "Object";
-             flags_k =
-                [Asm.Sealed];
-             attributes = 
-                [];
-             cinit = 
-                cinit;
-             iinit = 
-                {init with 
-                   instructions = prefix @ [PushByte 42; Pop; ReturnVoid]};
-             interface = [];
-             methods   = []})
-         (generate_script @@ compile_string 
-            "(define-class Foo (flash.text.Object) ())
-              (define-method init ((self Foo))  42)")
-
-test klass_args =
-    assert_equal 
-      (new_class
-        {Asm.cname = make_qname "Foo"; 
-         sname     = make_qname "Object";
-         flags_k   = [Asm.Sealed];
-         attributes = [];
-         cinit     = cinit;
-         iinit     = {init with
-                        params = [0];
-                        instructions = List.concat [
-                          prefix;
-                          [GetLocal 1; Pop;ReturnVoid] ] };
-         interface = [];
-         methods   = []})
-      (generate_script @@ compile_string 
-        "(define-class Foo (Object) ())
-          (define-method init ((self Foo) x) x)")
-
-test klass_self =
-    assert_equal 
-      (new_class
-        {Asm.cname = make_qname "Foo"; 
-         sname     = make_qname "Object";
-         flags_k   = [Asm.Sealed];
-         attributes = [];
-         cinit     = cinit;
-         iinit     = {init with
-                        instructions = prefix @ [GetLocal 0;Pop;ReturnVoid] };
-         interface = [];
-         methods   = []})
-      (generate_script @@ compile_string 
-        "(define-class Foo (Object) ())
-          (define-method init ((self Foo)) self)")
 
+let _ =
+  ("codegen module test" >::: [
+     "external call" >::
+       (fun () ->
+         ok (expr [FindPropStrict (qname "print");
+                   PushString "Hello";
+                   CallPropLex ((qname "print"),1)]) @@
+           compile (Call [Var "print";String "Hello"]));
+     "literal" >::: [
+       "int" >::
+        (fun () ->
+           ok (expr [PushByte 42]) @@
+             compile (Int 42));
+       "int optimize" >::
+        (fun () ->
+           ok (expr [PushByte 42]) @@
+             compile (Int 42);
+           ok (expr [PushInt 300]) @@
+             compile (Int 300));
+       "string" >::
+        (fun () ->
+           ok (expr [PushString "Thanks for All the Fish"]) @@
+             compile (String "Thanks for All the Fish"))
+     ];
+     "bulidin operator" >::: [
+       "+" >::
+        (fun () ->
+           ok (expr [PushByte 1;PushByte 2;Add_i]) @@
+             compile (Call [Var "+";Int 1;Int 2]));
+       "=" >::
+        (fun () ->
+           ok (expr [PushByte 1;PushByte 2;Equals]) @@
+             compile (Call [Var "=";Int 1;Int 2]))
+     ];
+     "if" >::
+       (fun () ->
+         let a =
+           Label.peek 0 in
+         let b = 
+           Label.peek 1 in
+           ok 
+             (expr [PushByte 10; PushByte 20;  
+                    IfNe a; PushByte 0; Jump b;
+                    Asm.Label a;PushByte 1; Asm.Label b])
+             (compile (If ((Call [Var "=";Int 10;Int 20]),Int 0,Int 1))));
+     "block" >::
+       (fun () ->
+         ok (expr [PushByte 1;Pop;PushByte 2]) @@
+           compile (Block [Int 1;Int 2]));
+     "let" >::
+       (fun () ->
+         ok (expr [PushString "x"; PushByte 1;
+                   PushString "y"; PushByte 2;
+                   NewObject 2;
+                   PushWith;
+                   GetScopeObject 1;
+                   GetProperty (qname "x");
+                   Pop;
+                   GetScopeObject 1;
+                   GetProperty (qname "y");
+                   PopScope]) @@
+           compile (Let (["x",Int 1;"y",Int 2],
+                         Block [Var "x";Var "y"])));
+     "letrec" >::
+       (fun () ->
+         ok (expr [NewObject 0;
+                   PushWith;
+                   GetScopeObject 1;
+                   PushByte 42;
+                   SetProperty (qname "x");
+                   PushByte 10;
+                   PopScope]) @@
+           compile (LetRec (["x",Int 42],Block [Int 10])));
+     "letrec for recursion" >::
+       (fun () ->
+         ok (expr [NewObject 0;
+                   PushWith;
+                   GetScopeObject 1;
+
+                   GetScopeObject 1;
+                   GetProperty (qname "x");
+                   
+                   SetProperty (qname "x");
+
+                   PushByte 42;
+                   PopScope]) @@
+           compile (LetRec (["x",Var "x"],Block [Int 42])));
+     "define" >::
+       (fun () ->
+         ok (toplevel [NewFunction (inner [] [PushByte 42]);
+                       GetScopeObject 0;
+                       Swap;
+                       SetProperty (qname "f")]) @@
+           generate_script @@ compile_string "(define (f) 42)");
+     "define dual" >::
+       (fun () ->
+         ok (toplevel [NewFunction (inner [] [PushByte 42]);
+                       GetScopeObject 0;Swap;SetProperty (qname "f");
+                       NewFunction (inner [] [PushByte 30]);
+                       GetScopeObject 0;Swap;SetProperty (qname "g")]) @@
+           generate_script @@ compile_string 
+           "(define (f) 42) (define (g) 30)");
+     "define same name" >::
+       (fun () ->
+         ok (toplevel [NewFunction (inner [] [PushByte 42]);
+                       GetScopeObject 0;Swap;SetProperty (qname "f");
+                       NewObject 0;PushWith;
+                       NewFunction (inner [] [PushByte 30]);
+                       GetScopeObject 1;Swap;SetProperty (qname "f")]) @@
+         generate_script @@ compile_string "(define (f) 42) (define (f) 30)");
+     "closure" >::
+       (fun () ->
+         ok (toplevel [NewFunction 
+                         (inner [] [NewFunction
+                                      (inner [] [GetLex (qname "x")])]);
+                       GetScopeObject 0;
+                       Swap;
+                       SetProperty (qname "f")]) @@
+           generate_script @@ compile_string "(define (f) (lambda () x))");
+     "call" >::: [
+       "normal" >::
+        (fun () ->
+           ok  (expr [NewFunction (inner [] [PushByte 42]) ]) @@
+             compile (Lambda ([],Block [Int 42])));
+       "arguments" >::
+        (fun () ->
+           ok  (expr [NewFunction (inner [0;0] [GetLocal 2])]) @@
+             compile (Lambda (["x";"y"],Block [Var "y"])));
+       "lambda" >::
+        (fun () ->
+           ok  (expr [PushString "z"; PushByte 42;
+                      NewObject 1;
+                      PushWith;
+                      NewFunction (inner [] [GetLex (qname "z")]);
+                      PopScope]) @@
+             compile (Let (["z",Int 42],
+                           Lambda ([],Block [Var "z"]))))
+     ];
+     "class" >::: [
+       "new" >::
+        (fun () ->
+           ok (expr [FindPropStrict (make_qname "Foo");
+                     ConstructProp (make_qname "Foo",0)]) @@
+             generate_script @@ compile_string "(new Foo)");
+       "new arguments" >::
+        (fun () ->
+           ok (expr [FindPropStrict (make_qname "Foo");
+                     PushByte 42;ConstructProp (make_qname "Foo",1)]) @@
+             generate_script @@ compile_string "(new Foo 42)");
+       "invoke" >::
+        (fun () ->
+           ok (expr [GetLex (make_qname "x");
+                     PushByte 10;
+                     CallProperty (make_qname "foo",1)]) @@
+             generate_script @@ compile_string "(. x (foo 10))");
+       "slot-ref" >::
+        (fun () ->
+           ok (expr [GetLex (make_qname "obj");
+                     GetProperty (make_qname "x")]) @@
+             generate_script @@ compile_string "(slot-ref obj x)");
+       "slot-set!" >::
+        (fun () ->
+           ok (expr [PushByte 42; 
+                     GetLex (make_qname "obj");
+                     Swap;
+                     SetProperty (make_qname "x");
+                     PushUndefined]) @@
+             generate_script @@ compile_string "(slot-set! obj x 42)");
+     ];
+     "class define" >::: [
+       "normal" >::
+        (fun () ->
+           ok 
+             (new_class
+                {Asm.cname = make_qname "Foo"; 
+                 sname     = make_qname "Object";
+                 flags_k   = [Asm.Sealed];
+                 attributes = [];
+                 cinit     = cinit;
+                 iinit     = {init with
+                                instructions = 
+                     prefix@[PushByte 10;Pop]@[ReturnVoid] };
+                 interface = [];
+                 methods   = []}) @@
+             generate_script @@ compile_string "(define-class Foo (Object) ())
+          (define-method init ((self Foo)) 10)");
+       "empty" >::
+        (fun () ->
+           ok (new_class
+                 {Asm.cname = make_qname "Foo"; 
+                  sname     = make_qname "Object";
+                  flags_k   = [Asm.Sealed];
+                  attributes= [];
+                  cinit     = cinit;
+                  iinit     = init;
+                  interface = [];
+                  methods   = []}) @@
+             generate_script @@ compile_string 
+             "(define-class Foo (Object) ())");
+       "method" >::
+        (fun ()->
+           ok (new_class
+                 {Asm.cname = make_qname "Foo"; 
+                  sname     = make_qname "Object";
+                  flags_k   = [Asm.Sealed];
+                  attributes= [];
+                  cinit     = cinit;
+                  iinit     = init;
+                  interface = [];
+                  methods   = [{ Asm.empty_method with
+                                   name = make_qname "f";
+                                   fun_scope = Asm.Class (make_qname "Foo");
+                                   instructions = [PushByte 42;ReturnValue] }]}) @@
+             generate_script @@ compile_string 
+                "(define-class Foo (Object) ())
+          (define-method f ((self Foo)) 42)");
+       "namespace" >::
+        (fun () ->
+           let make ns x =
+             QName ((Namespace ns),x) in
+             ok (new_class 
+                   {Asm.cname = 
+                       make_qname "Foo"; 
+                    sname =
+                       make "flash.text" "Object";
+                    flags_k =
+                       [Asm.Sealed];
+                    attributes = 
+                       [];
+                    cinit = 
+                       cinit;
+                    iinit = 
+                       {init with 
+                          instructions = prefix @ [PushByte 42; Pop; ReturnVoid]};
+                    interface = [];
+                    methods   = []}) @@
+               generate_script @@ compile_string 
+               "(define-class Foo (flash.text.Object) ())
+              (define-method init ((self Foo))  42)");
+       "method arguments" >::
+        (fun () ->
+           ok (new_class
+                 {Asm.cname = make_qname "Foo"; 
+                  sname     = make_qname "Object";
+                  flags_k   = [Asm.Sealed];
+                  attributes = [];
+                  cinit     = cinit;
+                  iinit     = {init with
+                                 params = [0];
+                                 instructions = List.concat [
+                                   prefix;
+                                   [GetLocal 1; Pop;ReturnVoid] ] };
+                  interface = [];
+                  methods   = []}) @@
+             generate_script @@ compile_string 
+             "(define-class Foo (Object) ())
+          (define-method init ((self Foo) x) x)");
+       "self" >::
+        (fun () ->
+           ok (new_class
+                 {Asm.cname = make_qname "Foo"; 
+                  sname     = make_qname "Object";
+                  flags_k   = [Asm.Sealed];
+                  attributes = [];
+                  cinit     = cinit;
+                  iinit     = {init with
+                                 instructions = prefix @ [GetLocal 0;Pop;ReturnVoid] };
+                  interface = [];
+                  methods   = []}) @@
+             generate_script @@ compile_string 
+             "(define-class Foo (Object) ())
+          (define-method init ((self Foo)) self)");
+       "attributes" >::
+        (fun () ->
+           ok (new_class
+                 {Asm.cname = make_qname "Foo"; 
+                  sname     = make_qname "Object";
+                  flags_k   = [Asm.Sealed];
+                  cinit     = cinit;
+                  iinit     = init;
+                  interface = [];
+                  attributes = [Cpool.make_qname "x";Cpool.make_qname "y"];
+                  methods   = []}) @@
+             generate_script @@ compile_string "(define-class Foo (Object) (x y))");
+     ]
+   ]) +> run_test_tt
 
-test klass_f_args =
-    assert_equal 
-      (new_class
-        {Asm.cname = make_qname "Foo"; 
-         sname     = make_qname "Object";
-         flags_k   = [Asm.Sealed];
-         cinit     = cinit;
-         iinit     = init;
-         interface = [];
-         attributes = [];
-         methods   = [{Asm.empty_method with
-                         name = 
-                          make_qname "f";
-                         fun_scope = 
-                          Asm.Class (make_qname "Foo");
-                         params = 
-                          [0];
-                         instructions =
-                          [GetLocal 1;ReturnValue] }]})
-      (generate_script @@ compile_string "(define-class Foo (Object) ())
- (define-method f ((self Foo) x) x)")
 
-test klass_attr =
-    assert_equal 
-      (new_class
-        {Asm.cname = make_qname "Foo"; 
-         sname     = make_qname "Object";
-         flags_k   = [Asm.Sealed];
-         cinit     = cinit;
-         iinit     = init;
-         interface = [];
-         attributes = [Cpool.make_qname "x";Cpool.make_qname "y"];
-         methods   = []})
-      (generate_script @@ compile_string "(define-class Foo (Object) (x y))")