diff options
Diffstat (limited to 'source')
| -rw-r--r-- | source/mod_student/plugin.ml | 15 | ||||
| -rw-r--r-- | source/mod_student/typechecker.ml | 231 | ||||
| -rw-r--r-- | source/xi/.merlin | 15 | ||||
| -rw-r--r-- | source/xi/pipeline.ml | 14 | ||||
| -rw-r--r-- | source/xi/xi.ml | 2 | ||||
| -rw-r--r-- | source/xi_lib/.merlin | 5 | ||||
| -rw-r--r-- | source/xi_lib/iface.ml | 2 | ||||
| -rw-r--r-- | source/xi_lib/typechecker_errors.ml | 119 | ||||
| -rw-r--r-- | source/xi_lib/types.ml | 51 |
9 files changed, 405 insertions, 49 deletions
diff --git a/source/mod_student/plugin.ml b/source/mod_student/plugin.ml index 26d15d0..41487d3 100644 --- a/source/mod_student/plugin.ml +++ b/source/mod_student/plugin.ml @@ -27,9 +27,20 @@ module Plugin : PLUGIN = struct let make_spill_costs_analysis = None + let lexer_and_parser = None + (* + * Przenieś pliki parser.mly oraz lexer.mll z poprzedniego rozwiązania + * i odkomentuj poniższą linijkę. + * + * Przenoszenie rozwiązania nie jest wymagane. Pamiętaj, że możesz napotkać + * trudności gdy rozwiązanie z poprzedniej pracowni okaże się nie do końca + * kompatybilne z kształtem danych oczekiwanym przez resztę modułów + * kompilatora. + * let lexer_and_parser = Some (module LexerAndParser : LEXER_AND_PARSER) + *) - let make_typechecker = None + let make_typechecker = Some (module Typechecker.Make : MAKE_TYPECHECKER) let make_translator = None @@ -58,4 +69,4 @@ module Plugin : PLUGIN = struct let make_reachability_analysis = None end -module RegisterMyPlugin = RegisterPlugin(Plugin)
\ No newline at end of file +module RegisterMyPlugin = RegisterPlugin(Plugin) diff --git a/source/mod_student/typechecker.ml b/source/mod_student/typechecker.ml new file mode 100644 index 0000000..800fecf --- /dev/null +++ b/source/mod_student/typechecker.ml @@ -0,0 +1,231 @@ +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 + + (* --------------------------------------------------- *) + (* 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; _} -> + failwith "Not yet implemented" + + | EXPR_Int _ -> + TP_Int + + | EXPR_Char _ -> + failwith "Not yet implemented" + + | EXPR_Bool _ -> + failwith "Not yet implemented" + + | EXPR_Index {expr;index;loc; _} -> + failwith "Not yet implemented" + + | EXPR_Call call -> + check_function_call env call + + | EXPR_Length {arg;loc;_} -> + failwith "Not yet implemented" + + | 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; _} -> + failwith "Not yet implemented" + + | EXPR_Relation {lhs; rhs; op=RELOP_Eq; _} + | EXPR_Relation {lhs; rhs; op=RELOP_Ne; _} -> + failwith "Not yet implemented" + + (* 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; _} -> + failwith "not yet implemented" + + | 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; _} -> + failwith "not yet implemented" + + | EXPR_Unop {op=UNOP_Neg; sub; _} -> + failwith "not yet implemented" + + | EXPR_Unop {op=UNOP_Not; sub; _} -> + failwith "not yet implemented" + + | EXPR_String _ -> + failwith "not yet implemented" + + | EXPR_Struct {elements=[]; loc; _} -> + ErrorReporter.report_cannot_infer ~loc + + | EXPR_Struct {elements=x::xs; _} -> + failwith "not yet implemented" + + and check_function_call env call = + failwith "not yet implemented" + + (* --------------------------------------------------- *) + (* 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 + + (* ========== !! 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 : unit = + failwith "not yet implemented" + + (* --------------------------------------------------- *) + (* Rekonstrukcja typu dla lvalue *) + + let infer_lvalue env = function + | LVALUE_Id {id;loc;_} -> + failwith "not yet implemented" + + | LVALUE_Index {index; sub; loc} -> + failwith "not yet implemented" + + + (* --------------------------------------------------- *) + (* 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; _} -> + failwith "not yet implemented" + + | 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; _} -> + failwith "not yet implemented" + + | STMT_Return {values;loc} -> + failwith "not yet implemented" + + | STMT_VarDecl {var; init} -> + failwith "not yet implemented" + + | STMT_While {cond; body; _} -> + failwith "not yet implemented" + + and check_statement_block env (STMTBlock {body; _}) = + failwith "not yet implemented" + + (* --------------------------------------------------- *) + (* Top-level funkcje *) + + let check_global_declaration env = function + | GDECL_Function {formal_parameters; return_types; body; loc; id; _} -> + (* Sprawdź wszystko *) + failwith "not yet implemented" + + let scan_global_declaration env = function + | GDECL_Function {id; formal_parameters; return_types; loc; _} -> + (* Dodaj idenetyfkator funkcji i jej typ do środowiska *) + failwith "not yet implemented" + + 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 diff --git a/source/xi/.merlin b/source/xi/.merlin deleted file mode 100644 index 615c7ba..0000000 --- a/source/xi/.merlin +++ /dev/null @@ -1,15 +0,0 @@ -B /usr/home/pawel/.opam/4.07.0/lib/bytes -B /usr/home/pawel/.opam/4.07.0/lib/cmdliner -B /usr/home/pawel/.opam/4.07.0/lib/ocaml -B /usr/home/pawel/.opam/4.07.0/lib/ocamlgraph -B /usr/home/pawel/.opam/4.07.0/lib/result -B ../../_build/default/source/xi/.xi.eobjs -B ../../_build/default/source/xi_lib/.xi_lib.objs -S /usr/home/pawel/.opam/4.07.0/lib/bytes -S /usr/home/pawel/.opam/4.07.0/lib/cmdliner -S /usr/home/pawel/.opam/4.07.0/lib/ocaml -S /usr/home/pawel/.opam/4.07.0/lib/ocamlgraph -S /usr/home/pawel/.opam/4.07.0/lib/result -S . -S ../xi_lib -FLG -w @a-4-29-40-41-42-44-45-48-58-59-60-40 -strict-sequence -strict-formats -short-paths -keep-locs -g -w -39-33-26-27 diff --git a/source/xi/pipeline.ml b/source/xi/pipeline.ml index 34a06f9..ae9a4c9 100644 --- a/source/xi/pipeline.ml +++ b/source/xi/pipeline.ml @@ -31,10 +31,21 @@ module Make(Steps:COMPILER_STEPS)(Params:PARAMS) = struct Logger.dump_string "regmapping" @@ describe_register_mapping mapping let dump_schedule proc_ir schedule = - let title = Format.sprintf "%s.schedule" (Ir_utils.string_of_procid @@ Ir.procid_of_procedure proc_ir) in + let title = Format.sprintf "%s.schedule" (Ir_utils.string_of_procid proc_ir) in let output = Ir_utils.string_of_labellist schedule in Logger.dump_string title output + let dump_node2type node2type = + let title = "types" in + let f k v xs = + let line = Format.sprintf "%s -> %s" + (Ast.string_of_node_tag k) + (Types.string_of_normal_type v) in + line :: xs + in + let lines = Hashtbl.fold f node2type [] in + Logger.dump_string title @@ String.concat "\n" @@ List.sort compare lines + module IrPhases = struct let regalloc proc = @@ -111,6 +122,7 @@ module Make(Steps:COMPILER_STEPS)(Params:PARAMS) = struct List.iter prerr_endline xs; Error "typechecker" | Ok (node2type) -> + dump_node2type node2type; if Invariants.AllExpressionsAreTypecheck.verify_module_definition node2type ast then check_stop_point "typechecker" translate (ast, node2type) else diff --git a/source/xi/xi.ml b/source/xi/xi.ml index 86a23f1..d59dbf6 100644 --- a/source/xi/xi.ml +++ b/source/xi/xi.ml @@ -72,7 +72,7 @@ module CommandLine = struct let cmd = let doc = "Compile Xi Program" in - let version = "pracownia1.1-0-gc10b4f2" in + let version = "pracownia2.3-0-g63fd12e" in Term.(const compile $ xi_log $ extra_debug $ mod_uwr $ plugin $ reg_descr $ stop_after $ output $ source_file), Term.info "xi" ~doc ~version diff --git a/source/xi_lib/.merlin b/source/xi_lib/.merlin deleted file mode 100644 index eafe161..0000000 --- a/source/xi_lib/.merlin +++ /dev/null @@ -1,5 +0,0 @@ -B /usr/home/pawel/.opam/4.07.0/lib/ocamlgraph -B ../../_build/default/source/xi_lib/.xi_lib.objs -S /usr/home/pawel/.opam/4.07.0/lib/ocamlgraph -S . -FLG -open Xi_lib -w @a-4-29-40-41-42-44-45-48-58-59-60-40 -strict-sequence -strict-formats -short-paths -keep-locs diff --git a/source/xi_lib/iface.ml b/source/xi_lib/iface.ml index b67a787..04658e0 100644 --- a/source/xi_lib/iface.ml +++ b/source/xi_lib/iface.ml @@ -1,7 +1,7 @@ type node2type = (Ast.node_tag, Types.normal_type) Hashtbl.t -type schedule = (Ir.procedure, Ir.label list) Hashtbl.t +type schedule = (Ir.procid, Ir.label list) Hashtbl.t type register_mapping = (Ir.reg, Ir.reg) Hashtbl.t diff --git a/source/xi_lib/typechecker_errors.ml b/source/xi_lib/typechecker_errors.ml index f3ee529..4799a6b 100644 --- a/source/xi_lib/typechecker_errors.ml +++ b/source/xi_lib/typechecker_errors.ml @@ -2,12 +2,15 @@ open Ast open Types type type_checking_error = + + (* Ogólny błąd, że oczekiwany typ się nie zgadza z rzeczywistym *) | TCERR_TypeMismatch of { loc: location ; expected: normal_type ; actual: normal_type } + (* Błąd typu przy multireturn *) | TCERR_BindingTypeMismatch of { loc: location ; expected: normal_type @@ -15,48 +18,57 @@ type type_checking_error = ; id: identifier } + (* Wywołaliśmy procedurę/funkcję ze złą liczbą argumentów *) | TCERR_BadNumberOfActualArguments of { loc: location ; expected: int ; actual: int } + (* Return dostał złą liczbę parametrów *) | TCERR_BadNumberOfReturnValues of { loc: location ; expected: int ; actual: int } + (* Nieznany identyfikator *) | TCERR_UnknownIdentifier of { loc: location ; id: identifier } + (* Identyfikator nie jest zmienną (a np jest funkcją) *) | TCERR_IdentifierIsNotVariable of { loc: location ; id: identifier } + (* Generyczny błąd gdyby inne nie pasowały *) | TCERR_OtherError of { loc: location ; descr: string } + (* Wywołujemy identyfikator, który nie jest funkcją/procedurą *) | TCERR_IdentifierIsNotCallable of { loc: location ; id: identifier } + (* Brakuje return gdzieś *) | TCERR_NotAllControlPathsReturnValue of { loc: location ; id: identifier } + (* Użyliśmy w wyrażeniu multireturnowej funkcji *) | TCERR_ExpectedFunctionReturningOneValue of { loc: location ; id: identifier } + (* Użyliśmy w multireturnie zywkłej funkcji *) | TCERR_ExpectedFunctionReturningManyValues of { loc: location ; expected: int @@ -64,33 +76,33 @@ type type_checking_error = ; id: identifier } + (* Return w procedurze *) | TCERR_ProcedureCannotReturnValue of { loc: location } + (* Brakuje parametru w return *) | TCERR_FunctionMustReturnValue of { loc: location } + (* Typ miał być tablicą *) | TCERR_ExpectedArray of { loc: location ; actual: normal_type } - | TCERR_InvalidRedeclaration of - { loc: location - ; id: identifier - ; previous: env_type - } - + (* Przykryliśmy nazwę *) | TCERR_ShadowsPreviousDefinition of { loc: location ; id: identifier } + (* W wyrażeniu typowym pojawiło się wyrażenie oznaczające rozmiar *) | TCERR_ArrayInitializationForbidden of { loc: location } + (* Generyczny błąd, że nie dało się zrekonstruować typu *) | TCERR_CannotInferType of { loc: location } @@ -169,12 +181,6 @@ let string_of_type_checking_error = function Format.sprintf "%s: procedure cannot return value" (string_of_location loc) - | TCERR_InvalidRedeclaration {loc; id; previous} -> - Format.sprintf "%s: invalid redeclaration: %s: previous type: %s" - (string_of_location loc) - (string_of_identifier id) - (string_of_env_type previous) - | TCERR_ShadowsPreviousDefinition {loc; id} -> Format.sprintf "%s: shadows previous definition: %s" (string_of_location loc) @@ -188,19 +194,30 @@ let string_of_type_checking_error = function Format.sprintf "%s: cannot infer type" (string_of_location loc) - module MakeErrorReporter () = struct + + + + module MakeCollectingErrorReporter () = struct let r = ref [] let add e = r := e :: !r + let wrap f x = + let result = f x in + let errors = List.rev !r in + r := []; + match errors with + | [] -> Ok result + | xs -> Error xs + let report_type_mismatch ~loc ~expected ~actual = add @@ TCERR_TypeMismatch {loc;expected;actual} let report_binding_type_mismatch ~loc ~expected ~actual ~id = add @@ TCERR_BindingTypeMismatch {loc;expected;actual; id} - let report_error ~loc ~descr = + let report_other_error ~loc ~descr = add @@ TCERR_OtherError {loc; descr} let report_identifier_is_not_variable ~loc ~id = @@ -239,19 +256,77 @@ let string_of_type_checking_error = function let report_shadows_previous_definition ~loc ~id = add @@ TCERR_ShadowsPreviousDefinition {loc; id} - let report_invalid_redeclaration ~loc ~id ~previous = - add @@ TCERR_InvalidRedeclaration {loc; id; previous} - let report_array_initialization_forbidden ~loc = add @@ TCERR_ArrayInitializationForbidden {loc} let report_cannot_infer ~loc = add @@ TCERR_CannotInferType {loc} - let flush () = - let result = List.rev !r in - r := []; - result + end + + (* Kopia poniewaz chcemy aby typ wyniku funkcji `add` był dowolny bo sterowanie się kończy przez raise *) + module MakeOneShotErrorReporter() = struct + + exception TypeCheckingError of type_checking_error + + let add e = raise (TypeCheckingError e) - end
\ No newline at end of file + let wrap f x = + try + Ok (f x) + with (TypeCheckingError e) -> + Error [e] + + let report_type_mismatch ~loc ~expected ~actual = + add @@ TCERR_TypeMismatch {loc;expected;actual} + + let report_binding_type_mismatch ~loc ~expected ~actual ~id = + add @@ TCERR_BindingTypeMismatch {loc;expected;actual; id} + + let report_other_error ~loc ~descr = + add @@ TCERR_OtherError {loc; descr} + + let report_identifier_is_not_variable ~loc ~id = + add @@ TCERR_IdentifierIsNotVariable {loc; id} + + let report_unknown_identifier ~loc ~id = + add @@ TCERR_UnknownIdentifier {loc; id} + + let report_identifier_is_not_callable ~loc ~id = + add @@ TCERR_IdentifierIsNotCallable {loc; id} + + let report_bad_number_of_arguments ~loc ~expected ~actual = + add @@ TCERR_BadNumberOfActualArguments {loc; expected; actual} + + let report_bad_number_of_return_values ~loc ~expected ~actual = + add @@ TCERR_BadNumberOfReturnValues {loc; expected; actual} + + let report_expected_function_returning_one_value ~loc ~id = + add @@ TCERR_ExpectedFunctionReturningOneValue {loc;id} + + let report_expected_function_returning_many_values ~loc ~id ~expected ~actual = + add @@ TCERR_ExpectedFunctionReturningManyValues {loc;id; expected;actual} + + let report_function_must_return_something ~loc = + add @@ TCERR_FunctionMustReturnValue {loc} + + let report_procedure_cannot_return_value ~loc = + add @@ TCERR_ProcedureCannotReturnValue {loc} + + let report_expected_array ~loc ~actual = + add @@ TCERR_ExpectedArray {loc; actual} + + let report_not_all_control_paths_return_value ~loc ~id = + add @@ TCERR_NotAllControlPathsReturnValue {loc; id} + + let report_shadows_previous_definition ~loc ~id = + add @@ TCERR_ShadowsPreviousDefinition {loc; id} + + let report_array_initialization_forbidden ~loc = + add @@ TCERR_ArrayInitializationForbidden {loc} + + let report_cannot_infer ~loc = + add @@ TCERR_CannotInferType {loc} + + end diff --git a/source/xi_lib/types.ml b/source/xi_lib/types.ml index 14809cc..398b2e9 100644 --- a/source/xi_lib/types.ml +++ b/source/xi_lib/types.ml @@ -1,4 +1,3 @@ - type normal_type = TP_Int | TP_Bool @@ -9,6 +8,11 @@ let rec string_of_normal_type = function | TP_Bool -> "bool" | TP_Array el -> string_of_normal_type el ^ "[]" +(* Rozszerzony typ + * Lista 0 elementów - unit + * Lista 1 element - normalny typ + * Lista n elementów - krotka + *) type extended_type = normal_type list let string_of_extended_type xs = @@ -28,4 +32,47 @@ let string_of_env_type = function (string_of_extended_type xs) | ENVTP_Fn (xs, rs) -> Format.sprintf "fn(%s) -> (%s)" (string_of_extended_type xs) - (string_of_extended_type rs)
\ No newline at end of file + (string_of_extended_type rs) + +module TypingEnvironment = struct + + (* W przeciwieństwie do specyfikacji nie trzymamy specjalnej zmiennej `ro` + * oznaczającej return type. Trzymamy to w oddzielnym polu dla + * przejrzystości. + *) + + type t = + { mapping: env_type Ast.IdMap.t + ; return: extended_type option + } + + (* Dodaj do środowiska. + * Zwraca nowe środowisko oraz informację czy dany klucz `x` już nie był + * w kontekście. Jak był to nic nie zwracamy, klient zapyta o starą wartość + * by zgłosić komunikat o błędzie. Ta informacja o dodawaniu jest używana + * aby wykrywać przykrywanie zmiennych. + *) + let add (x:Ast.identifier) (t:env_type) (env:t) = + if Ast.IdMap.mem x env.mapping then + env , + false + else + {env with mapping=Ast.IdMap.add x t env.mapping}, + true + + (* Pobranie, zwraca option *) + let lookup x (t : t) = Ast.IdMap.find_opt x t.mapping + + (* Gdy wiemy że klucz jest w bazie i nie chce nam się rozpatrywać czy było + * Some czy None *) + let lookup_unsafe x t = + match lookup x t with + | None -> failwith "TypingEnvironment.lookup_unsafe failed" + | Some x -> x + + let empty : t = { mapping=Ast.IdMap.empty; return=None} + + let set_return t r = {t with return=Some r} + + let get_return t = t.return +end
\ No newline at end of file |