test/test_codegen.ml

   1 open Base
   2 open Asm
   3 open Ast
   4 open Cpool
   5 open Codegen
   6 open Util
   7
   8 (** util function *)
   9 let string_of_insts xs =
  10   let ys =
  11     String.concat "; \n\t" @@ List.map string_of_instruction xs in
  12     Printf.sprintf "[\n\t%s ]\n" ys
  13
  14 let assert_equal lhs rhs =
  15   OUnit.assert_equal ~printer:Std.dump ~msg:"name"
  16     lhs.name         rhs.name;
  17   OUnit.assert_equal ~printer:Std.dump ~msg:"params"
  18     lhs.params       rhs.params;
  19   OUnit.assert_equal ~printer:Std.dump ~msg:"return"
  20     lhs.return       rhs.return;
  21   OUnit.assert_equal ~printer:Std.dump ~msg:"flags"
  22     lhs.flags        rhs.flags;
  23   OUnit.assert_equal ~printer:string_of_insts ~msg:"instructions"
  24     lhs.instructions rhs.instructions;
  25   OUnit.assert_equal ~printer:Std.dump ~msg:"traits"
  26     lhs.traits       rhs.traits;
  27   OUnit.assert_equal ~printer:Std.dump ~msg:"exceptions"
  28     lhs.exceptions   rhs.exceptions
  29
  30 let expr inst =
  31   {Asm.empty_method with
  32      name =
  33       make_qname "";
  34      instructions=
  35       [GetLocal_0;PushScope]@inst@[Pop;ReturnVoid]}
  36
  37 let toplevel inst =
  38   {Asm.empty_method with
  39      name =
  40       make_qname "";
  41      instructions=
  42       [GetLocal_0;PushScope]@inst@[ReturnVoid]}
  43
  44 let inner args inst =
  45   {Asm.empty_method with
  46      name =
  47       make_qname "";
  48      params =
  49       args;
  50      instructions=
  51       inst@[ReturnValue] }
  52
  53 let qname name =
  54   QName ((Namespace ""),name)
  55
  56 let compile x =
  57   (generate_script [Expr x])
  58
  59 (** test *)
  60 test lib_call =
  61     assert_equal
  62       (expr [FindPropStrict (qname "print");
  63                  PushString "Hello";
  64                  CallPropLex ((qname "print"),1)])
  65       (compile (Call [Var "print";String "Hello"]))
  66
  67 (* literal *)
  68 test int =
  69   assert_equal
  70     (expr [PushByte 42])
  71     (compile (Int 42))
  72
  73 test int_opt =
  74   assert_equal
  75     (expr [PushByte 42])
  76     (compile (Int 42));
  77   assert_equal
  78     (expr [PushInt 300])
  79     (compile (Int 300))
  80
  81 test string =
  82   assert_equal
  83     (expr [PushString "Thanks for All the Fish"])
  84     (compile (String "Thanks for All the Fish"))
  85
  86 (* builtin operator *)
  87 test add =
  88   assert_equal
  89     (expr [PushByte 1;PushByte 2;Add_i;])
  90     (compile (Call [Var "+";Int 1;Int 2]))
  91
  92 test boolean =
  93   assert_equal
  94     (expr [PushByte 1;PushByte 2;Equals])
  95     (compile (Call [Var "=";Int 1;Int 2]))
  96
  97 (* complex expression *)
  98 test block =
  99   assert_equal
 100     (expr [PushByte 1;Pop;PushByte 2])
 101     (compile (Block [Int 1;Int 2]))
 102
 103 test if_ =
 104   let a =
 105     Label.peek 0 in
 106   let b = Label.peek 1 in
 107   assert_equal
 108     (expr [PushByte 10; PushByte 20;
 109                IfNe a; PushByte 0; Jump b;
 110                Label a;PushByte 1; Label b])
 111     (compile (If ((Call [Var "=";Int 10;Int 20]),Int 0,Int 1)))
 112
 113 (* scope *)
 114 test let_ =
 115   assert_equal
 116     (expr [PushString "x"; PushByte 1;
 117            PushString "y"; PushByte 2;
 118            NewObject 2;
 119            PushWith;
 120            GetScopeObject 1;
 121            GetProperty (qname "x");
 122            Pop;
 123            GetScopeObject 1;
 124            GetProperty (qname "y");
 125            PopScope])
 126     (compile (Let (["x",Int 1;"y",Int 2],
 127                    Block [Var "x";Var "y"])))
 128
 129 test letrec =
 130     assert_equal
 131       (expr [NewObject 0;
 132                  PushWith;
 133                  GetScopeObject 1;
 134                  PushByte 42;
 135                  SetProperty (qname "x");
 136                  PushByte 10;
 137                  PopScope])
 138       (compile (LetRec (["x",Int 42],Block [Int 10])))
 139
 140 test letrec =
 141     assert_equal
 142       (expr [NewObject 0;
 143              PushWith;
 144              GetScopeObject 1;
 145
 146              GetScopeObject 1;
 147              GetProperty (qname "x");
 148
 149              SetProperty (qname "x");
 150
 151              PushByte 42;
 152              PopScope])
 153       (compile (LetRec (["x",Var "x"],Block [Int 42])))
 154
 155 test define =
 156     assert_equal
 157       (toplevel [NewFunction (inner [] [PushByte 42]);
 158                  GetScopeObject 0;
 159                  Swap;
 160                  SetProperty (qname "f")])
 161       (generate_script @@ compile_string "(define (f) 42)")
 162
 163 test define_not_hidden =
 164     assert_equal
 165       (toplevel [NewFunction (inner [] [PushByte 42]);GetScopeObject 0;Swap;SetProperty (qname "f");
 166                  NewFunction (inner [] [PushByte 30]);GetScopeObject 0;Swap;SetProperty (qname "g")])
 167       (generate_script @@ compile_string "(define (f) 42) (define (g) 30)")
 168
 169 test define_hidden =
 170     assert_equal
 171       (toplevel [NewFunction (inner [] [PushByte 42]);GetScopeObject 0;Swap;SetProperty (qname "f");
 172                  NewObject 0;PushWith;
 173                  NewFunction (inner [] [PushByte 30]);GetScopeObject 1;Swap;SetProperty (qname "f")])
 174       (generate_script @@ compile_string "(define (f) 42) (define (f) 30)")
 175
 176 test closure =
 177     assert_equal
 178       (toplevel [NewFunction (inner [] [NewFunction (inner [] [GetLex (qname "x")])]);
 179                  GetScopeObject 0;
 180                  Swap;
 181                  SetProperty (qname "f")])
 182       (generate_script @@ compile_string "(define (f) (lambda () x))")
 183
 184 (* function call *)
 185 test call =
 186   assert_equal
 187     (expr [NewFunction (inner [] [PushByte 42]) ])
 188     (compile (Lambda ([],Block [Int 42])))
 189
 190 test call_with_args =
 191   assert_equal
 192     (expr [NewFunction (inner [0;0] [GetLocal 2])])
 193     (compile (Lambda (["x";"y"],Block [Var "y"])))
 194
 195 test closure_lambda =
 196   assert_equal
 197     (expr [PushString "z"; PushByte 42;
 198            NewObject 1;
 199            PushWith;
 200            NewFunction (inner [] [GetLex (qname "z")]);
 201            PopScope])
 202     (compile (Let (["z",Int 42],
 203                    Lambda ([],Block [Var "z"]))))
 204
 205
 206 test new_ =
 207   assert_equal
 208     (expr [FindPropStrict (make_qname "Foo");ConstructProp (make_qname "Foo",0)])
 209     (generate_script @@ compile_string "(new Foo)")
 210
 211 test new_ =
 212   assert_equal
 213     (expr [FindPropStrict (make_qname "Foo");PushByte 42;ConstructProp (make_qname "Foo",1)])
 214     (generate_script @@ compile_string "(new Foo 42)")
 215
 216 test invoke =
 217   assert_equal
 218     (expr [GetLex (make_qname "x");PushByte 10;CallProperty (make_qname "foo",1)])
 219     (generate_script @@ compile_string "(. x (foo 10))")
 220
 221 test slotref =
 222   assert_equal
 223     (expr [GetLex (make_qname "obj");GetProperty (make_qname "x")])
 224     (generate_script @@ compile_string "(slot-ref obj x)")
 225
 226 test slotsef =
 227   assert_equal
 228     (expr [PushByte 42;
 229            GetLex (make_qname "obj");
 230            Swap;
 231            SetProperty (make_qname "x");
 232            PushUndefined])
 233     (generate_script @@ compile_string "(slot-set! obj x 42)")
 234
 235
 236 let new_class klass =
 237   (toplevel [
 238      GetLex klass.Asm.sname;
 239      PushScope;
 240      GetLex klass.Asm.sname;
 241      NewClass klass;
 242      PopScope;
 243      GetGlobalScope;
 244      Swap;
 245      InitProperty klass.Asm.cname])
 246
 247 let prefix= [GetLocal_0;
 248              ConstructSuper 0]
 249
 250 let init =
 251   {Asm.empty_method with
 252      name =
 253       make_qname "init";
 254      fun_scope =
 255       Asm.Class (make_qname "Foo");
 256      instructions =
 257       prefix @ [ReturnVoid] }
 258
 259 let cinit =
 260   {Asm.empty_method with
 261      name =
 262       make_qname "cinit";
 263      fun_scope =
 264       Asm.Class (make_qname "Foo");
 265      instructions =
 266       [ReturnVoid] }
 267
 268 test klass =
 269     assert_equal
 270       (new_class
 271          {Asm.cname = make_qname "Foo";
 272           sname     = make_qname "Object";
 273           flags_k   = [Asm.Sealed];
 274           attributes = [];
 275           cinit     = cinit;
 276           iinit     = {init with
 277                          instructions = prefix@[PushByte 10;Pop]@[ReturnVoid] };
 278           interface = [];
 279           methods   = []})
 280       (generate_script @@ compile_string
 281          "(define-class Foo (Object) ())
 282           (define-method init ((self Foo)) 10)")
 283
 284 test klass_empty =
 285     assert_equal
 286       (new_class
 287          {Asm.cname = make_qname "Foo";
 288           sname     = make_qname "Object";
 289           flags_k   = [Asm.Sealed];
 290           attributes = [];
 291           cinit     = cinit;
 292           iinit     = init;
 293           interface = [];
 294           methods   = []})
 295       (generate_script @@ compile_string "(define-class Foo (Object) ())")
 296
 297 test klass_f =
 298     assert_equal
 299       (new_class
 300          {Asm.cname = make_qname "Foo";
 301           sname     = make_qname "Object";
 302           flags_k   = [Asm.Sealed];
 303           attributes = [];
 304           cinit     = cinit;
 305           iinit     = init;
 306           interface = [];
 307           methods   = [{ Asm.empty_method with
 308                            name = make_qname "f";
 309                            fun_scope = Asm.Class (make_qname "Foo");
 310                            instructions = [PushByte 42;ReturnValue] }]})
 311       (generate_script @@ compile_string
 312          "(define-class Foo (Object) ())
 313           (define-method f ((self Foo)) 42)")
 314
 315 test klass_with_ns =
 316       let make ns x =
 317         QName ((Namespace ns),x) in
 318         assert_equal
 319           (new_class
 320              {Asm.cname =
 321                  make_qname "Foo";
 322               sname =
 323                  make "flash.text" "Object";
 324               flags_k =
 325                  [Asm.Sealed];
 326               attributes =
 327                  [];
 328               cinit =
 329                  cinit;
 330               iinit =
 331                  {init with
 332                     instructions = prefix @ [PushByte 42; Pop; ReturnVoid]};
 333               interface = [];
 334               methods   = []})
 335           (generate_script @@ compile_string
 336              "(define-class Foo (flash.text.Object) ())
 337               (define-method init ((self Foo))  42)")
 338
 339 test klass_args =
 340     assert_equal
 341       (new_class
 342          {Asm.cname = make_qname "Foo";
 343           sname     = make_qname "Object";
 344           flags_k   = [Asm.Sealed];
 345           attributes = [];
 346           cinit     = cinit;
 347           iinit     = {init with
 348                          params = [0];
 349                          instructions = List.concat [
 350                            prefix;
 351                            [GetLocal 1; Pop;ReturnVoid] ] };
 352           interface = [];
 353           methods   = []})
 354       (generate_script @@ compile_string
 355          "(define-class Foo (Object) ())
 356           (define-method init ((self Foo) x) x)")
 357
 358 test klass_self =
 359     assert_equal
 360       (new_class
 361          {Asm.cname = make_qname "Foo";
 362           sname     = make_qname "Object";
 363           flags_k   = [Asm.Sealed];
 364           attributes = [];
 365           cinit     = cinit;
 366           iinit     = {init with
 367                          instructions = prefix @ [GetLocal 0;Pop;ReturnVoid] };
 368           interface = [];
 369           methods   = []})
 370       (generate_script @@ compile_string
 371          "(define-class Foo (Object) ())
 372           (define-method init ((self Foo)) self)")
 373
 374
 375 test klass_f_args =
 376     assert_equal
 377       (new_class
 378          {Asm.cname = make_qname "Foo";
 379           sname     = make_qname "Object";
 380           flags_k   = [Asm.Sealed];
 381           cinit     = cinit;
 382           iinit     = init;
 383           interface = [];
 384           attributes = [];
 385           methods   = [{Asm.empty_method with
 386                           name =
 387                            make_qname "f";
 388                           fun_scope =
 389                            Asm.Class (make_qname "Foo");
 390                           params =
 391                            [0];
 392                           instructions =
 393                            [GetLocal 1;ReturnValue] }]})
 394       (generate_script @@ compile_string "(define-class Foo (Object) ())
 395  (define-method f ((self Foo) x) x)")
 396
 397 test klass_attr =
 398     assert_equal
 399       (new_class
 400          {Asm.cname = make_qname "Foo";
 401           sname     = make_qname "Object";
 402           flags_k   = [Asm.Sealed];
 403           cinit     = cinit;
 404           iinit     = init;
 405           interface = [];
 406           attributes = [Cpool.make_qname "x";Cpool.make_qname "y"];
 407           methods   = []})
 408       (generate_script @@ compile_string "(define-class Foo (Object) (x y))")