| 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 | (* For printing error messages *) |
| 179 | let op_show op = |
| 180 | match op with |
| 181 | | PlusOp -> "+" |
| 182 | | MinusOp -> "-" |
| 183 | | TimesOp -> "*" |
| 184 | | DivideOp -> "/" |
| 185 | | EqOp -> "=" |
| 186 | | NeqOp -> "<>" |
| 187 | | LtOp -> "<" |
| 188 | | LeOp -> "<=" |
| 189 | | GtOp -> ">" |
| 190 | | GeOp -> ">=" |
| 191 | |
| 192 | (* For printing AST *) |
| 193 | let op_to_string op = |
| 194 | match op with |
| 195 | | PlusOp -> "PlusOp" |
| 196 | | MinusOp -> "MinusOp" |
| 197 | | TimesOp -> "TimesOp" |
| 198 | | DivideOp -> "DivideOp" |
| 199 | | EqOp -> "EqOp" |
| 200 | | NeqOp -> "NeqOp" |
| 201 | | LtOp -> "LtOp" |
| 202 | | LeOp -> "LeOp" |
| 203 | | GtOp -> "GtOp" |
| 204 | | GeOp -> "GeOp" |
| 205 | |
| 206 | let xs_to_string ?(sep=",") ~f ~indent xs = |
| 207 | let i = Indent.to_string indent in |
| 208 | xs |> List.map ~f:(fun x -> i ^ (f x)) |> String.concat ~sep |
| 209 | |
| 210 | let mexp name params ~indent = |
| 211 | let params = xs_to_string ~f:(fun x -> x) ~indent params in |
| 212 | sprintf "%s[%s]" name params |
| 213 | |
| 214 | let field_to_string ~indent (Field {name; typ; _}) = |
| 215 | let name = Sym.to_string name in |
| 216 | let typ = Sym.to_string typ in |
| 217 | let indent = Indent.to_string indent in |
| 218 | sprintf "%s%s : %s" indent name typ |
| 219 | |
| 220 | let fields_to_string fields ~indent = |
| 221 | let fields = List.map fields ~f:(field_to_string ~indent) in |
| 222 | mexp "" fields ~indent |
| 223 | |
| 224 | let rec exp_to_string ~indent exp = |
| 225 | let indent = Indent.next indent in |
| 226 | let mexp = mexp ~indent in |
| 227 | (match exp with |
| 228 | | NilExp -> |
| 229 | mexp "NilExp" [] |
| 230 | | IntExp i -> |
| 231 | mexp "IntExp" [(string_of_int i)] |
| 232 | | StringExp {string; _} -> |
| 233 | mexp "StringExp" [sprintf "%S" string] |
| 234 | | CallExp {func; args; _} -> |
| 235 | let func = Sym.to_string func in |
| 236 | let args = List.map args ~f:(exp_to_string ~indent) in |
| 237 | mexp "CallExp" [func; mexp "" args] |
| 238 | | OpExp {left; oper; right; _} -> |
| 239 | let op_exp = |
| 240 | let indent = Indent.next indent in |
| 241 | let oper = op_to_string oper in |
| 242 | let left = exp_to_string ~indent left in |
| 243 | let right = exp_to_string ~indent right in |
| 244 | mexp oper [left; right] |
| 245 | in |
| 246 | mexp "OpExp" [op_exp] |
| 247 | | RecordExp {fields; typ; _} -> |
| 248 | let fields = |
| 249 | List.map fields ~f:(fun (sym, exp, _) -> |
| 250 | sprintf |
| 251 | "%s = %s" |
| 252 | (Sym.to_string sym) |
| 253 | (exp_to_string ~indent exp) |
| 254 | ) |
| 255 | in |
| 256 | let typ = Sym.to_string typ in |
| 257 | mexp "RecordExp" [typ; mexp "" fields] |
| 258 | | SeqExp exps -> |
| 259 | exps |
| 260 | |> List.map ~f:(fun (e, _) -> exp_to_string e ~indent) |
| 261 | |> mexp "SeqExp" |
| 262 | | AssignExp {var; exp; _} -> |
| 263 | let var = var_to_string ~indent var in |
| 264 | let exp = exp_to_string ~indent exp in |
| 265 | mexp "AssignExp" [var; exp] |
| 266 | | IfExp {test; then'; else'; _} -> |
| 267 | let test = exp_to_string ~indent test in |
| 268 | let then' = exp_to_string ~indent then' in |
| 269 | (match else' with |
| 270 | | None -> |
| 271 | mexp "IfThen" [test; then'] |
| 272 | | Some e -> |
| 273 | mexp "IfThenElse" [test; then'; (exp_to_string ~indent e)] |
| 274 | ) |
| 275 | | WhileExp {test; body; _} -> |
| 276 | let test = exp_to_string ~indent test in |
| 277 | let body = exp_to_string ~indent body in |
| 278 | mexp "WhileExp" [test; body] |
| 279 | | ForExp {var; lo; hi; body; _} -> |
| 280 | mexp "ForExp" |
| 281 | [ (Sym.to_string var) |
| 282 | ; (exp_to_string ~indent lo) |
| 283 | ; (exp_to_string ~indent hi) |
| 284 | ; (exp_to_string ~indent body) |
| 285 | ] |
| 286 | | BreakExp _ -> |
| 287 | mexp "BreakExp" [] |
| 288 | | LetExp {decs; body; _} -> |
| 289 | let decs = List.map decs ~f:(dec_to_string ~indent) in |
| 290 | let body = exp_to_string ~indent body in |
| 291 | mexp "LetExp" [mexp "" decs; body] |
| 292 | | ArrayExp {typ; size; init; _} -> |
| 293 | let typ = Sym.to_string typ in |
| 294 | let size = exp_to_string ~indent size in |
| 295 | let init = exp_to_string ~indent init in |
| 296 | mexp "ArrayExp" [typ; size; init] |
| 297 | | VarExp var -> |
| 298 | mexp "VarExp" [(var_to_string ~indent var)] |
| 299 | ) |
| 300 | and var_to_string ~indent var = |
| 301 | let indent = Indent.next indent in |
| 302 | let mexp = mexp ~indent in |
| 303 | match var with |
| 304 | | SimpleVar {symbol; _} -> |
| 305 | mexp "SimpleVar" [(Sym.to_string symbol)] |
| 306 | | FieldVar {var; symbol; _} -> |
| 307 | mexp "FieldVar" |
| 308 | [ (var_to_string ~indent var) |
| 309 | ; (Sym.to_string symbol) |
| 310 | ] |
| 311 | | SubscriptVar {var; exp; _} -> |
| 312 | mexp "SubscriptVar[%s]" |
| 313 | [ (var_to_string ~indent var) |
| 314 | ; (exp_to_string ~indent exp) |
| 315 | ] |
| 316 | and dec_to_string ~indent dec = |
| 317 | let indent = Indent.next indent in |
| 318 | let mexp = mexp ~indent in |
| 319 | match dec with |
| 320 | | VarDec {name; typ; init; _} -> |
| 321 | let name = Sym.to_string name in |
| 322 | let init = exp_to_string ~indent init in |
| 323 | (match typ with |
| 324 | | Some (typ, _) -> |
| 325 | let typ = Sym.to_string typ in |
| 326 | mexp "VarDec" [name; typ; init] |
| 327 | | None -> |
| 328 | mexp "VarDec" [name; init] |
| 329 | ) |
| 330 | | TypeDecs type_decs -> |
| 331 | mexp "TypeDecs" |
| 332 | (List.map type_decs ~f:(type_dec_to_string ~indent)) |
| 333 | | FunDecs fun_decs -> |
| 334 | mexp "FunDecs" |
| 335 | (List.map fun_decs ~f:(fun_dec_to_string ~indent)) |
| 336 | and fun_dec_to_string ~indent fun_dec = |
| 337 | let indent = Indent.next indent in |
| 338 | let mexp = mexp ~indent in |
| 339 | match fun_dec with |
| 340 | | FunDec {name; params; body; _} -> |
| 341 | let name = Sym.to_string name in |
| 342 | let params = fields_to_string ~indent params in |
| 343 | let body = exp_to_string ~indent body in |
| 344 | mexp "FunDec" [name; params; body] |
| 345 | and type_dec_to_string ~indent type_dec = |
| 346 | let indent = Indent.next indent in |
| 347 | let mexp = mexp ~indent in |
| 348 | match type_dec with |
| 349 | | TypeDec {name; ty; _} -> |
| 350 | mexp "TypeDec" |
| 351 | [ (Sym.to_string name) |
| 352 | ; (ty_to_string ~indent ty) |
| 353 | ] |
| 354 | and ty_to_string ~indent ty = |
| 355 | let mexp = mexp ~indent in |
| 356 | match ty with |
| 357 | | NameTy {symbol; _} -> mexp "NameTy" [(Sym.to_string symbol)] |
| 358 | | ArrayTy {symbol; _} -> mexp "ArrayTy" [(Sym.to_string symbol)] |
| 359 | | RecordTy fields -> mexp "RecordTy" [(fields_to_string ~indent fields)] |
| 360 | |
| 361 | let to_string = |
| 362 | let unit = String.make 4 ' ' in |
| 363 | let indent = Indent.init ~enabled:true ~unit in |
| 364 | exp_to_string ~indent |