Sketch-out a dummy escape-finding module

[tiger.ml.git] / compiler / src / lib / tiger / tiger_semant.ml

diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml
index b19c6fc..25eb2ce 100644 (file)
--- a/compiler/src/lib/tiger/tiger_semant.ml
+++ b/compiler/src/lib/tiger/tiger_semant.ml
@@ -1,8 +1,12 @@
 module List = ListLabels
 
 module A         = Tiger_absyn
+module Dag       = Tiger_dag
 module Env       = Tiger_env
 module E         = Tiger_error
+module Escape    = Tiger_semant_escape
+module Pos       = Tiger_position
+module Sym       = Tiger_symbol
 module Translate = Tiger_translate
 module Type      = Tiger_env_type
 module Value     = Tiger_env_value
@@ -77,6 +81,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
@@ -158,16 +193,25 @@ end = struct
       | A.WhileExp {test; body; pos} ->
           (* test : must be int, because we have no bool *)
           check_int (trexp test) ~pos;
-          ignore (trexp body);  (* Only care if a type-error is raised *)
+          let (loop, env) = Env.loop_begin env in
+          (* Only care if an error is raised *)
+          ignore (transExp ~env body);
+          ignore (Env.loop_end env loop);
           return_unit
       | A.ForExp {var; lo; hi; body; pos; escape=_} ->
           check_int (trexp lo) ~pos;
           check_int (trexp hi) ~pos;
-          (* Only care if a type-error is raised *)
+          let (loop, env) = Env.loop_begin env in
           let env = Env.set_val env var (Value.Var {ty = Type.Int}) in
+          (* Only care if an error is raised *)
           ignore (transExp ~env body);
+          ignore (Env.loop_end env loop);
           return_unit
-      | A.BreakExp _ ->
+      | A.BreakExp pos ->
+          (match Env.loop_current env with
+          | Some _ -> ()
+          | None   -> E.raise (E.Break_outside_loop pos)
+          );
           return_unit
       | A.LetExp {decs; body; pos=_} ->
           (* (1) decs augment env *)
@@ -285,15 +329,16 @@ 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=_}) ->
               Env.set_typ env name (Type.Name (name, ref None))
           )
         in
-        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
+        List.iter typedecs ~f:(fun (A.TypeDec {name=ty_name; ty=ty_exp; pos}) ->
+          let ty = transTy ~env ~ty_name ~ty_exp in
+          (match env_get_typ ~sym:ty_name ~env ~pos with
           | Type.Name (_, ty_opt_ref) ->
               ty_opt_ref := Some ty
           | Type.Unit
@@ -338,7 +383,7 @@ end = struct
         );
         env_with_fun_heads_only
     )
-  and transTy ~(env : Env.t) (ty_exp : A.ty) : Type.t =
+  and transTy ~(env : Env.t) ~ty_name ~(ty_exp : A.ty) : Type.t =
     (match ty_exp with
     | A.NameTy {symbol=sym; pos} ->
         env_get_typ ~sym ~env ~pos
@@ -349,15 +394,16 @@ end = struct
             (name, ty)
           )
         in
-        Type.new_record fields
+        Type.new_record ~name:ty_name ~fields
     | A.ArrayTy {symbol=sym; pos} ->
         let element_ty = env_get_typ ~sym ~env ~pos in
-        Type.new_array element_ty
+        Type.new_array ~name:ty_name ~ty:element_ty
     )
 end
 
 open Semant
 
 let transProg absyn =
+  Escape.find absyn;
   let {exp = _; ty = _} = transExp absyn ~env:Env.base in
   ()