test/astUtil.ml

   1 open Base
   2 open Ast
   3 open ClosTrans
   4 open Node
   5
   6 let eq_ident {value = x} {value = y} =
   7   x = y
   8
   9 let rec eq_expr a b =
  10   match a,b with
  11       `Int    {value = x}, `Int {value = y} ->
  12         x = y
  13     | `String {value = x}, `String {value = y} ->
  14         x = y
  15     | `Bool   {value = x}, `Bool {value = y} ->
  16         x = y
  17     | `Float  {value = x}, `Float {value = y} ->
  18         x = y
  19     | `Var    {value = x}, `Var {value = y} ->
  20         x = y
  21     | `Lambda (args,expr), `Lambda (args',expr') ->
  22         (List.for_all2 eq_ident args args') && eq_expr expr expr'
  23     | `Call   args, `Call args' ->
  24         List.for_all2 eq_expr args args'
  25     | `If  (a,b,c), `If (a',b',c') ->
  26         List.for_all2 eq_expr [a;b;c] [a';b';c']
  27     | `Let (decls,body), `Let (decls',body')
  28     | `LetRec (decls,body), `LetRec (decls',body')  ->
  29         let b =
  30           List.for_all2
  31             (fun (v,e) (v',e') -> eq_ident v v' && eq_expr e e')
  32             decls' decls' in
  33           b && eq_expr body body'
  34     | `Block xs, `Block xs' ->
  35         List.for_all2 eq_expr xs xs'
  36     | `New ({value=name},args), `New ({value=name'},args') ->
  37         name = name' && HList.conj @@ List.map2 eq_expr args args'
  38     | `Invoke (obj,name,args), `Invoke (obj',name',args') ->
  39         eq_expr obj obj' && eq_ident name name' &&
  40           List.for_all2 eq_expr args args'
  41     | `SlotRef (obj,name), `SlotRef (obj',name') ->
  42         eq_expr obj obj' && eq_ident name name'
  43     | `SlotSet (obj,name,value), `SlotSet (obj',name',value') ->
  44         eq_expr obj obj' && eq_ident name name' && eq_expr value' value'
  45     | _ ->
  46         false
  47
  48 let eq_method (name,args,body) (name',args',body') =
  49   eq_ident name name' &&
  50     (List.for_all2 eq_ident args args') &&
  51     eq_expr body body'
  52
  53 let eq_stmt a b =
  54   match a,b with
  55       `Define (name,body), `Define (name',body') ->
  56         eq_ident name name' && eq_expr body body'
  57     | `Expr expr, `Expr expr' ->
  58         eq_expr expr expr'
  59     | `Class (name,{value=super},attrs,methods),
  60         `Class (name',{value=super'},attrs',methods') ->
  61         eq_ident name name' &&
  62           super = super' &&
  63           (List.for_all2 eq_ident attrs attrs') &&
  64           (List.for_all2 eq_method methods methods')
  65     | _ ->
  66         false
  67
  68 let eq_clos a b =
  69   match a,b with
  70       `DefineClass (name,{value=super},attrs), `DefineClass (name',{value=super'},attrs') ->
  71         eq_ident name name' &&
  72           super = super' && List.for_all2 eq_ident attrs attrs'
  73     | `DefineMethod (name,(self,obj),args,body), `DefineMethod (name',(self',obj'),args',body') ->
  74         eq_ident name name' &&
  75           eq_ident self self' &&
  76           eq_ident obj obj' &&
  77           (List.for_all2 eq_ident args args') &&
  78           eq_expr body body'
  79     | a,b ->
  80         eq_stmt a b
  81
  82