(*
   absyn.ml
   15-411
*)

module HA = Hashtbl
module E = Errormsg

(* This exception is raised to exit the program *)
exception EXIT

type ofs_t = {mutable ofs : int}

type program = Program of typedcl list * vardcl list * stmt list
and typedcl = Typedcl of string * (string * typeval) list * E.pos
and typeval = BoolT | IntT | NS_T | AnyT
            | StructT of string | PtrT of typeval
and vardcl = Vardcl of string * typeval * E.pos
and stmt = Assign of exp * exp * bool * E.pos
         | Exp of exp
         | Return of exp * E.pos
         | IfElse of exp * stmt list * stmt list * E.pos
and exp = IntConstExp of int32 * E.pos * typeval
         | BoolConstExp of bool * E.pos * typeval
         | NullConstExp of E.pos * typeval
         | UnOpExp of unop * exp * E.pos * typeval
         | BinOpExp of exp * binop * exp * E.pos * typeval
         | AmpersandExp of exp * E.pos * typeval
         | AllocExp of exp * typeval * E.pos * typeval
         | VarExp of string * E.pos * typeval
         | FieldExp of exp * string * ofs_t * E.pos * typeval
         | VarLval of string * E.pos * typeval
         | DerefLval of exp * E.pos * typeval
         | FieldLval of exp * string * ofs_t * E.pos * typeval
and binop = PLUS | MINUS | TIMES | DIVIDE | MOD
          | RELLT | RELLE | RELGT | RELGE | RELEQ | RELNE
          | LOGAND | LOGOR | LOGXOR | BITAND | BITOR | BITXOR
          | BITSHL | BITSHR | PTRPLUS | PTRMINUS | PTREQ | PTRNE
and unop = NEGATE | LOGNEGATE | BITNEGATE
         | DEREF | OFFSET | SIZE

exception NotAnLvalue

let rec deLval = function
  | VarLval(v, pos, tv) -> VarExp(v, pos, tv)
  | DerefLval(e, pos, tv) -> UnOpExp(DEREF, e, pos, tv)
  | FieldLval(lv, id, ofs, pos, tv) -> FieldExp(deLval lv, id, ofs, pos, tv)
  | _ -> raise NotAnLvalue

let rec reLval = function
  | VarExp(v, pos, tv) -> VarLval(v, pos, tv)
  | UnOpExp(DEREF, e, pos, tv) -> DerefLval(e, pos, tv)
  | FieldExp(e, id, ofs, pos, tv) -> FieldLval(reLval e, id, ofs, pos, tv)
  | _ -> raise NotAnLvalue

(************************************************************************)
(* Pretty-print AST *)
(************************************************************************)

let nice_binop = function
  | PLUS -> "+" | MINUS -> "-"
  | TIMES -> "*" | DIVIDE -> "/" | MOD -> "%"
  | RELLT -> "<" | RELLE -> "<="
  | RELGT -> ">" | RELGE -> ">="
  | RELEQ -> "==" | RELNE -> "!="
  | LOGAND -> "&&" | LOGOR -> "||" | LOGXOR -> "^^"
  | BITAND -> "&" | BITOR -> "|" | BITXOR -> "^"
  | BITSHL -> "<<" | BITSHR -> ">>"
  | PTRPLUS -> "*+" | PTRMINUS -> "*-" | PTREQ -> "*==" | PTRNE -> "*!="

let nice_unop = function
  | NEGATE -> "-" | LOGNEGATE -> "!" | BITNEGATE -> "~" | DEREF -> "*"
  | OFFSET -> "offset" | SIZE -> "size"

let rec nice_typeval = function
  | BoolT -> "bool"
  | IntT -> "int"
  | StructT(tag) -> tag
  | PtrT(tv) -> (nice_typeval tv)^"*"
  | NS_T -> "NS"
  | AnyT -> "AnyT"

(* Pretty Print AST *)

exception Done

