src/bindCheck.ml

   1 open Base
   2 open Node
   3
   4 let rec unzip_with f =
   5   function
   6       [] ->
   7         ([],[])
   8     | x::xs ->
   9         let (x,y) =
  10           f x in
  11         let (xs,ys) =
  12           unzip_with f xs in
  13           (x::xs,y::ys)
  14
  15
  16 type method_ = Ast.ident * Ast.ident list
  17
  18 type stmt =
  19     [ `ExternalClass of Ast.ident * Ast.name * Ast.attr list * method_ list
  20     | `External of Ast.ident
  21     | Ast.stmt]
  22
  23 type 'a info = 'a * 'a Node.t
  24 module VSet = Set.Make(struct
  25                          type t =  string Node.t
  26                          let compare {value=a} {value=b} = Pervasives.compare a b
  27                        end)
  28
  29 module CSet = Set.Make(struct
  30                          type t =  (string*string) Node.t
  31                          let compare {value=a} {value=b} = Pervasives.compare a b
  32                        end)
  33 module MSet = VSet
  34 type env = {
  35   var:   VSet.t;
  36   klass: CSet.t;
  37   meth:  MSet.t;
  38 }
  39
  40 let empty = {
  41   var  = VSet.empty;
  42   klass= CSet.empty;
  43   meth = MSet.empty;
  44 }
  45
  46 let (++)  {var=v1; klass=k1; meth=m1} {var=v2; klass=k2; meth=m2} = {
  47   var   = VSet.union v1 v2;
  48   klass = CSet.union k1 k2;
  49   meth  = MSet.union m1 m2;
  50 }
  51
  52 let (--) env xs = {
  53   env with
  54     var = List.fold_left (fun set x -> VSet.remove x set) env.var xs}
  55
  56 let union =
  57   List.fold_left (++) empty
  58
  59 let rec unbound_expr : Ast.expr -> env =
  60   function
  61       `Bool _ | `Float _ | `Int _ | `String _ ->
  62         empty
  63     | `Var node ->
  64         {empty with
  65            var = VSet.singleton (node)}
  66     | `Block xs | `Call xs ->
  67         union @@ List.map unbound_expr xs
  68     | `Let (decls,expr) ->
  69         let xs =
  70           union @@ List.map (unbound_expr$snd) decls in
  71         let vars =
  72           List.map fst decls in
  73         let ys =
  74           unbound_expr expr in
  75           xs ++ (ys -- vars)
  76     | `LetRec (decls,expr) ->
  77         let xs =
  78           union @@ List.map (unbound_expr$snd) decls in
  79         let vars =
  80           List.map fst decls in
  81         let ys =
  82           unbound_expr expr in
  83           (xs ++ ys) -- vars
  84     | `If (a,b,c) ->
  85         union @@ List.map unbound_expr [a;b;c]
  86     | `Lambda (args,body) ->
  87         unbound_expr body -- args
  88     | `Invoke (name,meth,args) ->
  89         let { meth = meths } as env' =
  90           unbound_expr name ++ union (List.map unbound_expr args) in
  91           {env' with
  92              meth = MSet.add meth meths}
  93     | `New (klass,args) ->
  94         let {klass=klasses} as env' =
  95           union @@ List.map unbound_expr args in
  96           {env' with
  97              klass = CSet.add klass klasses}
  98     | `SlotRef (obj,_) ->
  99         unbound_expr obj
 100     | `SlotSet (obj,_,value) ->
 101         unbound_expr obj ++ unbound_expr value
 102
 103 let unbound_stmt (stmt : stmt) env =
 104   match stmt with
 105       `Expr expr ->
 106         unbound_expr expr ++ env
 107     | `Define (name,expr) ->
 108         unbound_expr expr -- [name]
 109     | `External name ->
 110         env -- [name]
 111     | `Class (name,super,_,methods) ->
 112         let (ms,envs) =
 113           unzip_with
 114             (fun (name,args,expr) -> (name,unbound_expr expr -- args))
 115             methods in
 116         let {meth=meths; klass=klasses} as env' =
 117           union envs ++ env in
 118           {env' with
 119              meth  = List.fold_left (flip MSet.remove) meths ms;
 120              klass = CSet.remove {name with value=("",name.value)} klasses}
 121     | `ExternalClass (name,super,_,methods) ->
 122         let ms =
 123           List.map fst methods in
 124           {env with
 125              meth  = List.fold_left (flip MSet.remove) env.meth ms;
 126              klass = CSet.remove {name with value=("",name.value)} env.klass}
 127
 128 let unbound program =
 129   if List.fold_right unbound_stmt program empty = empty then
 130     Val true
 131   else
 132     Error false