X-Git-Url: https://git.xandkar.net/?p=tiger.ml.git;a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_semant.ml;h=6bb45fd515a5fb3fe1788417118c5b4b2c144b5a;hp=8d0ca11a4d8c6afadcc92a7bcf743b46a51e10f1;hb=e6e82c0866db4eb08f956b2582e5c2ed5399e986;hpb=cbb4ffb6428f52eaea42f6039332af0c392cdd0f

diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml
index 8d0ca11..6bb45fd 100644
--- a/compiler/src/lib/tiger/tiger_semant.ml
+++ b/compiler/src/lib/tiger/tiger_semant.ml
@@ -1,9 +1,11 @@
 module List = ListLabels
 
 module A         = Tiger_absyn
+module Dag       = Tiger_dag
 module Env       = Tiger_env
 module E         = Tiger_error
-module Symbol    = Tiger_symbol
+module Pos       = Tiger_position
+module Sym       = Tiger_symbol
 module Translate = Tiger_translate
 module Type      = Tiger_env_type
 module Value     = Tiger_env_value
@@ -78,6 +80,37 @@ end = struct
   let check_int expty ~pos : unit =
     check_same return_int expty ~pos
 
+  let paths_of_typedecs typedecs : (Sym.t * Sym.t * Pos.t) list list =
+    let (path, paths) =
+      List.fold_left typedecs ~init:([], []) ~f:(
+        fun (path, paths) (A.TypeDec {name=child; ty; pos}) ->
+          match ty with
+          | A.NameTy {symbol=parent; _} ->
+              (((parent, child, pos) :: path), paths)
+          | A.RecordTy _
+          | A.ArrayTy _ ->
+              ([], path :: paths)
+      )
+    in
+    List.map (path :: paths) ~f:List.rev
+
+  let check_cycles (typedecs : A.typedec list) : unit =
+    let non_empty_paths =
+      List.filter
+        (paths_of_typedecs typedecs)
+        ~f:(function [] -> false | _ -> true)
+    in
+    List.iter non_empty_paths ~f:(
+      fun path ->
+        match Dag.of_list (List.map path ~f:(fun (p, c, _) -> (p, c))) with
+        | Ok _ ->
+            ()
+        | Error `Cycle ->
+            let (_, from_id, from_pos) = List.hd           path  in
+            let (_,   to_id,   to_pos) = List.hd (List.rev path) in
+            E.raise (E.Cycle_in_type_decs {from_id; from_pos; to_id; to_pos})
+    )
+
   let rec transExp ~env exp =
     let rec trexp exp =
       (match exp with
@@ -90,10 +123,20 @@ end = struct
       | A.CallExp {func; args; pos} ->
           (match env_get_val ~sym:func ~env ~pos with
           | Value.Fun {formals; result} ->
-              List.iter2 formals args ~f:(fun ty_expected exp_given ->
-                check_same (return (actual_ty ~pos ty_expected)) (trexp exp_given) ~pos;
-              );
-              return (actual_ty ~pos result)
+              let expected = List.length formals in
+              let given    = List.length args in
+              if given = expected then
+                begin
+                  List.iter2 formals args ~f:(fun ty_expected exp_given ->
+                    check_same
+                      (return (actual_ty ~pos ty_expected))
+                      (trexp exp_given)
+                      ~pos;
+                  );
+                  return (actual_ty ~pos result)
+                end
+              else
+                E.raise (E.Wrong_number_of_args {func; expected; given; pos})
           | Value.Var _ ->
               E.raise (E.Id_not_a_function {id=func; pos})
           )
@@ -276,6 +319,7 @@ end = struct
         in
         Env.set_val env name (Value.Var {ty})
     | A.TypeDecs typedecs ->
+        check_cycles typedecs;
         let env =
           List.fold_left typedecs ~init:env ~f:(
             fun env (A.TypeDec {name; ty=_; pos=_}) ->
@@ -285,7 +329,7 @@ end = struct
         List.iter typedecs ~f:(fun (A.TypeDec {name; ty=ty_exp; pos}) ->
           let ty = transTy ~env ty_exp in
           (match env_get_typ ~sym:name ~env ~pos with
-          | Type.Name (name, ty_opt_ref) ->
+          | Type.Name (_, ty_opt_ref) ->
               ty_opt_ref := Some ty
           | Type.Unit
           | Type.Nil
@@ -298,28 +342,36 @@ end = struct
         );
         env
     | A.FunDecs fundecs ->
-        List.fold_left fundecs ~init:env ~f:(
-          fun env (A.FunDec {name; params; result; body; pos=_}) ->
-            let (env_for_body, formals_in_reverse_order) =
-              List.fold_left params ~init:(env, []) ~f:(
-                fun (env, formals) (A.Field {name; escape=_; typ; pos}) ->
-                  let ty = env_get_typ_actual ~env ~sym:typ ~pos in
-                  let env = Env.set_val env name (Value.Var {ty}) in
-                  (env, ty :: formals)
+        let env_with_fun_heads_only =
+          List.fold_left fundecs ~init:env ~f:(
+            fun env (A.FunDec {name; params; result; body=_; pos=_}) ->
+              let formals =
+                List.map params ~f:(
+                  fun (A.Field {name=_; typ; pos; escape=_}) ->
+                    env_get_typ_actual ~env ~sym:typ ~pos
+                )
+              in
+              let result =
+                match result with
+                | Some (s, p) -> env_get_typ_actual ~sym:s ~env ~pos:p
+                | None        -> Type.Unit
+              in
+              Env.set_val env name (Value.Fun {formals; result})
+          )
+        in
+        List.iter fundecs ~f:(
+          fun (A.FunDec {name=_; params; result=_; body; pos=_}) ->
+            let env_with_fun_heads_and_local_vars =
+              List.fold_left params ~init:env_with_fun_heads_only ~f:(
+                fun env (A.Field {name=var_name; escape=_; typ; pos}) ->
+                  let var_ty = env_get_typ_actual ~env ~sym:typ ~pos in
+                  Env.set_val env var_name (Value.Var {ty = var_ty})
               )
             in
-            (* ignore because we only care if an exception is raised *)
-            ignore (transExp ~env:env_for_body body);
-            let formals = List.rev formals_in_reverse_order in
-            let result =
-              match result with
-              | None ->
-                  Type.Unit
-              | Some (sym, pos) ->
-                  env_get_typ_actual ~sym ~env ~pos
-            in
-            Env.set_val env name (Value.Fun {formals; result})
-        )
+            (* we only care if an exception is raised *)
+            ignore (transExp ~env:env_with_fun_heads_and_local_vars body);
+        );
+        env_with_fun_heads_only
     )
   and transTy ~(env : Env.t) (ty_exp : A.ty) : Type.t =
     (match ty_exp with