let rec print_ast oc (Program(tli, dli, sli)) =
  let ps_indentlevel = ref 0
  and ps_indentdelta = ref 0
  and ps_buffer = ref "" in
  let modify_indent = function
    | '{' -> ps_indentdelta := !ps_indentdelta + 1
    | '}' -> ps_indentlevel := !ps_indentlevel - 1
    | _ -> () in
  let ps s = begin
    ps_buffer := !ps_buffer ^ s;
    try
      let x = String.index !ps_buffer '\n' in
      let line = String.sub !ps_buffer 0 (x+1) in
      (*
         At this point, we have a complete line to print out.  We
         go through the string |line| and figure out what needs to
         be done to our indentation, and then print out that line
         and remove it from the front of the buffer |ps_buffer|.
      *)
      ps_indentdelta := 0;
      String.iter modify_indent line;
      for i=1 to !ps_indentlevel do
        output_string oc "    "; done;
      output_string oc line;
      ps_indentlevel := !ps_indentlevel + !ps_indentdelta;
      ps_buffer := String.sub !ps_buffer (x+1)
          ((String.length !ps_buffer) - (x+1))
    with Not_found -> ()
  end
  in
  (* Print the operand *)
  let rec print_exp = function
    | IntConstExp(c, _, _) -> ps (Int32.to_string c)
    | BoolConstExp(b, _, _) -> ps (if b then "true" else "false")
    | NullConstExp(_, _) -> ps "NULL"
    | UnOpExp(OFFSET as op, e, _, _) ->
        ps ("("^(nice_unop op)^"("); print_exp e; ps "))"
    | UnOpExp(SIZE as op, e, _, _) ->
        ps ("("^(nice_unop op)^"("); print_exp e; ps "))"
    | UnOpExp(op, e, _, _) ->
        ps ("("^(nice_unop op)); print_exp e; ps ")"
    | BinOpExp(e1, op, e2, _, _) ->
        ps "(";
        print_exp e1; ps (" "^(nice_binop op)^" "); print_exp e2;
        ps ")"
    | AmpersandExp(lve, _, _) ->
        ps "(&"; print_exp(lve); ps ")"
    | AllocExp(e, t, _, _) ->
        ps "(alloc("; print_exp e; ps (", "^(nice_typeval t)^"))")
    | VarExp(s, _, _) -> ps s
    | FieldExp(e, f, _, _, _) -> ps "("; print_exp e; ps ")."; ps f
    | VarLval(s, _, _) -> ps s
    | DerefLval(e, _, _) -> ps "(*("; print_exp e; ps "))"
    | FieldLval(lv, f, _, _, _) -> ps "("; print_exp lv; ps ")."; ps f
  and print_stmt = function
    | Assign(lve,e,_,_) -> print_exp lve; ps " = "; print_exp e; ps ";\n"
    | Exp(e) -> print_exp e; ps ";\n"
    | Return(e, _) -> ps "return "; print_exp e; ps ";\n"
    | IfElse(e, s1, s2, _) -> begin
        ps "if ("; print_exp e; ps ") {\n";
        List.iter print_stmt s1;
        ps "}\nelse {\n";
        List.iter print_stmt s2;
        ps "}\n"
      end
  and print_typedcl = function | Typedcl(tag, mli, _) ->
    let print_field(s, tv) = ps (s^": "^(nice_typeval tv)^";\n")
    in
      ps "struct "; ps tag; ps " {\n";
      List.iter print_field mli;
      ps "};\n";
  and print_vardcl = function
    | Vardcl(s, tv, _) ->
        ps ("var " ^ s ^ ": "^(nice_typeval tv)^";\n")
  in
  List.iter (fun t -> print_typedcl t; ps "\n") tli;
  ps "{\n";
  List.iter print_vardcl dli;
  if (dli <> []) then ps "\n";
  List.iter print_stmt sli;
  ps "}\n"


(************************************************************************)
(* Dump AST *)
(************************************************************************)

