(* Semantic checking for the MicroC compiler *)

(* This code was original from MicroC and modified by:
Keir Lauritzen, Leon Song, and Guy Yardeni*)

open Sast

module StringMap = Map.Make(String)

(* Semantic checking of a program. Returns void if successful,
   throws an exception if something is wrong.

   Check each global variable, then check each function *)

let check program =

  (* Raise an exception if the given list has a duplicate *)
  let report_duplicate exceptf list =
    let rec helper = function
	n1 :: n2 :: _ when n1 = n2 -> raise (Failure (exceptf n1))
      | _ :: t -> helper t
      | [] -> ()
    in helper (List.sort compare list)
  in

  (* Raise an exception if a given binding is to a void type *)
  let check_not_void exceptf = function
      (Void, n) -> raise (Failure (exceptf n))
    | _ -> ()
  in
  
  (* Raise an exception of the given rvalue type cannot be assigned to
     the given lvalue type *)
  let check_assign lvaluet rvaluet err =
     if lvaluet == rvaluet || lvaluet == Array_f || lvaluet == Array_s 
     then lvaluet 
   else raise err
  in
   
  (**** Checking Global Variables ****)


  List.iter (check_not_void (fun n -> "illegal void global " ^ n)) program.Sast.var_decls;
   
  report_duplicate (fun n -> "duplicate global " ^ n) (List.map snd program.Sast.var_decls);

  (**** Checking Functions ****)

  if List.mem "print" (List.map (fun fd -> fd.fname) program.Sast.func_decls)
  then raise (Failure ("function print may not be defined")) else ();

  report_duplicate (fun n -> "duplicate function " ^ n)
    (List.map (fun fd -> fd.fname) program.Sast.func_decls);

  (* Function declaration for a named function *)
  let built_in_decls =  StringMap.add "print"
     { typ = Void; fname = "print"; formals = [(Int, "x")];
       locals = []; body = [] } (StringMap.add "printb"
     { typ = Void; fname = "printb"; formals = [(Bool, "x")];
       locals = []; body = [] } (StringMap.add "printc"
     { typ = Void; fname = "printc"; formals = [(Char, "x")];
       locals = []; body = [] } (StringMap.add "print_string"
     { typ = Void; fname = "print_string"; formals = [(String_t, "x")];
       locals = []; body = [] } (StringMap.add "print_float"
     { typ = Void; fname = "print_float"; formals = [(Float, "x")];
       locals = []; body = [] } (StringMap.add "create"
     { typ = Void; fname = "create"; formals = [];
       locals = []; body = [] } (StringMap.add "array_add_float"
     { typ = Float; fname = "array_add_float"; formals = [(Void, "x"); (String_t, "y"); (Float, "z")];
       locals = []; body = [] } (StringMap.add "array_add_string"
     { typ = Float; fname = "array_add_string"; formals = [(Void, "x"); (String_t, "y"); (String_t, "z")];
       locals = []; body = [] } (StringMap.add "array_retrieve_float"
     { typ = Float; fname = "array_retrieve_float"; formals = [(Void, "x"); (String_t, "y")];
       locals = []; body = [] } (StringMap.add "array_retrieve_string"
     { typ = String_t; fname = "array_retrieve_string"; formals = [(Void, "x"); (String_t, "y")];
       locals = []; body = [] } (StringMap.add "strlen"
     { typ = Void; fname = "strlen"; formals = [(String_t, "x")];
       locals = []; body = [] } (StringMap.singleton "printbig"
     { typ = Void; fname = "printbig"; formals = [(Int, "x")];
       locals = []; body = [] })))))))))))

   in
     
  let function_decls = List.fold_left (fun m fd -> StringMap.add fd.fname fd m)
                         built_in_decls program.Sast.func_decls
  in

  let function_decl s = try StringMap.find s function_decls
       with Not_found -> raise (Failure ("unrecognized function " ^ s))
  in

  let check_function func =

    List.iter (check_not_void (fun n -> "illegal void formal " ^ n ^
      " in " ^ func.fname)) func.formals;

    report_duplicate (fun n -> "duplicate formal " ^ n ^ " in " ^ func.fname)
      (List.map snd func.formals);

    List.iter (check_not_void (fun n -> "illegal void local " ^ n ^
      " in " ^ func.fname)) func.locals;

    report_duplicate (fun n -> "duplicate local " ^ n ^ " in " ^ func.fname)
      (List.map snd func.locals);

    (* Type of each variable (global, formal, or local *)
    let symbols = List.fold_left (fun m (t, n) -> StringMap.add n t m)
	StringMap.empty (program.Sast.var_decls @ func.formals @ func.locals )
    in

    let type_of_identifier s =
      try StringMap.find s symbols
      with Not_found -> raise (Failure ("undeclared identifier " ^ s))
    in

    (* Return the type of an expression or throw an exception *)


    let rec expr = function
    | Int_Lit _ -> Int
    | Bool_Lit _ -> Bool
    | String_Lit _ -> String_t
    | Float_Lit _ -> Float
    | Char_Lit _ -> Char
    | Id s -> type_of_identifier s
    | Binop(e1, op, e2) as e -> let t1 = expr e1 and t2 = expr e2 in
      	(match op with
                Add | Sub | Mult | Div when t1 = Float && t2 = Float -> Float
      	| Equal | Neq when t1 = t2 -> Bool
      	| Less | Leq | Greater | Geq when (t1 = Float || t1 = Void) && t2 = Float -> Bool
      	| And | Or when t1 = Bool && t2 = Bool -> Bool
              | _ -> raise (Failure ("illegal binary operator " ^
                    string_of_typ t1 ^ " " ^ string_of_op op ^ " " ^
                    string_of_typ t2 ^ " in " ^ string_of_expr e))
        )
    | Unop(op, e) as ex -> let t = expr e in
    	 (match op with
    	   Neg when t = Float -> Float
    	 | Not when t = Bool -> Bool
             | _ -> raise (Failure ("illegal unary operator " ^ string_of_uop op ^
    	  		   string_of_typ t ^ " in " ^ string_of_expr ex))
        )
    | Noexpr -> Void
    | Assign(var, e) as ex -> let lt = type_of_identifier var
                                and rt = expr e in
        check_assign lt rt (Failure ("illegal assignment " ^ string_of_typ lt ^
				     " = " ^ string_of_typ rt ^ " in " ^ 
				     string_of_expr ex))
    | Call(fname, actuals) as call -> let fd = function_decl fname in
         if List.length actuals != List.length fd.formals then
           raise (Failure ("expecting " ^ string_of_int
             (List.length fd.formals) ^ " arguments in " ^ string_of_expr call))
         else
           (*List.iter2 (fun (ft, _) e -> let et = expr e in
              ignore (check_assign ft et
                (Failure ("illegal actual argument found " ^ string_of_typ et ^
                " expected " ^ string_of_typ ft ^ " in " ^ string_of_expr e))))
             fd.formals actuals; *)
           fd.typ
    | Assign_func (string1, string2) -> Bool
    | Assign_func_array (string1, int1, string2) -> Bool
    | Assign_array (string1, int1, e) -> Bool
    | Retrieve_Float (name, key) -> Float
    | Retrieve_String (name, key) -> String_t
    | Array_Assign_Float (name, key, value) -> Float
    | Array_Assign_String (name, key, value) -> String_t
    | _ -> ignore(print_endline "JUST CHECKING"); Void
    in

    let check_bool_expr e = if expr e != Bool
     then raise (Failure ("expected Boolean expression in " ^ string_of_expr e))
     else () in

    (* Verify a statement or throw an exception *)
    let rec stmt = function
	Block sl -> let rec check_block = function
           [Return _ as s] -> stmt s
         | Return _ :: _ -> raise (Failure "nothing may follow a return")
         | Block sl :: ss -> check_block (sl @ ss)
         | s :: ss -> stmt s ; check_block ss
         | [] -> ()
        in check_block sl
      | Expr e -> ignore (expr e)
      | Return e -> let t = expr e in if t = func.typ then () else
         raise (Failure ("return gives " ^ string_of_typ t ^ " expected " ^
                         string_of_typ func.typ ^ " in " ^ string_of_expr e))
           
      | If(p, b1, b2) -> check_bool_expr p; stmt b1; stmt b2
      | For(e1, e2, e3, st) -> ignore (expr e1); check_bool_expr e2;
                               ignore (expr e3); stmt st
      | While(p, s) -> check_bool_expr p; stmt s
    in

    stmt (Block func.body)
   
  in
  List.iter check_function program.Sast.func_decls
