scm/test/codegen/codegenExprTest.ml

   1 open Base
   2 open Asm
   3 open Codegen
   4 open OUnit
   5 open Binding
   6 open AstUtil
   7
   8 let join xs =
   9   String.concat "." xs
  10
  11 let qname ns x =
  12   `QName ((`Namespace (join ns)),x)
  13
  14 let ok expect actual =
  15   assert_equal (expect@[ `Pop ]) @@
  16     generate_program [`Expr actual]
  17
  18 let member i ns name =
  19   `BindVar (Node.ghost (Member ((Scope i),(ns,name))))
  20
  21 let global_member ns name =
  22   `BindVar (Node.ghost (Member (Global,(ns,name))))
  23
  24 let slot i j =
  25   `BindVar (Node.ghost (Slot ((Scope i),j)))
  26
  27 let register i =
  28   `BindVar (Node.ghost (Register i))
  29
  30 let inner args inst =
  31   let l = Label.peek 0 in
  32     {Asm.empty_method with
  33        method_name  = qname [] @@ Label.to_string l;
  34        params       = args;
  35        instructions = inst@[`ReturnValue] }
  36
  37 let _ =
  38   ("codegen.ml(expr)" >::: [
  39      "literal" >::: [
  40        "int" >::
  41          (fun () ->
  42             ok [`PushByte 42] (int 42));
  43        "int(big)" >::
  44          (fun () ->
  45             ok [`PushInt 200] (int 200);
  46             ok [`PushInt 300] (int 300));
  47        "string" >::
  48          (fun () ->
  49             ok [`PushString "Thanks for All the Fish"] @@
  50               string "Thanks for All the Fish");
  51        "float" >::
  52          (fun () ->
  53             ok [`PushDouble 4.2] @@
  54               float 4.2);
  55        "bool" >::
  56          (fun () ->
  57             ok [`PushTrue] @@
  58               bool true;
  59             ok [`PushFalse] @@
  60               bool false);
  61        "array" >::
  62          (fun () ->
  63             ok [`NewArray 0] (`Array []);
  64             ok [`PushByte 1; `PushByte 2; `NewArray 2] (`Array [int 1; int 2]););
  65      ];
  66      "if" >::
  67        (fun () ->
  68           let a =
  69             Label.peek 0 in
  70           let b =
  71             Label.peek 1 in
  72             ok
  73               [`PushByte 10;
  74                `PushByte 20;
  75                `IfNe a;  `PushByte 0; `Coerce_a; `Jump b;
  76                `Label a; `PushByte 1; `Coerce_a; `Label b] @@
  77               if_ (call [var [] "="; int 10; int 20]) (int 0) (int 1));
  78      "if" >::
  79        (fun () ->
  80           List.iter
  81             (fun (sym,op) ->
  82                let a =
  83                  Label.peek 0 in
  84                let b =
  85                  Label.peek 1 in
  86                  ok
  87                    [`PushByte 10;
  88                     `PushByte 20;
  89                     op a;  `PushByte 0; `Coerce_a; `Jump b;
  90                     `Label a; `PushByte 1; `Coerce_a; `Label b] @@
  91                    if_ (call [var [] sym; int 10; int 20]) (int 0) (int 1))
  92             [("=" ,fun x -> `IfNe x);
  93              ("<=",fun x -> `IfNle x);
  94              (">" ,fun x -> `IfNgt x);
  95              (">=",fun x -> `IfNge x); ]);
  96      "block" >::
  97        (fun () ->
  98           ok [`PushByte 1; `Pop; `PushByte 2] @@
  99             block [int 1;int 2]);
 100      "empty block" >::
 101        (fun () ->
 102           ok [`PushUndefined] @@
 103             block []);
 104      "let" >::
 105        (fun () ->
 106           ok [`PushString "x"; `PushByte 1;
 107               `PushString "y"; `PushByte 2;
 108               `NewObject 2;
 109               `PushWith;
 110               `PushUndefined;
 111               `PopScope] @@
 112             let_ ["x",int 1; "y",int 2] @@ block []);
 113      "letrec" >::
 114        (fun () ->
 115           ok [`NewObject 0;
 116               `Dup;
 117               `PushWith;
 118               `Dup;
 119               `PushByte 42;
 120               `SetProperty (qname [] "x");
 121               `Pop;
 122               `PushUndefined;
 123               `PopScope] @@
 124             let_rec ["x",int 42] @@ block []);
 125      "lambda" >::
 126        (fun () ->
 127           let m =
 128             inner [] [`GetLex (qname [] "z")] in
 129             ok  [`NewFunction m] @@
 130               lambda [] @@ block [var [] "z"]);
 131      "var" >::: [
 132        "member" >::
 133          (fun () ->
 134             ok [`GetScopeObject 1;
 135                 `GetProperty (qname [] "foo")] @@
 136               member 1 [] "foo";
 137             ok [`GetScopeObject 1;
 138                 `GetProperty (qname [] "bar")] @@
 139               member 1 [] "bar");
 140        "global" >::
 141          (fun () ->
 142             ok [`GetGlobalScope;
 143                 `GetProperty (qname [] "foo")] @@
 144               global_member [] "foo");
 145        "slot" >::
 146          (fun () ->
 147             ok [`GetScopeObject 0;
 148                 `GetSlot 1] @@
 149               slot 0 1);
 150        "register" >::
 151          (fun () ->
 152             ok [`GetLocal 0] @@
 153               register 0;
 154             ok [`GetLocal 1] @@
 155               register 1)
 156      ];
 157      "call" >::: [
 158        "var" >::
 159          (fun () ->
 160             ok [`FindPropStrict (qname [] "print");
 161                 `PushString "Hello";
 162                 `CallPropLex ((qname [] "print"),1)] @@
 163               call [var [] "print"; string "Hello"]);
 164        "member" >::
 165          (fun () ->
 166             ok  [`GetScopeObject 1;
 167                  `PushByte 42;
 168                  `CallPropLex ((qname [] "f"),1)] @@
 169               call [member 1 [] "f"; int 42]);
 170        "global member" >::
 171          (fun () ->
 172             ok  [`GetGlobalScope;
 173                  `PushByte 42;
 174                  `CallPropLex ((qname [] "f"),1)] @@
 175               call [global_member [] "f"; int 42]);
 176        "bulid-in" >::
 177          (fun () ->
 178             ok [`PushByte 1; `PushByte 2; `Add_i] @@
 179               call [var [] "+";int 1;int 2];
 180             ok [`PushByte 1; `PushByte 2; `Equals] @@
 181               call [var [] "=";int 1;int 2])
 182      ];
 183    ]) +> run_test_tt
 184
 185