let dump_ast oc (Program(tli, dli, sli)) =
  let ps = output_string oc in
  (* Print the operands *)
  let nice_binop = function
    | PLUS ->   "PLUS"
    | MINUS ->  "MINUS"
    | TIMES ->  "TIMES"
    | DIVIDE -> "DIVIDE"
    | MOD ->    "MOD"
    | BITSHL -> "BITSHL"
    | BITSHR -> "BITSHR"
    | BITAND -> "BITAND"
    | BITOR ->  "BITOR"
    | BITXOR -> "BITXOR"
    | LOGAND -> "LOGAND"
    | LOGOR ->  "LOGOR"
    | LOGXOR -> "LOGXOR"
    | PTRPLUS -> "PTRPLUS"
    | PTRMINUS -> "PTRMINUS"
    | PTREQ ->  "PTREQ"
    | PTRNE ->  "PTRNE"
    | RELLT ->  "RELLT"
    | RELLE ->  "RELLE"
    | RELGT ->  "RELGT"
    | RELGE ->  "RELGE"
    | RELEQ ->  "RELEQ"
    | RELNE ->  "RELNE"
  and nice_unop = function
    | NEGATE -> "NEGATE"
    | LOGNEGATE -> "LOGNEGATE"
    | BITNEGATE -> "BITNEGATE"
    | DEREF -> "DEREF"
    | SIZE -> "SIZE"
    | OFFSET -> "OFFSET"
  in
  let rec nice_exp = function
    | IntConstExp(c, _, _) ->
        Printf.sprintf "IntConstExp(%li)" c
    | BoolConstExp(b, _, _) ->
        Printf.sprintf "BoolConstExp(%s)" (if b then "true" else "false")
    | NullConstExp(_, _) -> "NullConstExp"
    | UnOpExp(op, e, _, _) ->
        "UnOpExp("^(nice_unop op)^", "^(nice_exp e)^")"
    | BinOpExp(e1, op, e2, _, _) ->
        "BinOpExp("^(nice_exp e1)^", "^(nice_binop op)^", "^(nice_exp e2)^")"
    | AmpersandExp(lve, _, _) ->
        "AmpersandExp("^(nice_exp lve)^")"
    | AllocExp(e, t, _, _) ->
        "AllocExp("^(nice_exp e)^", "^(nice_typeval t)^")"
    | VarExp(s, _, _) -> "VarExp(" ^ s ^ ")"
    | FieldExp(e, f, ofs, _, _) -> "FieldExp("^(nice_exp e)^", "^f^" ("^
        (string_of_int ofs.ofs)^"))"
    | VarLval(s, _, _) -> "VarLval(" ^ s ^ ")"
    | DerefLval(e, _, _) -> "DerefLval("^(nice_exp e)^")"
    | FieldLval(lv, f, _, _, _) -> "FieldLval("^(nice_exp lv)^", "^f^")"
  and print_stmt = function
    | Assign(lve, e, _, _) ->
        ps ("Assign("^(nice_exp lve)^", "^(nice_exp e)^")\n")
    | Exp(e) ->
        ps ("Exp("^(nice_exp e)^")\n")
    | Return(e, _) ->
        ps ("Return("^(nice_exp e)^")\n")
    | IfElse(e, s1, s2, _) -> begin
        ps ("IfElse("^(nice_exp e)^", {\n");
        List.iter print_stmt s1;
        ps "}, {\n";
        List.iter print_stmt s2;
        ps "})\n"
      end
  and print_typedcl = function | Typedcl(tag, mli, _) ->
    let print_field(s, tv) =
      ps ("field("^s^", "^(nice_typeval tv)^")\n")
    in
      ps ("Typedcl("^tag^", {\n");
      List.iter print_field mli;
      ps "})\n";
  and nice_typeval = function
    | BoolT -> "BoolT"
    | IntT -> "IntT"
    | StructT(tag) -> "StructT(" ^ tag ^ ")"
    | PtrT(tv) -> "PtrT("^(nice_typeval tv)^")"
    | NS_T -> "NS"
    | AnyT -> "AnyT"
  and print_vardcl = function
    | Vardcl(s, tv, _) -> ps ("Vardcl("^s^", "^(nice_typeval tv)^")\n")
  in
  List.iter (fun t -> print_typedcl t; ps "\n") tli;
  ps "{\n";
  List.iter print_vardcl dli;
  ps "\n";
  List.iter print_stmt sli;
  ps "}\n"