ADD: unittest for define-class/new

diff --git a/example/class.scm b/example/class.scm
index 6d21bd7..dcc2904 100644 (file)
--- a/example/class.scm
+++ b/example/class.scm
@@ -1,9 +1,8 @@
-;;; hello
-;;; [object Foo]
+;;; [class Foo]
+;;; 42
 (define-class Foo Object
-  ((init) (print "hello")))
-
-(let ([k (new Foo)])
-  (print k))
-
+  ((init x) (print x))
+  ((f    x) (print x)))
 
+(print Foo)
+(new Foo 42)
\ No newline at end of file

diff --git a/src/base.ml b/src/base.ml
index 98d7c80..fc0b2db 100644 (file)
--- a/src/base.ml
+++ b/src/base.ml
@@ -1,4 +1,5 @@
 let (@@) f g = f g
+let (+>) f g = g f
 let ($) f g x = f (g x)
 let id x = x
 

diff --git a/src/codegen.ml b/src/codegen.ml
index 81ab2a2..36a307c 100644 (file)
--- a/src/codegen.ml
+++ b/src/codegen.ml
@@ -88,9 +88,9 @@ let rec generate_expr expr env =
        let qname =
          make_qname name in
        List.concat [
+         [FindPropStrict qname];
          HList.concat_map gen args;
-         [FindPropStrict qname;
-          ConstructProp (qname,List.length args)]]
+         [ConstructProp (qname,List.length args)]]
     | Lambda (args,body) ->
        let env' =
          add_register args empty_env in
@@ -108,6 +108,9 @@ let rec generate_expr expr env =
                 GetProperty qname]
            | Some (Register n) ->
                [GetLocal n]
+           | Some Global ->
+               [GetGlobalScope;
+                GetProperty qname]
            | _ ->
                [GetLex qname]
          end
@@ -223,32 +226,48 @@ let generate_stmt env stmt =
                        Swap;
                        SetProperty (make_qname name)]] in
          env',body'
-    | Class (name,(ns,sname),xs) ->
+    | Class (name,(ns,sname),body) ->
        let env' = 
          add_global name env in
        let name' =
          make_qname name in
        let sname' = 
          make_qname ~ns:ns sname in
