-type pos = Tiger_position.t
+open Printf
-type symbol = Tiger_symbol.t
+module List = ListLabels
+module String = StringLabels
+
+module Sym = Tiger_symbol
+module Pos = Tiger_position
+
+module Indent : sig
+ type t
+ val init : enabled:bool -> unit:string -> t
+ val next : t -> t
+ val to_string : t -> string
+end = struct
+ type t =
+ { unit : string option
+ ; levels : int
+ }
+
+ let init ~enabled ~unit =
+ { unit = if enabled then Some unit else None
+ ; levels = 0
+ }
+
+ let next t =
+ {t with levels = succ t.levels}
+
+ let to_string = function
+ | {unit=None; _} ->
+ ""
+ | {unit=Some u; levels} ->
+ let rec add = function
+ | 0 -> ""
+ | n -> u ^ (add (pred n))
+ in
+ "\n" ^ (add levels)
+end
type oper =
| PlusOp
| GeOp
type exp =
- | VarExp of
- var
| NilExp
| IntExp of
int
| StringExp of
{ string : string
- ; pos : pos
+ ; pos : Pos.t
}
| CallExp of
- { func : symbol
+ { func : Sym.t
; args : exp list
- ; pos : pos
+ ; pos : Pos.t
}
| OpExp of
{ left : exp
; oper : oper
; right : exp
- ; pos : pos
+ ; pos : Pos.t
}
| RecordExp of
- { fields : (symbol * exp * pos) list
- ; typ : symbol
- ; pos : pos
+ { fields : (Sym.t * exp * Pos.t) list
+ ; typ : Sym.t
+ ; pos : Pos.t
}
| SeqExp of
- (exp * pos) list
+ (exp * Pos.t) list
| AssignExp of
{ var : var
; exp : exp
- ; pos : pos
+ ; pos : Pos.t
}
| IfExp of
{ test : exp
; then' : exp
; else' : exp option
- ; pos : pos
+ ; pos : Pos.t
}
| WhileExp of
{ test : exp
; body : exp
- ; pos : pos
+ ; pos : Pos.t
}
| ForExp of
- { var : symbol
+ { var : Sym.t
; escape : bool ref (* Whoa - why a mutable cell in AST? *)
; lo : exp
; hi : exp
; body : exp
- ; pos : pos
+ ; pos : Pos.t
}
| BreakExp of
- pos
+ Pos.t
| LetExp of
{ decs : dec list
; body : exp
- ; pos : pos
+ ; pos : Pos.t
}
| ArrayExp of
- { typ : symbol
+ { typ : Sym.t
; size : exp
; init : exp
- ; pos : pos
+ ; pos : Pos.t
}
+ | VarExp of
+ var
and var =
| SimpleVar of
- { symbol : symbol
- ; pos : pos
+ { symbol : Sym.t
+ ; pos : Pos.t
}
| FieldVar of
{ var : var
- ; symbol : symbol
- ; pos : pos
+ ; symbol : Sym.t
+ ; pos : Pos.t
}
| SubscriptVar of
{ var : var
; exp : exp
- ; pos : pos
+ ; pos : Pos.t
}
and dec =
| FunDecs of (* "FunctionDec" in Appel's code *)
fundec list
| VarDec of
- { name : symbol
+ { name : Sym.t
; escape : bool ref (* Again, why mutable? *)
- ; typ : (symbol * pos) option
+ ; typ : (Sym.t * Pos.t) option
; init : exp
- ; pos : pos
+ ; pos : Pos.t
}
| TypeDecs of (* "TypeDec" in Appel's code *)
typedec list
and ty =
| NameTy of
- { symbol : symbol
- ; pos : pos
+ { symbol : Sym.t
+ ; pos : Pos.t
}
| RecordTy of
field list
| ArrayTy of
- { symbol : symbol
- ; pos : pos
+ { symbol : Sym.t
+ ; pos : Pos.t
}
and field =
| Field of
- { name : symbol
+ { name : Sym.t
; escape : bool ref
- ; typ : symbol
- ; pos : pos
+ ; typ : Sym.t
+ ; pos : Pos.t
}
and typedec =
| TypeDec of (* An anonymous record in Appel's code *)
- { name : symbol
+ { name : Sym.t
; ty : ty
- ; pos : pos
+ ; pos : Pos.t
}
and fundec =
| FunDec of
- { name : symbol
+ { name : Sym.t
; params : field list
- ; result : (symbol * pos) option
+ ; result : (Sym.t * Pos.t) option
; body : exp
- ; pos : pos
+ ; pos : Pos.t
}
type t = exp
-let to_string _ = "TODO: implement Tiger_absyn.to_string"
+let op_to_string op =
+ match op with
+ | PlusOp -> "PlusOp"
+ | MinusOp -> "MinusOp"
+ | TimesOp -> "TimesOp"
+ | DivideOp -> "DivideOp"
+ | EqOp -> "EqOp"
+ | NeqOp -> "NeqOp"
+ | LtOp -> "LtOp"
+ | LeOp -> "LeOp"
+ | GtOp -> "GtOp"
+ | GeOp -> "GeOp"
+
+let xs_to_string ?(sep=",") ~f ~indent xs =
+ let i = Indent.to_string indent in
+ xs |> List.map ~f:(fun x -> i ^ (f x)) |> String.concat ~sep
+
+let mexp name params ~indent =
+ let params = xs_to_string ~f:(fun x -> x) ~indent params in
+ sprintf "%s[%s]" name params
+
+let field_to_string ~indent (Field {name; typ; _}) =
+ let name = Sym.to_string name in
+ let typ = Sym.to_string typ in
+ let indent = Indent.to_string indent in
+ sprintf "%s%s : %s" indent name typ
+
+let fields_to_string fields ~indent =
+ let fields = List.map fields ~f:(field_to_string ~indent) in
+ mexp "" fields ~indent
+
+let rec exp_to_string ~indent exp =
+ let indent = Indent.next indent in
+ let mexp = mexp ~indent in
+ (match exp with
+ | NilExp ->
+ mexp "NilExp" []
+ | IntExp i ->
+ mexp "IntExp" [(string_of_int i)]
+ | StringExp {string; _} ->
+ mexp "StringExp" [sprintf "%S" string]
+ | CallExp {func; args; _} ->
+ let func = Sym.to_string func in
+ let args = List.map args ~f:(exp_to_string ~indent) in
+ mexp "CallExp" [func; mexp "" args]
+ | OpExp {left; oper; right; _} ->
+ let op_exp =
+ let indent = Indent.next indent in
+ let oper = op_to_string oper in
+ let left = exp_to_string ~indent left in
+ let right = exp_to_string ~indent right in
+ mexp oper [left; right]
+ in
+ mexp "OpExp" [op_exp]
+ | RecordExp {fields; typ; _} ->
+ let fields =
+ List.map fields ~f:(fun (sym, exp, _) ->
+ sprintf
+ "%s = %s"
+ (Sym.to_string sym)
+ (exp_to_string ~indent exp)
+ )
+ in
+ let typ = Sym.to_string typ in
+ mexp "RecordExp" [typ; mexp "" fields]
+ | SeqExp exps ->
+ exps
+ |> List.map ~f:(fun (e, _) -> exp_to_string e ~indent)
+ |> mexp "SeqExp"
+ | AssignExp {var; exp; _} ->
+ let var = var_to_string ~indent var in
+ let exp = exp_to_string ~indent exp in
+ mexp "AssignExp" [var; exp]
+ | IfExp {test; then'; else'; _} ->
+ let test = exp_to_string ~indent test in
+ let then' = exp_to_string ~indent then' in
+ (match else' with
+ | None ->
+ mexp "IfThen" [test; then']
+ | Some e ->
+ mexp "IfThenElse" [test; then'; (exp_to_string ~indent e)]
+ )
+ | WhileExp {test; body; _} ->
+ let test = exp_to_string ~indent test in
+ let body = exp_to_string ~indent body in
+ mexp "WhileExp" [test; body]
+ | ForExp {var; lo; hi; body; _} ->
+ mexp "ForExp"
+ [ (Sym.to_string var)
+ ; (exp_to_string ~indent lo)
+ ; (exp_to_string ~indent hi)
+ ; (exp_to_string ~indent body)
+ ]
+ | BreakExp _ ->
+ mexp "BreakExp" []
+ | LetExp {decs; body; _} ->
+ let decs = List.map decs ~f:(dec_to_string ~indent) in
+ let body = exp_to_string ~indent body in
+ mexp "LetExp" [mexp "" decs; body]
+ | ArrayExp {typ; size; init; _} ->
+ let typ = Sym.to_string typ in
+ let size = exp_to_string ~indent size in
+ let init = exp_to_string ~indent init in
+ mexp "ArrayExp" [typ; size; init]
+ | VarExp var ->
+ mexp "VarExp" [(var_to_string ~indent var)]
+ )
+and var_to_string ~indent var =
+ let indent = Indent.next indent in
+ let mexp = mexp ~indent in
+ match var with
+ | SimpleVar {symbol; _} ->
+ mexp "SimpleVar" [(Sym.to_string symbol)]
+ | FieldVar {var; symbol; _} ->
+ mexp "FieldVar"
+ [ (var_to_string ~indent var)
+ ; (Sym.to_string symbol)
+ ]
+ | SubscriptVar {var; exp; _} ->
+ mexp "SubscriptVar[%s]"
+ [ (var_to_string ~indent var)
+ ; (exp_to_string ~indent exp)
+ ]
+and dec_to_string ~indent dec =
+ let indent = Indent.next indent in
+ let mexp = mexp ~indent in
+ match dec with
+ | VarDec {name; typ; init; _} ->
+ let name = Sym.to_string name in
+ let init = exp_to_string ~indent init in
+ (match typ with
+ | Some (typ, _) ->
+ let typ = Sym.to_string typ in
+ mexp "VarDec" [name; typ; init]
+ | None ->
+ mexp "VarDec" [name; init]
+ )
+ | TypeDecs type_decs ->
+ mexp "TypeDecs"
+ (List.map type_decs ~f:(type_dec_to_string ~indent))
+ | FunDecs fun_decs ->
+ mexp "FunDecs"
+ (List.map fun_decs ~f:(fun_dec_to_string ~indent))
+and fun_dec_to_string ~indent fun_dec =
+ let indent = Indent.next indent in
+ let mexp = mexp ~indent in
+ match fun_dec with
+ | FunDec {name; params; body; _} ->
+ let name = Sym.to_string name in
+ let params = fields_to_string ~indent params in
+ let body = exp_to_string ~indent body in
+ mexp "FunDec" [name; params; body]
+and type_dec_to_string ~indent type_dec =
+ let indent = Indent.next indent in
+ let mexp = mexp ~indent in
+ match type_dec with
+ | TypeDec {name; ty; _} ->
+ mexp "TypeDec"
+ [ (Sym.to_string name)
+ ; (ty_to_string ~indent ty)
+ ]
+and ty_to_string ~indent ty =
+ let mexp = mexp ~indent in
+ match ty with
+ | NameTy {symbol; _} -> mexp "NameTy" [(Sym.to_string symbol)]
+ | ArrayTy {symbol; _} -> mexp "ArrayTy" [(Sym.to_string symbol)]
+ | RecordTy fields -> mexp "RecordTy" [(fields_to_string ~indent fields)]
+
+let to_string =
+ let unit = String.make 4 ' ' in
+ let indent = Indent.init ~enabled:true ~unit in
+ exp_to_string ~indent
home / code / tiger.ml.git / blobdiff