| 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 | type oper = |
| 10 | | PlusOp |
| 11 | | MinusOp |
| 12 | | TimesOp |
| 13 | | DivideOp |
| 14 | | EqOp |
| 15 | | NeqOp |
| 16 | | LtOp |
| 17 | | LeOp |
| 18 | | GtOp |
| 19 | | GeOp |
| 20 | |
| 21 | type exp = |
| 22 | | NilExp |
| 23 | | IntExp of |
| 24 | int |
| 25 | | StringExp of |
| 26 | { string : string |
| 27 | ; pos : Pos.t |
| 28 | } |
| 29 | | CallExp of |
| 30 | { func : Sym.t |
| 31 | ; args : exp list |
| 32 | ; pos : Pos.t |
| 33 | } |
| 34 | | OpExp of |
| 35 | { left : exp |
| 36 | ; oper : oper |
| 37 | ; right : exp |
| 38 | ; pos : Pos.t |
| 39 | } |
| 40 | | RecordExp of |
| 41 | { fields : (Sym.t * exp * Pos.t) list |
| 42 | ; typ : Sym.t |
| 43 | ; pos : Pos.t |
| 44 | } |
| 45 | | SeqExp of |
| 46 | (exp * Pos.t) list |
| 47 | | AssignExp of |
| 48 | { var : var |
| 49 | ; exp : exp |
| 50 | ; pos : Pos.t |
| 51 | } |
| 52 | | IfExp of |
| 53 | { test : exp |
| 54 | ; then' : exp |
| 55 | ; else' : exp option |
| 56 | ; pos : Pos.t |
| 57 | } |
| 58 | | WhileExp of |
| 59 | { test : exp |
| 60 | ; body : exp |
| 61 | ; pos : Pos.t |
| 62 | } |
| 63 | | ForExp of |
| 64 | { var : Sym.t |
| 65 | ; escape : bool ref (* Whoa - why a mutable cell in AST? *) |
| 66 | ; lo : exp |
| 67 | ; hi : exp |
| 68 | ; body : exp |
| 69 | ; pos : Pos.t |
| 70 | } |
| 71 | | BreakExp of |
| 72 | Pos.t |
| 73 | | LetExp of |
| 74 | { decs : dec list |
| 75 | ; body : exp |
| 76 | ; pos : Pos.t |
| 77 | } |
| 78 | | ArrayExp of |
| 79 | { typ : Sym.t |
| 80 | ; size : exp |
| 81 | ; init : exp |
| 82 | ; pos : Pos.t |
| 83 | } |
| 84 | | VarExp of |
| 85 | var |
| 86 | and var = |
| 87 | | SimpleVar of |
| 88 | { symbol : Sym.t |
| 89 | ; pos : Pos.t |
| 90 | } |
| 91 | | FieldVar of |
| 92 | { var : var |
| 93 | ; symbol : Sym.t |
| 94 | ; pos : Pos.t |
| 95 | } |
| 96 | | SubscriptVar of |
| 97 | { var : var |
| 98 | ; exp : exp |
| 99 | ; pos : Pos.t |
| 100 | } |
| 101 | and dec = |
| 102 | | FunDecs of (* "FunctionDec" in Appel's code *) |
| 103 | fundec list |
| 104 | | VarDec of |
| 105 | { name : Sym.t |
| 106 | ; escape : bool ref (* Again, why mutable? *) |
| 107 | ; typ : (Sym.t * Pos.t) option |
| 108 | ; init : exp |
| 109 | ; pos : Pos.t |
| 110 | } |
| 111 | | TypeDecs of (* "TypeDec" in Appel's code *) |
| 112 | typedec list |
| 113 | and ty = |
| 114 | | NameTy of |
| 115 | { symbol : Sym.t |
| 116 | ; pos : Pos.t |
| 117 | } |
| 118 | | RecordTy of |
| 119 | field list |
| 120 | | ArrayTy of |
| 121 | { symbol : Sym.t |
| 122 | ; pos : Pos.t |
| 123 | } |
| 124 | and field = |
| 125 | | Field of |
| 126 | { name : Sym.t |
| 127 | ; escape : bool ref |
| 128 | ; typ : Sym.t |
| 129 | ; pos : Pos.t |
| 130 | } |
| 131 | and typedec = |
| 132 | | TypeDec of (* An anonymous record in Appel's code *) |
| 133 | { name : Sym.t |
| 134 | ; ty : ty |
| 135 | ; pos : Pos.t |
| 136 | } |
| 137 | and fundec = |
| 138 | | FunDec of |
| 139 | { name : Sym.t |
| 140 | ; params : field list |
| 141 | ; result : (Sym.t * Pos.t) option |
| 142 | ; body : exp |
| 143 | ; pos : Pos.t |
| 144 | } |
| 145 | |
| 146 | type t = exp |
| 147 | |
| 148 | let op_to_string = function |
| 149 | | PlusOp -> "PlusOp" |
| 150 | | MinusOp -> "MinusOp" |
| 151 | | TimesOp -> "TimesOp" |
| 152 | | DivideOp -> "DivideOp" |
| 153 | | EqOp -> "EqOp" |
| 154 | | NeqOp -> "NeqOp" |
| 155 | | LtOp -> "LtOp" |
| 156 | | LeOp -> "LeOp" |
| 157 | | GtOp -> "GtOp" |
| 158 | | GeOp -> "GeOp" |
| 159 | |
| 160 | let xs_to_string ?(sep=", ") ~f xs = |
| 161 | xs |> List.map ~f |> String.concat ~sep |
| 162 | |
| 163 | let field_to_string (Field {name; typ; _}) = |
| 164 | let name = Sym.to_string name in |
| 165 | let typ = Sym.to_string typ in |
| 166 | name ^ " : " ^ typ |
| 167 | |
| 168 | let fields_to_string fields = |
| 169 | xs_to_string fields ~f:field_to_string |
| 170 | let rec exp_to_string exp = |
| 171 | (match exp with |
| 172 | | NilExp -> |
| 173 | "NilExp[]" |
| 174 | | IntExp i -> |
| 175 | sprintf "IntExp[%d]" i |
| 176 | | StringExp {string; _} -> |
| 177 | sprintf "StringExp[%S]" string |
| 178 | | CallExp {func; args; _} -> |
| 179 | let func = Sym.to_string func in |
| 180 | let args = xs_to_string args ~f:exp_to_string in |
| 181 | sprintf "CallExp[%s, %s]" func args |
| 182 | | OpExp {left; oper; right; _} -> |
| 183 | let oper = op_to_string oper in |
| 184 | let left = exp_to_string left in |
| 185 | let right = exp_to_string right in |
| 186 | sprintf "OpExp[%s[%s, %s]]" oper left right |
| 187 | | RecordExp {fields; typ; _} -> |
| 188 | let fields = |
| 189 | xs_to_string |
| 190 | fields |
| 191 | ~f:(fun (s, e, _) -> (Sym.to_string s) ^ " = " ^ (exp_to_string e)) |
| 192 | in |
| 193 | let typ = Sym.to_string typ in |
| 194 | sprintf "RecordExp[%s, %s]" typ fields |
| 195 | | SeqExp exps -> |
| 196 | exps |
| 197 | |> List.map ~f:(fun (exp, _pos) -> exp) |
| 198 | |> xs_to_string ~f:exp_to_string |
| 199 | |> sprintf "SeqExp[%s]" |
| 200 | | AssignExp {var; exp; _} -> |
| 201 | let var = var_to_string var in |
| 202 | let exp = exp_to_string exp in |
| 203 | sprintf "AssignExp[%s, %s]" var exp |
| 204 | | IfExp {test; then'; else'; _} -> |
| 205 | let test = exp_to_string test in |
| 206 | let then' = exp_to_string then' in |
| 207 | (match else' with |
| 208 | | None -> sprintf "IfThen[%s, %s]" test then' |
| 209 | | Some e -> sprintf "IfThenElse[%s, %s, %s]" test then' (exp_to_string e) |
| 210 | ) |
| 211 | | WhileExp {test; body; _} -> |
| 212 | let test = exp_to_string test in |
| 213 | let body = exp_to_string body in |
| 214 | sprintf "WhileExp[%s, %s]" test body |
| 215 | | ForExp {var; lo; hi; body; _} -> |
| 216 | sprintf |
| 217 | "ForExp[ForVar[%S], ForLo[%s], ForHi[%s], ForBody[%s]]" |
| 218 | (Sym.to_string var) |
| 219 | (exp_to_string lo) |
| 220 | (exp_to_string hi) |
| 221 | (exp_to_string body) |
| 222 | | BreakExp _ -> |
| 223 | "BreakExp[]" |
| 224 | | LetExp {decs; body; _} -> |
| 225 | let decs = xs_to_string decs ~f:dec_to_string in |
| 226 | let body = exp_to_string body in |
| 227 | sprintf "LetExp[LetDecs[%s], LetIn[%s]]" decs body |
| 228 | | ArrayExp {typ; size; init; _} -> |
| 229 | let typ = Sym.to_string typ in |
| 230 | let size = exp_to_string size in |
| 231 | let init = exp_to_string init in |
| 232 | sprintf "ArrayExp[%s, %s, %s]" typ size init |
| 233 | | VarExp var -> |
| 234 | sprintf "VarExp[%s]" (var_to_string var) |
| 235 | ) |
| 236 | and var_to_string = function |
| 237 | | SimpleVar {symbol; _} -> |
| 238 | sprintf "SimpleVar[%s]" (Sym.to_string symbol) |
| 239 | | FieldVar {var; symbol; _} -> |
| 240 | sprintf "FieldVar[%s, %s]" (var_to_string var) (Sym.to_string symbol) |
| 241 | | SubscriptVar {var; exp; _} -> |
| 242 | sprintf "SubscriptVar[%s, %s]" (var_to_string var) (exp_to_string exp) |
| 243 | and dec_to_string = function |
| 244 | | VarDec {name; typ; init; _} -> |
| 245 | let name = Sym.to_string name in |
| 246 | let init = exp_to_string init in |
| 247 | (match typ with |
| 248 | | Some (typ, _) -> |
| 249 | let typ = Sym.to_string typ in |
| 250 | sprintf "VarDec[%s, %s, %s]" name typ init |
| 251 | | None -> |
| 252 | sprintf "VarDec[%s, %s]" name init |
| 253 | ) |
| 254 | | TypeDecs type_decs -> |
| 255 | sprintf "TypeDecs[%s]" (xs_to_string type_decs ~f:type_dec_to_string) |
| 256 | | FunDecs fun_decs -> |
| 257 | sprintf "FunDecs[%s]" (xs_to_string fun_decs ~f:fun_dec_to_string) |
| 258 | and fun_dec_to_string = function |
| 259 | | FunDec {name; params; body; _} -> |
| 260 | let name = Sym.to_string name in |
| 261 | let params = fields_to_string params in |
| 262 | let body = exp_to_string body in |
| 263 | sprintf "FunDec[%s, FunParams[%s], FunBody[%s]]" name params body |
| 264 | and type_dec_to_string = function |
| 265 | | TypeDec {name; ty; _} -> |
| 266 | sprintf "TypeDec[%s, %s]" (Sym.to_string name) (ty_to_string ty) |
| 267 | and ty_to_string = function |
| 268 | | NameTy {symbol; _} -> sprintf "NameTy[%s]" (Sym.to_string symbol) |
| 269 | | ArrayTy {symbol; _} -> sprintf "ArrayTy[%s]" (Sym.to_string symbol) |
| 270 | | RecordTy fields -> sprintf "RecordTy[%s]" (fields_to_string fields) |
| 271 | |
| 272 | let to_string = exp_to_string |