-       let methods =
-         List.map (fun (name,args,body)-> 
-                     match generate_expr (Lambda (args,body)) env' with
-                         [NewFunction m] -> (name,{m with name=make_qname name})
-                       | _ -> failwith "must not happen") xs in
-       let init = 
-         List.assoc "init" methods in
+       let prefix = 
+         [GetLocal_0;
+          PushScope;
+          GetLocal_0;
+          ConstructSuper 0] in
+       let (init,cinit,methods) =
+         List.fold_left
+           (fun (init',cinit',methods') (name,args,body) -> 
+              match name,generate_expr (Lambda (args,body)) env' with
+                  "init" ,[NewFunction m] -> 
+                    ({m with 
+                        name=make_qname name;
+                        instructions=prefix@m.instructions},
+                     cinit',
+                     methods')
+                | "cinit",[NewFunction m] -> 
+                    (init',
+                     {m with name=make_qname name},
+                     methods')
+                | _      ,[NewFunction m] -> 
+                    (init',
+                     cinit',
+                     {m with name=make_qname name}::methods')
+                | _ -> 
+                    failwith "must not happen")
+           (make_meth "init" prefix,make_meth "cinit" [],[])
+           body in
        let klass = {
          Asm.cname = name';
          sname     = sname';
          flags_k   = [Sealed];
-         cinit     = make_meth "cinit" [];
-         iinit     = {init with 
-                        instructions= [GetLocal_0;
-                                       PushScope;
-                                       GetLocal_0;
-                                       ConstructSuper 0] @ init.instructions};
+         cinit     = cinit;
+         iinit     = init;
          interface = [];
-         methods   = List.map snd @@ List.remove_assoc "init" methods;
+         methods   = methods
        } in
          env',[
            (* init class *)

diff --git a/src/hList.ml b/src/hList.ml
index 2b77075..f2903f1 100644 (file)
--- a/src/hList.ml
+++ b/src/hList.ml
@@ -185,3 +185,9 @@ let unzip xs =
 
 let unzip3 xs =
   List.fold_right (fun (x,y,z) (xs,ys,zs) -> (x::xs,y::ys,z::zs)) xs ([],[],[])
+
+let lookup x xs =
+  try
+    Some (List.assoc x xs)
+  with Not_found ->
+    None

diff --git a/test/test_codegen.ml b/test/test_codegen.ml
index 1577eb3..982c641 100644 (file)
--- a/test/test_codegen.ml
+++ b/test/test_codegen.ml
@@ -167,6 +167,16 @@ test call_with_args =
     (toplevel [NewFunction (inner [0;0] [GetLocal 2])])
     (compile (Lambda (["x";"y"],Block [Var "y"])))
 
+test new_ = 
+  assert_equal 
+    (toplevel [FindPropStrict (make_qname "Foo");ConstructProp (make_qname "Foo",0)])
+    (generate_method @@ Lisp.compile_string "(new Foo)")
+
+test new_ = 
+  assert_equal 
+    (toplevel [FindPropStrict (make_qname "Foo");PushByte 42;ConstructProp (make_qname "Foo",1)])
+    (generate_method @@ Lisp.compile_string "(new Foo 42)")
+
 
 let new_class klass = 
   (toplevel [
@@ -195,6 +205,36 @@ test klass =
          methods   = []})
       (generate_method @@ Lisp.compile_string "(define-class Foo Object ((init) 10))")
 
+test klass_empty =
+    assert_equal 
+      (new_class
+        {Asm.cname = make_qname "Foo"; 
+         sname     = make_qname "Object";
+         flags_k   = [Asm.Sealed];
+         cinit     = Asm.make_meth "cinit" [];
+         iinit     = Asm.make_meth "init" [GetLocal_0;
+                                           PushScope;
+                                           GetLocal_0;
+                                           ConstructSuper 0];
+         interface = [];
+         methods   = []})
+      (generate_method @@ Lisp.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];
+         cinit     = Asm.make_meth "cinit" [];
+         iinit     = Asm.make_meth "init" [GetLocal_0;
+                                           PushScope;
+                                           GetLocal_0;
+                                           ConstructSuper 0];
+         interface = [];
+         methods   = [Asm.make_meth "f" [PushByte 42]]})
+      (generate_method @@ Lisp.compile_string "(define-class Foo Object ((f) 42))")
+
 test klass_with_ns =
       let make ns x =
        QName ((Namespace ns),x) in
@@ -211,3 +251,35 @@ test klass_with_ns =
                      interface = [];
                      methods   = []})
          (generate_method @@ Lisp.compile_string "(define-class Foo flash.text.Object ((init) 10))")
+
+test klass_args =
+    assert_equal 
+      (new_class
+        {Asm.cname = make_qname "Foo"; 
+         sname     = make_qname "Object";
+         flags_k   = [Asm.Sealed];
+         cinit     = Asm.make_meth "cinit" [];
+         iinit     = Asm.make_meth "init" ~args:[0] [GetLocal_0;
+                                                     PushScope;
+                                                     GetLocal_0;
+                                                     ConstructSuper 0;
+                                                     GetLocal 1];
+         interface = [];
+         methods   = []})
+      (generate_method @@ Lisp.compile_string "(define-class Foo Object ((init x) x))")
+
+
+test klass_f_args =
+    assert_equal 
+      (new_class
+        {Asm.cname = make_qname "Foo"; 
+         sname     = make_qname "Object";
+         flags_k   = [Asm.Sealed];
+         cinit     = Asm.make_meth "cinit" [];
+         iinit     = Asm.make_meth "init" [GetLocal_0;
+                                           PushScope;
+                                           GetLocal_0;
+                                           ConstructSuper 0];
+         interface = [];
+         methods   = [Asm.make_meth "f" ~args:[0] [GetLocal 1]]})
+      (generate_method @@ Lisp.compile_string "(define-class Foo Object ((f x) x))")

diff --git a/test/test_lisp.ml b/test/test_lisp.ml
index 377dd1b..8fc0e25 100644 (file)
--- a/test/test_lisp.ml
+++ b/test/test_lisp.ml
@@ -105,6 +105,9 @@ test klass =
   assert_equal [Class ("Foo",("","Object"),["init",[],Block [Var "x"]])] @@
     compile_string "(define-class Foo Object ((init) x))";
   assert_equal [Class ("Foo",("flash.text","Object"),["init",[],Block [Var "x"]])] @@
-    compile_string "(define-class Foo flash.text.Object ((init) x))"
+    compile_string "(define-class Foo flash.text.Object ((init) x))";
+  assert_equal [Class ("Foo",("flash.text","Object"),[])] @@
+    compile_string "(define-class Foo flash.text.Object)";
+