summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPaweł Dybiec <pdybiec@stud.cs.uni.wroc.pl>2018-11-24 17:52:48 +0100
committerPaweł Dybiec <pdybiec@stud.cs.uni.wroc.pl>2018-11-24 17:52:48 +0100
commit45db6551fd1860159e9babd53b68a67302e57e37 (patch)
treeef726bd338486459ad4e3f77efbaffbd7a61b82f
parent96b8e795b776c2e195d5551e136ced85b8b44141 (diff)
Upgrade base
-rw-r--r--source/mod_student/plugin.ml15
-rw-r--r--source/mod_student/typechecker.ml231
-rw-r--r--source/xi/.merlin15
-rw-r--r--source/xi/pipeline.ml14
-rw-r--r--source/xi/xi.ml2
-rw-r--r--source/xi_lib/.merlin5
-rw-r--r--source/xi_lib/iface.ml2
-rw-r--r--source/xi_lib/typechecker_errors.ml119
-rw-r--r--source/xi_lib/types.ml51
-rw-r--r--xisdk/mod_uwr.cmabin1183174 -> 1205101 bytes
10 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
diff --git a/xisdk/mod_uwr.cma b/xisdk/mod_uwr.cma
index 5e94a9d..1bb9965 100644
--- a/xisdk/mod_uwr.cma
+++ b/xisdk/mod_uwr.cma
Binary files differ