From af7ed8a78a3e8d10a86832af633d4bca376a470c Mon Sep 17 00:00:00 2001
From: Paweł Dybiec <pdybiec@stud.cs.uni.wroc.pl>
Date: Sun, 25 Nov 2018 02:47:34 +0100
Subject: Types for function calls

---
 source/mod_student/typechecker.ml | 44 ++++++++++++++++++++++++++++++++-------
 1 file changed, 36 insertions(+), 8 deletions(-)

(limited to 'source/mod_student/typechecker.ml')

diff --git a/source/mod_student/typechecker.ml b/source/mod_student/typechecker.ml
index 0d4d76d..ce396d9 100644
--- a/source/mod_student/typechecker.ml
+++ b/source/mod_student/typechecker.ml
@@ -140,9 +140,27 @@ module Make() = struct
       | EXPR_Struct {elements=x::xs; _} ->
         failwith "not yet implemented"
 
-    and check_function_call env call = 
-      failwith "not yet implemented"
-
+    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
     (* --------------------------------------------------- *)
     (* Odgórna strategia: zapish w node2type_map oczekiwanie a następnie
      * sprawdź czy nie zachodzi specjalny przypadek. *)
@@ -173,8 +191,10 @@ module Make() = struct
     (* --------------------------------------------------- *)
     (* Pomocnicza funkcja do sprawdzania wywołania procedury *)
 
-    let check_procedure_call env call : unit = 
-      failwith "not yet implemented"
+    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 *)
@@ -198,6 +218,7 @@ module Make() = struct
         env, RT_Unit
 
       | STMT_MultiVarDecl {vars; init; _} ->
+        
         failwith "not yet implemented"
 
       | STMT_Block body ->
@@ -208,7 +229,14 @@ module Make() = struct
         env, RT_Unit
 
       | STMT_If {cond;then_branch;else_branch; _} ->
-        failwith "not yet implemented"
+        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
@@ -247,8 +275,8 @@ module Make() = struct
 
       | STMT_While {cond; body; _} ->
         check_expression env TP_Bool cond;
-        (* TODO *)
-        failwith "not yet implemented"
+        let _ = check_statement env body in
+        env,RT_Unit
 
     and check_statement_block env (STMTBlock {body; _}) =
         let rec aux env = function
-- 
cgit 1.4.1