| 1 | open Printf |
| 2 | |
| 3 | module List = ListLabels |
| 4 | module String = StringLabels |
| 5 | |
| 6 | module Sym = Tiger_symbol |
| 7 | module Pos = Tiger_position |
| 8 | |
| 9 | module Indent : sig |
| 10 | type t |
| 11 | val init : enabled:bool -> unit:string -> t |
| 12 | val next : t -> t |
| 13 | val to_string : t -> string |
| 14 | end = struct |
| 15 | type t = |
| 16 | { unit : string option |
| 17 | ; levels : int |
| 18 | } |
| 19 | |
| 20 | let init ~enabled ~unit = |
| 21 | { unit = if enabled then Some unit else None |
| 22 | ; levels = 0 |
| 23 | } |
| 24 | |
| 25 | let next t = |
| 26 | {t with levels = succ t.levels} |
| 27 | |
| 28 | let to_string = function |
| 29 | | {unit=None; _} -> |
| 30 | "" |
| 31 | | {unit=Some u; levels} -> |
| 32 | let rec add = function |
| 33 | | 0 -> "" |
| 34 | | n -> u ^ (add (pred n)) |
| 35 | in |
| 36 | "\n" ^ (add levels) |
| 37 | end |
| 38 | |
| 39 | type oper = |
| 40 | | PlusOp |
| 41 | | MinusOp |
| 42 | | TimesOp |
| 43 | | DivideOp |
| 44 | | EqOp |
| 45 | | NeqOp |
| 46 | | LtOp |
| 47 | | LeOp |
| 48 | | GtOp |
| 49 | | GeOp |
| 50 | |
| 51 | type exp = |
| 52 | | NilExp |
| 53 | | IntExp of |
| 54 | int |
| 55 | | StringExp of |
| 56 | { string : string |
| 57 | ; pos : Pos.t |
| 58 | } |
| 59 | | CallExp of |
| 60 | { func : Sym.t |
| 61 | ; args : exp list |
| 62 | ; pos : Pos.t |
| 63 | } |
| 64 | | OpExp of |
| 65 | { left : exp |
| 66 | ; oper : oper |
| 67 | ; right : exp |
| 68 | ; pos : Pos.t |
| 69 | } |
| 70 | | RecordExp of |
| 71 | { fields : (Sym.t * exp * Pos.t) list |
| 72 | ; typ : Sym.t |
| 73 | ; pos : Pos.t |
| 74 | } |
| 75 | | SeqExp of |
| 76 | (exp * Pos.t) list |
| 77 | | AssignExp of |
| 78 | { var : var |
| 79 | ; exp : exp |
| 80 | ; pos : Pos.t |
| 81 | } |
| 82 | | IfExp of |
| 83 | { test : exp |
| 84 | ; then' : exp |
| 85 | ; else' : exp option |
| 86 | ; pos : Pos.t |
| 87 | } |
| 88 | | WhileExp of |
| 89 | { test : exp |
| 90 | ; body : exp |
| 91 | ; pos : Pos.t |
| 92 | } |
| 93 | | ForExp of |
| 94 | { var : Sym.t |
| 95 | ; escape : bool ref (* Whoa - why a mutable cell in AST? *) |
| 96 | ; lo : exp |
| 97 | ; hi : exp |
| 98 | ; body : exp |
| 99 | ; pos : Pos.t |
| 100 | } |
| 101 | | BreakExp of |
| 102 | Pos.t |
| 103 | | LetExp of |
| 104 | { decs : dec list |
| 105 | ; body : exp |
| 106 | ; pos : Pos.t |
| 107 | } |
| 108 | | ArrayExp of |
| 109 | { typ : Sym.t |
| 110 | ; size : exp |
| 111 | ; init : exp |
| 112 | ; pos : Pos.t |
| 113 | } |
| 114 | | VarExp of |
| 115 | var |
| 116 | and var = |
| 117 | | SimpleVar of |
| 118 | { symbol : Sym.t |
| 119 | ; pos : Pos.t |
| 120 | } |
| 121 | | FieldVar of |
| 122 | { var : var |
| 123 | ; symbol : Sym.t |
| 124 | ; pos : Pos.t |
| 125 | } |
| 126 | | SubscriptVar of |
| 127 | { var : var |
| 128 | ; exp : exp |
| 129 | ; pos : Pos.t |
| 130 | } |
| 131 | and dec = |
| 132 | | FunDecs of (* "FunctionDec" in Appel's code *) |
| 133 | fundec list |
| 134 | | VarDec of |
| 135 | { name : Sym.t |
| 136 | ; escape : bool ref (* Again, why mutable? *) |
| 137 | ; typ : (Sym.t * Pos.t) option |
| 138 | ; init : exp |
| 139 | ; pos : Pos.t |
| 140 | } |
| 141 | | TypeDecs of (* "TypeDec" in Appel's code *) |
| 142 | typedec list |
| 143 | and ty = |
| 144 | | NameTy of |
| 145 | { symbol : Sym.t |
| 146 | ; pos : Pos.t |
| 147 | } |
| 148 | | RecordTy of |
| 149 | field list |
| 150 | | ArrayTy of |
| 151 | { symbol : Sym.t |
| 152 | ; pos : Pos.t |
| 153 | } |
| 154 | and field = |
| 155 | | Field of |
| 156 | { name : Sym.t |
| 157 | ; escape : bool ref |
| 158 | ; typ : Sym.t |
| 159 | ; pos : Pos.t |
| 160 | } |
| 161 | and typedec = |
| 162 | | TypeDec of (* An anonymous record in Appel's code *) |
| 163 | { name : Sym.t |
| 164 | ; ty : ty |
| 165 | ; pos : Pos.t |
| 166 | } |
| 167 | and fundec = |
| 168 | | FunDec of |
| 169 | { name : Sym.t |
| 170 | ; params : field list |
| 171 | ; result : (Sym.t * Pos.t) option |
| 172 | ; body : exp |
| 173 | ; pos : Pos.t |
| 174 | } |
| 175 | |
| 176 | type t = exp |
| 177 | |
| 178 | let op_to_string op = |
| 179 | match op with |
| 180 | | PlusOp -> "PlusOp" |
| 181 | | MinusOp -> "MinusOp" |
| 182 | | TimesOp -> "TimesOp" |
| 183 | | DivideOp -> "DivideOp" |
| 184 | | EqOp -> "EqOp" |
| 185 | | NeqOp -> "NeqOp" |
| 186 | | LtOp -> "LtOp" |
| 187 | | LeOp -> "LeOp" |
| 188 | | GtOp -> "GtOp" |
| 189 | | GeOp -> "GeOp" |
| 190 | |
| 191 | let xs_to_string ?(sep=",") ~f ~indent xs = |
| 192 | let i = Indent.to_string indent in |
| 193 | xs |> List.map ~f:(fun x -> i ^ (f x)) |> String.concat ~sep |
| 194 | |
| 195 | let mexp name params ~indent = |
| 196 | let params = xs_to_string ~f:(fun x -> x) ~indent params in |
| 197 | sprintf "%s[%s]" name params |
| 198 | |
| 199 | let field_to_string ~indent (Field {name; typ; _}) = |
| 200 | let name = Sym.to_string name in |
| 201 | let typ = Sym.to_string typ in |
| 202 | let indent = Indent.to_string indent in |
| 203 | sprintf "%s%s : %s" indent name typ |
| 204 | |
| 205 | let fields_to_string fields ~indent = |
| 206 | let fields = List.map fields ~f:(field_to_string ~indent) in |
| 207 | mexp "" fields ~indent |
| 208 | |
| 209 | let rec exp_to_string ~indent exp = |
| 210 | let indent = Indent.next indent in |
| 211 | let mexp = mexp ~indent in |
| 212 | (match exp with |
| 213 | | NilExp -> |
| 214 | mexp "NilExp" [] |
| 215 | | IntExp i -> |
| 216 | mexp "IntExp" [(string_of_int i)] |
| 217 | | StringExp {string; _} -> |
| 218 | mexp "StringExp" [sprintf "%S" string] |
| 219 | | CallExp {func; args; _} -> |
| 220 | let func = Sym.to_string func in |
| 221 | let args = List.map args ~f:(exp_to_string ~indent) in |
| 222 | mexp "CallExp" [func; mexp "" args] |
| 223 | | OpExp {left; oper; right; _} -> |
| 224 | let op_exp = |
| 225 | let indent = Indent.next indent in |
| 226 | let oper = op_to_string oper in |
| 227 | let left = exp_to_string ~indent left in |
| 228 | let right = exp_to_string ~indent right in |
| 229 | mexp oper [left; right] |
| 230 | in |
| 231 | mexp "OpExp" [op_exp] |
| 232 | | RecordExp {fields; typ; _} -> |
| 233 | let fields = |
| 234 | List.map fields ~f:(fun (sym, exp, _) -> |
| 235 | sprintf |
| 236 | "%s = %s" |
| 237 | (Sym.to_string sym) |
| 238 | (exp_to_string ~indent exp) |
| 239 | ) |
| 240 | in |
| 241 | let typ = Sym.to_string typ in |
| 242 | mexp "RecordExp" [typ; mexp "" fields] |
| 243 | | SeqExp exps -> |
| 244 | exps |
| 245 | |> List.map ~f:(fun (e, _) -> exp_to_string e ~indent) |
| 246 | |> mexp "SeqExp" |
| 247 | | AssignExp {var; exp; _} -> |
| 248 | let var = var_to_string ~indent var in |
| 249 | let exp = exp_to_string ~indent exp in |
| 250 | mexp "AssignExp" [var; exp] |
| 251 | | IfExp {test; then'; else'; _} -> |
| 252 | let test = exp_to_string ~indent test in |
| 253 | let then' = exp_to_string ~indent then' in |
| 254 | (match else' with |
| 255 | | None -> |
| 256 | mexp "IfThen" [test; then'] |
| 257 | | Some e -> |
| 258 | mexp "IfThenElse" [test; then'; (exp_to_string ~indent e)] |
| 259 | ) |
| 260 | | WhileExp {test; body; _} -> |
| 261 | let test = exp_to_string ~indent test in |
| 262 | let body = exp_to_string ~indent body in |
| 263 | mexp "WhileExp" [test; body] |
| 264 | | ForExp {var; lo; hi; body; _} -> |
| 265 | mexp "ForExp" |
| 266 | [ (Sym.to_string var) |
| 267 | ; (exp_to_string ~indent lo) |
| 268 | ; (exp_to_string ~indent hi) |
| 269 | ; (exp_to_string ~indent body) |
| 270 | ] |
| 271 | | BreakExp _ -> |
| 272 | mexp "BreakExp" [] |
| 273 | | LetExp {decs; body; _} -> |
| 274 | let decs = List.map decs ~f:(dec_to_string ~indent) in |
| 275 | let body = exp_to_string ~indent body in |
| 276 | mexp "LetExp" [mexp "" decs; body] |
| 277 | | ArrayExp {typ; size; init; _} -> |
| 278 | let typ = Sym.to_string typ in |
| 279 | let size = exp_to_string ~indent size in |
| 280 | let init = exp_to_string ~indent init in |
| 281 | mexp "ArrayExp" [typ; size; init] |
| 282 | | VarExp var -> |
| 283 | mexp "VarExp" [(var_to_string ~indent var)] |
| 284 | ) |
| 285 | and var_to_string ~indent var = |
| 286 | let indent = Indent.next indent in |
| 287 | let mexp = mexp ~indent in |
| 288 | match var with |
| 289 | | SimpleVar {symbol; _} -> |
| 290 | mexp "SimpleVar" [(Sym.to_string symbol)] |
| 291 | | FieldVar {var; symbol; _} -> |
| 292 | mexp "FieldVar" |
| 293 | [ (var_to_string ~indent var) |
| 294 | ; (Sym.to_string symbol) |
| 295 | ] |
| 296 | | SubscriptVar {var; exp; _} -> |
| 297 | mexp "SubscriptVar[%s]" |
| 298 | [ (var_to_string ~indent var) |
| 299 | ; (exp_to_string ~indent exp) |
| 300 | ] |
| 301 | and dec_to_string ~indent dec = |
| 302 | let indent = Indent.next indent in |
| 303 | let mexp = mexp ~indent in |
| 304 | match dec with |
| 305 | | VarDec {name; typ; init; _} -> |
| 306 | let name = Sym.to_string name in |
| 307 | let init = exp_to_string ~indent init in |
| 308 | (match typ with |
| 309 | | Some (typ, _) -> |
| 310 | let typ = Sym.to_string typ in |
| 311 | mexp "VarDec" [name; typ; init] |
| 312 | | None -> |
| 313 | mexp "VarDec" [name; init] |
| 314 | ) |
| 315 | | TypeDecs type_decs -> |
| 316 | mexp "TypeDecs" |
| 317 | (List.map type_decs ~f:(type_dec_to_string ~indent)) |
| 318 | | FunDecs fun_decs -> |
| 319 | mexp "FunDecs" |
| 320 | (List.map fun_decs ~f:(fun_dec_to_string ~indent)) |
| 321 | and fun_dec_to_string ~indent fun_dec = |
| 322 | let indent = Indent.next indent in |
| 323 | let mexp = mexp ~indent in |
| 324 | match fun_dec with |
| 325 | | FunDec {name; params; body; _} -> |
| 326 | let name = Sym.to_string name in |
| 327 | let params = fields_to_string ~indent params in |
| 328 | let body = exp_to_string ~indent body in |
| 329 | mexp "FunDec" [name; params; body] |
| 330 | and type_dec_to_string ~indent type_dec = |
| 331 | let indent = Indent.next indent in |
| 332 | let mexp = mexp ~indent in |
| 333 | match type_dec with |
| 334 | | TypeDec {name; ty; _} -> |
| 335 | mexp "TypeDec" |
| 336 | [ (Sym.to_string name) |
| 337 | ; (ty_to_string ~indent ty) |
| 338 | ] |
| 339 | and ty_to_string ~indent ty = |
| 340 | let mexp = mexp ~indent in |
| 341 | match ty with |
| 342 | | NameTy {symbol; _} -> mexp "NameTy" [(Sym.to_string symbol)] |
| 343 | | ArrayTy {symbol; _} -> mexp "ArrayTy" [(Sym.to_string symbol)] |
| 344 | | RecordTy fields -> mexp "RecordTy" [(fields_to_string ~indent fields)] |
| 345 | |
| 346 | let to_string = |
| 347 | let unit = String.make 4 ' ' in |
| 348 | let indent = Indent.init ~enabled:true ~unit in |
| 349 | exp_to_string ~indent |