scm/test/codegen/bindingTest.ml

   1 open Base
   2 open Ast
   3 open Override
   4 open AstUtil
   5 open OUnit
   6 open Binding
   7
   8 let ok x y =
   9   assert_equal ~printer:Std.dump x (snd @@ Binding.of_module y)
  10
  11 let member scope ns name =
  12   Node.ghost @@ Member (scope,(ns,name))
  13 let slot scope i =
  14   Node.ghost @@ Slot (scope,i)
  15 let register n =
  16   Node.ghost @@ Register n
  17
  18 let class_  meths =
  19   AstUtil.class_ (`Public (qname [] "Foo")) (qname [] "Object") [] meths
  20
  21 (*
  22   type bind =
  23   Register of int
  24   | Slot of scope * int
  25   | Member of scope * name
  26 *)
  27 let _ =
  28   ("binding.ml" >::: [
  29      "let" >::
  30        (fun () ->
  31           ok [expr @@ let_ ["x", int 42] @@
  32                 `BindVar (member (Scope 1) [] "x")]
  33             [expr @@ let_ ["x", int 42] @@
  34                var [] "x"];
  35           ok [expr @@ let_ ["x", var [] "x"] @@
  36                 block []]
  37             [expr @@ let_ ["x", var [] "x"] @@
  38                block []];
  39           ok [expr @@ let_ ["x", int 42] @@
  40                 let_  ["x",int 42] @@
  41                 `BindVar (member (Scope 2) [] "x")]
  42             [expr @@ let_ ["x", int 42] @@
  43                let_  ["x",int 42] @@
  44                var [] "x"]);
  45      "letrec" >::
  46        (fun () ->
  47           ok [expr @@ let_rec ["x", int 42] @@
  48                 `BindVar (member (Scope 1) [] "x")]
  49             [expr @@ let_rec ["x", int 42] @@
  50                var [] "x"];
  51           (* note! *)
  52           ok [expr @@ let_rec ["x", `BindVar (member (Scope 1) [] "x")] @@
  53                 block []]
  54             [expr @@ let_rec ["x", var [] "x"] @@
  55                block []];
  56           ok [expr @@ let_rec ["x", int 42] @@
  57                 let_rec  ["x",int 42] @@
  58                 `BindVar (member (Scope 2) [] "x")]
  59             [expr @@ let_rec ["x", int 42] @@
  60                let_rec  ["x",int 42] @@
  61                var [] "x"]);
  62      "lambda" >::
  63        (fun () ->
  64           ok [expr @@ lambda [] @@ var [] "x"]
  65             [expr @@ lambda [] @@ var [] "x"];
  66           ok [expr @@ lambda ["x"] @@ `BindVar (register 1)]
  67             [expr @@ lambda ["x"] @@ var [] "x"];
  68           ok [expr @@ lambda ["x";"y"] @@ `BindVar (register 2)]
  69             [expr @@ lambda ["x";"y"] @@ var [] "y"]);
  70      "method" >::
  71        (fun () ->
  72           ok [class_ [public_meth "f" [] @@ var [] "x"]]
  73              [class_ [public_meth "f" [] @@ var [] "x"]];
  74           ok [class_ [public_meth "f" ["x"] @@ `BindVar (register 0)]]
  75              [class_ [public_meth "f" ["x"] @@ var [] "x"]]);
  76      "define" >::
  77        (fun () ->
  78           ok [`ReDefine (`Public (qname [] "x"),0,int 42);
  79               expr @@ `BindVar (slot Global 1)]
  80             [`Define (`Public (qname [] "x"),int 42);
  81              expr @@ var [] "x"]);
  82      "multiple-define" >::
  83        (fun () ->
  84           ok [`ReDefine (`Public (qname [] "x"),0,int 42);
  85               `ReDefine (`Public (qname [] "x"),0,int 42);
  86               expr @@ `BindVar (slot Global 1)]
  87             [`Define (`Public (qname [] "x"),int 42);
  88              `Define (`Public (qname [] "x"),int 42);
  89              expr @@ var [] "x"]);
  90      "class" >::
  91        (fun () ->
  92           ok [class_ [];
  93              expr @@ `BindVar (member Global [] "Foo")]
  94             [class_ [];
  95              expr @@ var [] "Foo"]);
  96    ]) +> run_test_tt
  97