src/closTrans.ml

   1 open Base
   2
   3 type stmt =
   4     Plain of Ast.stmt
   5   | DefineClass  of string * Ast.name * string list
   6   | DefineMethod of string * (string * string) * string list * Ast.expr
   7
   8 type program = stmt list
   9
  10 module Set = Core.Std.Set
  11 type 'a set = 'a Set.t
  12
  13 let set_of_list xs =
  14   List.fold_left (flip Set.add) Set.empty xs
  15
  16 (*
  17   Features:
  18   - convert DefineClass & DefineMethod to Ast.Class
  19   - convert Ast.Call to Ast.Invoke
  20 *)
  21
  22 let methods_table program =
  23   let tbl =
  24     Hashtbl.create 16 in
  25     program +> List.iter
  26       (function
  27            DefineMethod (name,(self,klass),args,body) ->
  28              Hashtbl.add tbl klass (name,self::args,body)
  29          | _ ->
  30              ());
  31     tbl
  32
  33 let methods_set program =
  34   set_of_list @@ HList.concat_map
  35     (function
  36          DefineMethod (name,_,_,_) ->
  37            [name]
  38        | _ ->
  39            []) program
  40
  41 let expr_trans set =
  42   function
  43       Ast.Call ((Ast.Var f)::obj::args) when Set.mem f set ->
  44         Ast.Invoke (obj,f,args)
  45     | e ->
  46         e
  47
  48 let stmt_trans tbl set =
  49   function
  50       Plain stmt ->
  51         [Ast.lift_stmt (expr_trans set) stmt]
  52     | DefineClass (klass,super,_) ->
  53         [Ast.Class (klass,super,Hashtbl.find_all tbl klass)]
  54     | DefineMethod _ ->
  55         []
  56
  57 let trans program =
  58   let tbl =
  59     methods_table program in
  60   let methods =
  61     methods_set   program in
  62     program +>  HList.concat_map (stmt_trans tbl methods)
  63
  64 let to_string =
  65   function
  66       Plain stmt ->
  67         Ast.to_string_stmt stmt
  68     | DefineClass (name,(ns,super),attrs) ->
  69         Printf.sprintf "Class (%s,%s::%s,%s)"
  70           name
  71           ns super @@
  72           string_of_list attrs
  73     | DefineMethod (f,(self,klass),args,body) ->
  74         Printf.sprintf "Metod (%s,((%s %s) %s),%s)"
  75           f self klass (string_of_list args) (Ast.to_string body)
  76