open Xi_lib open Ast (* W Xi_lib.Types są definicje typów i środowiska typowego *) open Types module Make() = struct (* Logger: używa się go jak Format.printf *) let logf fmt = Logger.make_logf __MODULE__ fmt module Check () = struct (* Zgłaszaczka błędów *) module ErrorReporter = Typechecker_errors.MakeOneShotErrorReporter () (* Hashtablica którą zwracamy jak wszystko jest OK. * Mapuje znacznik węzła na przypisany typ. Dzięki tej tablicy * późniejsze etapy kompilatora będą miały dostęp do policzonych * typów wyrażeń * * Jeżeli typowanie się powiedzie to zawartość tablicy wydrukuje się * do pliku xilog/004.typechecking.types *) let node2type_map = Hashtbl.create 513 let rec te2type_ret = function | TEXPR_Int _ -> TP_Int | TEXPR_Bool _ -> TP_Bool | TEXPR_Array {sub;dim=None;_} -> TP_Array (te2type_ret sub) | TEXPR_Array {sub;dim;loc} -> ErrorReporter.report_array_initialization_forbidden ~loc (* --------------------------------------------------- *) (* Funkcja nakładka na inferencję, jej zadanie to uzupełniać hashtablicę node2type_map *) let rec infer_expression env e = let tp = _infer_expression env e in Hashtbl.replace node2type_map (tag_of_expression e) tp; logf "%s: inferred type %s" (string_of_location (location_of_expression e)) (string_of_normal_type tp); tp (* --------------------------------------------------- *) (* Oddolna strategia *) and _infer_expression env = function | EXPR_Id {id; loc; _} -> begin match TypingEnvironment.lookup id env with | None -> ErrorReporter.report_unknown_identifier ~loc ~id | Some tp -> match tp with | ENVTP_Var tp -> tp | ENVTP_Fn (_,_) -> ErrorReporter.report_identifier_is_not_variable ~loc ~id end | EXPR_Int _ -> TP_Int | EXPR_Char _ -> TP_Int | EXPR_Bool _ -> TP_Bool | EXPR_Index {expr;index;loc; _} -> check_expression env TP_Int index; begin match infer_expression env expr with | TP_Array tp -> tp | TP_Int -> ErrorReporter.report_expected_array ~loc ~actual:TP_Int | TP_Bool -> ErrorReporter.report_expected_array ~loc ~actual:TP_Bool end | EXPR_Call call -> check_function_call env call | EXPR_Length {arg;loc;_} -> begin match infer_expression env arg with | TP_Array _ -> TP_Int | TP_Int -> ErrorReporter.report_expected_array ~loc ~actual:TP_Int | TP_Bool -> ErrorReporter.report_expected_array ~loc ~actual:TP_Bool end | EXPR_Relation {lhs; rhs; op=RELOP_Ge; _} | EXPR_Relation {lhs; rhs; op=RELOP_Gt; _} | EXPR_Relation {lhs; rhs; op=RELOP_Lt; _} | EXPR_Relation {lhs; rhs; op=RELOP_Le; _} -> check_expression env TP_Int lhs; check_expression env TP_Int rhs; TP_Bool | EXPR_Relation {lhs; rhs; op=RELOP_Eq; _} | EXPR_Relation {lhs; rhs; op=RELOP_Ne; _} -> let tp = infer_expression env lhs in check_expression env tp rhs; TP_Bool (* Consider backtracking *) (* Reguła dla dodawania, jak w treści zadania *) | EXPR_Binop {loc; lhs; rhs; op=BINOP_Add; _} -> begin match infer_expression env lhs with | (TP_Array _) as tp | (TP_Int as tp) -> check_expression env tp rhs; tp | _ -> let descr = "operator + expects integer or array" in ErrorReporter.report_other_error ~loc ~descr end | EXPR_Binop {lhs; rhs; op=BINOP_And;_} | EXPR_Binop {lhs; rhs; op=BINOP_Or; _} -> check_expression env TP_Bool lhs; check_expression env TP_Bool rhs; TP_Bool | EXPR_Binop {lhs; rhs; op=BINOP_Sub;_} | EXPR_Binop {lhs; rhs; op=BINOP_Rem;_} | EXPR_Binop {lhs; rhs; op=BINOP_Mult;_} | EXPR_Binop {lhs; rhs; op=BINOP_Div; _} -> check_expression env TP_Int lhs; check_expression env TP_Int rhs; TP_Int | EXPR_Unop {op=UNOP_Neg; sub; _} -> check_expression env TP_Int sub; TP_Int | EXPR_Unop {op=UNOP_Not; sub; _} -> check_expression env TP_Bool sub; TP_Bool | EXPR_String _ -> TP_Array TP_Int | EXPR_Struct {elements=[]; loc; _} -> ErrorReporter.report_cannot_infer ~loc | EXPR_Struct {elements=x::xs; _} -> let t=infer_expression env x in let _=List.map (check_expression env t) xs in TP_Array t and check_function_call env (Call {loc;callee;_} as call)= match check_function_args env call with | [] -> ErrorReporter.report_other_error ~loc ~descr:("Procedures don't return expressions") | [x] ->x | _ -> ErrorReporter.report_expected_function_returning_one_value ~loc ~id:callee and check_function_args env (Call {loc;callee;arguments;_}) = begin match TypingEnvironment.lookup callee env with | None -> ErrorReporter.report_unknown_identifier ~loc ~id:callee | Some ENVTP_Var _ -> ErrorReporter.report_identifier_is_not_callable ~loc ~id:callee | Some (ENVTP_Fn (arg_types,ret_types)) -> begin let rec aux args types = match args,types with | [],[] -> () | arg::args, t::ts -> check_expression env t arg;aux args ts | _,[] -> ErrorReporter.report_bad_number_of_arguments ~loc ~expected:(List.length arg_types) ~actual:(List.length arguments) | [],_ -> ErrorReporter.report_bad_number_of_arguments ~loc ~expected:(List.length arg_types) ~actual:(List.length arguments) in aux arguments arg_types; ret_types end end and te2base env = begin function | TEXPR_Int _ -> TP_Int | TEXPR_Bool _ -> TP_Bool | TEXPR_Array {sub;dim=None;loc} -> ErrorReporter.report_array_initialization_forbidden ~loc | TEXPR_Array {sub;dim=Some x;_} -> check_expression env TP_Int x;TP_Array (te2base env sub) end and te2type_decl env = begin function | TEXPR_Int _ -> TP_Int | TEXPR_Bool _ -> TP_Bool | TEXPR_Array {sub;dim=None;_} -> TP_Array (te2type_decl env sub) | TEXPR_Array {sub;dim=Some x;_} -> check_expression env TP_Int x;TP_Array (te2base env sub) end and add_var_decl env (VarDecl {loc;id;tp}) = match TypingEnvironment.add id (ENVTP_Var (te2type_decl env tp)) env with | (env,true) -> env | (env,false) -> ErrorReporter.report_shadows_previous_definition ~loc ~id (* --------------------------------------------------- *) (* Odgórna strategia: zapish w node2type_map oczekiwanie a następnie * sprawdź czy nie zachodzi specjalny przypadek. *) and check_expression env expected e = logf "%s: checking expression against %s" (string_of_location (location_of_expression e)) (string_of_normal_type expected); Hashtbl.replace node2type_map (tag_of_expression e) expected; (* Sprawdzamy specjalne przypadki *) match e, expected with (* Mamy sprawdzić `{elements...}` kontra `tp[]`, czyli sprawdzamy * elementy kontra typ elementu tablicy `tp` *) | EXPR_Struct {elements; _}, TP_Array tp -> List.iter (check_expression env tp) elements | EXPR_Binop {op=BINOP_Add; lhs; rhs;_}, TP_Int -> check_expression env TP_Int lhs; check_expression env TP_Int rhs | EXPR_Binop {op=BINOP_Add; lhs; rhs;_}, (TP_Array tp as t) -> check_expression env t lhs; check_expression env t rhs | EXPR_Index {expr;index;loc; _}, tp -> check_expression env TP_Int index; check_expression env (TP_Array tp) expr (* ========== !! Zaimplementuj pozostale przypadki !! ========= *) (* Fallback do strategii oddolnej *) | _ -> let actual = infer_expression env e in if actual <> expected then ErrorReporter.report_type_mismatch ~loc:(location_of_expression e) ~actual ~expected (* --------------------------------------------------- *) (* Pomocnicza funkcja do sprawdzania wywołania procedury *) let check_procedure_call env (Call {loc;_} as call) : unit = match check_function_args env call with | [] -> () | _ -> ErrorReporter.report_other_error ~loc ~descr:"Function used as procedure" (* --------------------------------------------------- *) (* Rekonstrukcja typu dla lvalue *) let infer_lvalue env = function | LVALUE_Id {id;loc;_} -> begin match TypingEnvironment.lookup id env with | None -> ErrorReporter.report_unknown_identifier ~loc ~id | Some ENVTP_Fn _ -> ErrorReporter.report_identifier_is_not_variable ~loc ~id | Some ENVTP_Var tp ->tp end | LVALUE_Index {index; sub; loc} -> check_expression env TP_Int index; begin match infer_expression env sub with | TP_Int -> ErrorReporter.report_expected_array ~loc ~actual:TP_Int | TP_Bool -> ErrorReporter.report_expected_array ~loc ~actual:TP_Bool | TP_Array tp -> tp end (* --------------------------------------------------- *) (* Sprawdzanie statementów *) let rec check_statement env = function (* Proste, wyinferuj typ `lhs` i sprawdź `rhs` kontra wynik *) | STMT_Assign {lhs; rhs; _} -> let lhs_tp = infer_lvalue env lhs in check_expression env lhs_tp rhs; env, RT_Unit | STMT_MultiVarDecl {vars; init; loc} -> begin let ret_types=check_function_args env init in let expected = List.length ret_types in let actual = List.length vars in match init with Call {loc;callee;_} -> if expected!=actual then ErrorReporter.report_expected_function_returning_many_values ~loc ~id:callee ~expected ~actual else begin let rec aux vars types bindings= match vars,types with | [] , [] -> bindings | None::vars , t::types -> aux vars types bindings | (Some (VarDecl{tp;loc;id} as v) )::vars, t::types -> let expected =te2type_decl env tp in if expected==t then aux vars types (v::bindings) else ErrorReporter.report_binding_type_mismatch ~loc ~expected ~id ~actual:t | _ -> failwith "Should not happen" in (List.fold_left add_var_decl env (aux vars ret_types [])),RT_Unit end end | STMT_Block body -> check_statement_block env body | STMT_Call call -> check_procedure_call env call; env, RT_Unit | STMT_If {cond;then_branch;else_branch; _} -> check_expression env TP_Bool cond; let if_ret = snd(check_statement env then_branch) in begin match else_branch with | None -> env,RT_Unit | Some else_branch -> let else_ret =snd(check_statement env else_branch) in env, (if if_ret==RT_Void && else_ret==RT_Void then RT_Void else RT_Unit) end | STMT_Return {values;loc} -> begin match TypingEnvironment.get_return env with | None -> begin match values with | [] -> env,RT_Void | _ -> ErrorReporter.report_procedure_cannot_return_value ~loc end | Some ret ->( let expected = List.length ret and actual = List.length values in if actual==0 then ErrorReporter.report_function_must_return_something ~loc else let rec aux rets values = match rets,values with | ([],[]) -> env, RT_Void | ((r::rs) , (v::vs)) -> let _=check_expression env r v in aux rs vs | ([],(x::xs)) -> ErrorReporter.report_bad_number_of_return_values ~loc ~expected ~actual | ((x::xs),[]) -> ErrorReporter.report_bad_number_of_return_values ~loc ~expected ~actual in aux ret values) end | STMT_VarDecl {var; init} -> begin match var with | VarDecl {tp;_} -> let t=te2type_decl env tp in begin match init with | Some init -> check_expression env t init | None -> () end; (add_var_decl env var),RT_Unit end | STMT_While {cond; body; _} -> check_expression env TP_Bool cond; let _ = check_statement env body in env,RT_Unit and check_statement_block env (STMTBlock {body; _}) = let rec aux env = function | [] -> env,RT_Unit | [x] -> check_statement env x | x::xs -> begin match check_statement env x with | (env,RT_Unit) -> aux env xs | (env,RT_Void) -> ErrorReporter.report_other_error ~loc:(location_of_statement x) ~descr:"Return not at the end of block - unreachable code" end in env,(snd (aux env body)) (* --------------------------------------------------- *) (* Top-level funkcje *) let check_global_declaration env = function | GDECL_Function {formal_parameters; return_types; body; loc; id; _} -> (* Sprawdź wszystko *) let env = List.fold_left add_var_decl env formal_parameters in match body with | Some body -> begin match check_statement_block (TypingEnvironment.set_return env (List.map te2type_ret return_types)) body with | _, RT_Unit -> if return_types!=[] then ErrorReporter.report_not_all_control_paths_return_value ~loc ~id else () | _, RT_Void -> () end | None -> () let scan_global_declaration env = function | GDECL_Function {id; formal_parameters; return_types; loc; _} -> match TypingEnvironment.add id (ENVTP_Fn ((List.map (fun (VarDecl x) -> te2type_ret(x.tp)) formal_parameters),(List.map te2type_ret return_types)) ) env with | (env,true) -> env | (env,false) -> ErrorReporter.report_shadows_previous_definition ~loc ~id let scan_module env (ModuleDefinition {global_declarations; _}) = List.fold_left scan_global_declaration env global_declarations let check_module env (ModuleDefinition {global_declarations; _}) = List.iter (check_global_declaration env) global_declarations (* --------------------------------------------------- *) (* Przetwórz moduł *) let process_module env mdef = (* Wpierw przeskanuj globalne definicje aby uzupełnić środowisko *) let env = scan_module env mdef in (* Zweryfikuj wszystko *) check_module env mdef let computation mdef = (* Zaczynamy z pustym środowiskiem *) let env = TypingEnvironment.empty in process_module env mdef; node2type_map end (* --------------------------------------------------- *) (* Procedura wejściowa *) let check_module mdef = (* Stwórz instancję typecheckera i ją odpal *) let module M = Check() in M.ErrorReporter.wrap M.computation mdef end