src/ast2.ml

   1 open Base
   2
   3 (* name := namespace * symbol *)
   4 type name = (string * string) Node.t
   5 type ident = string Node.t
   6
   7 (* expression has no side-effect. *)
   8 type expr =
   9     Int of int Node.t
  10   | String of string Node.t
  11   | Bool   of bool Node.t
  12   | Float  of float Node.t
  13   | Var    of ident
  14   | Lambda of ident list * expr
  15   | Call   of expr list
  16   | If     of expr * expr * expr
  17   | Let    of (ident*expr) list * expr
  18   | LetRec of (ident*expr) list * expr
  19   | Block  of expr list
  20   | New    of name * expr list
  21   | Invoke of expr   * ident * expr list (* (invoke <object> <method-name> <arg1> <arg2>...)*)
  22   | SlotRef of expr * ident
  23   | SlotSet of expr * ident * expr
  24
  25 (* statement has side-effect *)
  26 type attr    = ident
  27 type method_ = ident * ident list * expr
  28 type stmt =
  29   | Define of ident * expr
  30   | Expr of expr
  31   | Class of ident * name * attr list * method_ list
  32
  33 type program = stmt list
  34
  35 let lift_stmt f =
  36   function
  37       Define (name,expr) ->
  38         Define (name,f expr)
  39     | Expr expr ->
  40         Expr (f expr)
  41     | Class (name,sname,attrs,body) ->
  42         let body' =
  43           List.map (Tuple.T3.map3 f) body in
  44           Class (name,sname,attrs,body')
  45
  46 let lift_program f = List.map (lift_stmt f)
  47
  48 let rec map f expr =
  49   let g =
  50     map f in
  51     match expr with
  52         Int _ | String _ | Bool _ | Float _ | Var _ ->
  53           f expr
  54       | Lambda (name,expr') ->
  55           f @@ Lambda (name,(g expr'))
  56       | Call exprs ->
  57           f @@ Call (List.map g exprs)
  58       | If (a,b,c) ->
  59           f @@ If ((g a),(g b),(g c))
  60       | Let (decl,body) ->
  61           let decl' =
  62             List.map (fun (a,b)->(a,g b)) decl in
  63           let body' =
  64             g body in
  65             f @@ Let (decl',body')
  66       | LetRec (decl,body) ->
  67           let decl' =
  68             List.map (fun (a,b)->(a,g b)) decl in
  69           let body' =
  70             g body in
  71             f @@ LetRec (decl',body')
  72       | Block exprs' ->
  73           f @@ Block (List.map g exprs')
  74       | New (name,args) ->
  75           f @@ New (name,List.map g args)
  76       | Invoke (obj,name,args) ->
  77           f @@ Invoke (g obj,name,List.map g args)
  78       | SlotRef (obj,name) ->
  79           f @@ SlotRef (g obj,name)
  80       | SlotSet (obj,name,value) ->
  81           f @@ SlotSet (g obj,name,g value)
  82
  83 let rec to_string =
  84   function
  85       Int n ->
  86         Node.to_string (Printf.sprintf "Int %d") n
  87     | String s ->
  88         Node.to_string (Printf.sprintf "String %s") s
  89     | Bool b ->
  90         Node.to_string
  91           (fun b -> if true then "Bool true" else "Bool false")
  92           b
  93     | Float d ->
  94         Node.to_string (Printf.sprintf "Float %f") d
  95     | Var n ->
  96         Node.to_string (Printf.sprintf "Var %s")  n
  97     | Lambda (args,expr') ->
  98         Printf.sprintf "Lambda (%s,%s)"
  99           (string_of_list @@ List.map (Node.to_string id) args)
 100           (to_string expr')
 101     | Call exprs ->
 102         Printf.sprintf "Call %s" @@
 103           string_of_list @@ List.map to_string exprs
 104     | If (a,b,c) ->
 105         Printf.sprintf "If (%s,%s,%s)"
 106           (to_string a) (to_string b) (to_string c)
 107     | Let (decl,body) ->
 108         let decl' =
 109           string_of_list @@
 110             List.map (fun (a,b)->
 111                         Printf.sprintf "(%s,%s)"
 112                           (Node.to_string id a)
 113                           (to_string b)) decl in
 114         let body' =
 115           to_string body in
 116           Printf.sprintf "Let (%s,%s)" decl' body'
 117     | LetRec (decl,body) ->
 118         let decl' =
 119           string_of_list @@
 120             List.map (fun (a,b)->
 121                         Printf.sprintf "(%s,%s)"
 122                           (Node.to_string id a)
 123                           (to_string b)) decl in
 124         let body' =
 125           to_string body in
 126           Printf.sprintf "LetRec (%s,%s)" decl' body'
 127     | Block exprs ->
 128         Printf.sprintf "Block %s" @@ string_of_list @@
 129           List.map to_string exprs
 130     | New (name,args) ->
 131         Printf.sprintf "New (%s,%s)"
 132           (Node.to_string (fun (a,b) -> a ^ ":" ^ b) name) @@
 133           string_of_list @@ List.map to_string args
 134     | Invoke (obj,name,args) ->
 135         Printf.sprintf "Invoke (%s,%s,%s)"
 136           (to_string obj)
 137           (Node.to_string id name) @@
 138           string_of_list @@ List.map to_string args
 139     | SlotRef (obj,name) ->
 140         Printf.sprintf "SlotRef (%s,%s)"
 141           (to_string obj) @@ Node.to_string id name
 142     | SlotSet (obj,name,value) ->
 143         Printf.sprintf "SlotSet (%s,%s,%s)"
 144           (to_string obj)
 145           (Node.to_string id name)
 146           (to_string value)
 147
 148 let to_string_stmt =
 149   function
 150       Define (x,y) ->
 151         Printf.sprintf "Define (%s,%s)"
 152           (Node.to_string id x) @@
 153           to_string y
 154     | Expr x ->
 155         Printf.sprintf "Expr (%s)" (to_string x)
 156     | Class (name,sname,attrs,body) ->
 157         Printf.sprintf "Class (%s,%s,%s,%s)"
 158           (Node.to_string id name)
 159           (Node.to_string (fun (a,b) -> a ^ ":" ^ b) sname)
 160           (string_of_list @@ List.map (Node.to_string id) attrs)
 161         @@ String.concat "\n"
 162         @@ List.map (fun (name,args,expr) ->
 163                        Printf.sprintf "((%s %s) %s)"
 164                          (Node.to_string id name)
 165                          (String.concat " " @@
 166                             List.map (Node.to_string id) args)
 167                          (to_string expr))
 168           body