From: Siraaj Khandkar <siraaj@khandkar.net>
Date: Tue, 18 Sep 2018 20:31:45 +0000 (-0400)
Subject: Check scope of break statements
X-Git-Url: https://git.xandkar.net/?p=tiger.ml.git;a=commitdiff_plain;h=35dccbd3999a8c3bb1dc9e96e21b69a39f44fc6f

Check scope of break statements
---

diff --git a/compiler/src/lib/tiger/tiger_env.ml b/compiler/src/lib/tiger/tiger_env.ml
index f698f89..1e4cd1d 100644
--- a/compiler/src/lib/tiger/tiger_env.ml
+++ b/compiler/src/lib/tiger/tiger_env.ml
@@ -1,15 +1,18 @@
 module Map   = Tiger_map
+module Sym   = Tiger_symbol
 module Type  = Tiger_env_type
 module Value = Tiger_env_value
 
 type t =
   { typs : Type.env
   ; vals : Value.env
+  ; loop : Sym.t option
   }
 
 let base =
   { typs = Type.built_in
   ; vals = Value.built_in
+  ; loop = None
   }
 
 let get_typ {typs; _} k =
@@ -23,3 +26,20 @@ let set_typ t k v =
 
 let set_val t k v =
   {t with vals = Map.set t.vals ~k ~v}
+
+let loop_begin t =
+  let loop = Sym.new_of_string "loop" in
+  let t = {t with loop = Some loop} in
+  (loop, t)
+
+let loop_end t given =
+  match t.loop with
+  | None ->
+      assert false
+  | Some current when (not (Sym.is_equal current given)) ->
+      assert false
+  | Some _ ->
+      {t with loop = None}
+
+let loop_current {loop; _} =
+  loop
diff --git a/compiler/src/lib/tiger/tiger_env.mli b/compiler/src/lib/tiger/tiger_env.mli
index 91747e5..3338949 100644
--- a/compiler/src/lib/tiger/tiger_env.mli
+++ b/compiler/src/lib/tiger/tiger_env.mli
@@ -7,3 +7,7 @@ val get_val : t -> Tiger_symbol.t -> Tiger_env_value.t option
 
 val set_typ : t -> Tiger_symbol.t -> Tiger_env_type.t -> t
 val set_val : t -> Tiger_symbol.t -> Tiger_env_value.t -> t
+
+val loop_begin   : t -> (Tiger_symbol.t * t)
+val loop_end     : t ->  Tiger_symbol.t -> t
+val loop_current : t ->  Tiger_symbol.t option
diff --git a/compiler/src/lib/tiger/tiger_error.ml b/compiler/src/lib/tiger/tiger_error.ml
index 11b4b95..f2b3ae1 100644
--- a/compiler/src/lib/tiger/tiger_error.ml
+++ b/compiler/src/lib/tiger/tiger_error.ml
@@ -10,6 +10,7 @@ type t =
       ;   to_id  : Sym.t
       ;   to_pos : Pos.t
       }
+  | Break_outside_loop of Pos.t
   | Invalid_syntax    of Pos.t
   | Unknown_id        of {id    : Sym.t; pos : Pos.t}
   | Unknown_type      of {ty_id : Sym.t; pos : Pos.t}
@@ -80,6 +81,8 @@ let to_string =
   function
   | Invalid_syntax pos ->
       s "Invalid syntax in %s" (Pos.to_string pos)
+  | Break_outside_loop pos ->
+      s "Break statement is not within a loop. In %s" (Pos.to_string pos)
   | Cycle_in_type_decs  {from_id; from_pos; to_id; to_pos} ->
       s ( "Circular type declaration between %S and %S."
         ^^"Locations: %S (in %s), %S (in %s).")
@@ -167,6 +170,7 @@ let is_unknown_id t =
   match t with
   | Unknown_id _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Invalid_syntax _
   | Unknown_type _
@@ -190,6 +194,7 @@ let is_unknown_type t =
   match t with
   | Unknown_type _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Unknown_id _
   | Invalid_syntax _
@@ -213,6 +218,7 @@ let is_wrong_type t =
   match t with
   | Wrong_type _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Unknown_type _
   | Unknown_id _
@@ -236,6 +242,7 @@ let is_wrong_number_of_args t =
   match t with
   | Wrong_number_of_args _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Wrong_type _
   | Unknown_type _
@@ -259,6 +266,7 @@ let is_invalid_syntax t =
   match t with
   | Invalid_syntax _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Wrong_type _
   | Unknown_type _
@@ -282,6 +290,7 @@ let is_not_a_record t =
   match t with
   | Exp_not_a_record _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Invalid_syntax _
   | Wrong_type _
@@ -305,6 +314,7 @@ let is_not_an_array t =
   match t with
   | Exp_not_an_array _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Exp_not_a_record _
   | Invalid_syntax _
@@ -328,6 +338,7 @@ let is_no_such_field_in_record t =
   match t with
   | No_such_field_in_record _ ->
       true
+  | Break_outside_loop _
   | Cycle_in_type_decs _
   | Exp_not_an_array _
   | Exp_not_a_record _
@@ -351,6 +362,31 @@ let is_cycle_in_type_dec t =
   match t with
   | Cycle_in_type_decs _ ->
       true
+  | Break_outside_loop _
+  | No_such_field_in_record _
+  | Exp_not_an_array _
+  | Exp_not_a_record _
+  | Invalid_syntax _
+  | Wrong_type _
+  | Unknown_type _
+  | Unknown_id _
+  | Id_is_a_function _
+  | Id_not_a_function _
+  | Wrong_type_of_expression_in_var_dec _
+  | Wrong_type_used_as_array _
+  | Wrong_type_used_as_record _
+  | Wrong_type_of_field_value _
+  | Wrong_type_of_arg _
+  | Wrong_number_of_args _
+  | Invalid_operand_type _
+  | Different_operand_types _ ->
+      false
+
+let is_break_outside_loop t =
+  match t with
+  | Break_outside_loop _ ->
+      true
+  | Cycle_in_type_decs _
   | No_such_field_in_record _
   | Exp_not_an_array _
   | Exp_not_a_record _
diff --git a/compiler/src/lib/tiger/tiger_error.mli b/compiler/src/lib/tiger/tiger_error.mli
index 73505b8..0344269 100644
--- a/compiler/src/lib/tiger/tiger_error.mli
+++ b/compiler/src/lib/tiger/tiger_error.mli
@@ -10,6 +10,7 @@ type t =
       ;   to_id  : Sym.t
       ;   to_pos : Pos.t
       }
+  | Break_outside_loop of Pos.t
   | Invalid_syntax    of Pos.t
   | Unknown_id        of {id    : Sym.t; pos : Pos.t}
   | Unknown_type      of {ty_id : Sym.t; pos : Pos.t}
@@ -85,3 +86,4 @@ val is_not_a_record : t -> bool
 val is_not_an_array : t -> bool
 val is_no_such_field_in_record : t -> bool
 val is_cycle_in_type_dec : t -> bool
+val is_break_outside_loop : t -> bool
diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml
index 6bb45fd..19e8c8b 100644
--- a/compiler/src/lib/tiger/tiger_semant.ml
+++ b/compiler/src/lib/tiger/tiger_semant.ml
@@ -192,16 +192,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 *)
diff --git a/compiler/src/lib/tiger/tiger_symbol.ml b/compiler/src/lib/tiger/tiger_symbol.ml
index f1dc51a..b5d895b 100644
--- a/compiler/src/lib/tiger/tiger_symbol.ml
+++ b/compiler/src/lib/tiger/tiger_symbol.ml
@@ -5,22 +5,30 @@ type t =
   ; symbol : int
   }
 
-let nextsym = ref 0
+let counter = ref 0
 
 let symbols = H.create 16
 
+let next name =
+  incr counter;
+  let symbol = !counter in
+  {name; symbol}
+
+let new_of_string name =
+  let t = next name in
+  H.replace symbols ~key:t.name ~data:t.symbol;
+  t
+
 let of_string name =
   match H.find_opt symbols name with
-  | Some symbol ->
-      {name; symbol}
-  | None ->
-      incr nextsym;
-      let symbol = !nextsym in
-      H.replace symbols ~key:name ~data:symbol;
-      {name; symbol}
+  | Some s -> {name; symbol=s}
+  | None   -> new_of_string name
 
 let to_string {name; _} =
   name
 
 let is_equal {symbol=s1; _} {symbol=s2; _} =
   s1 = s2
+
+let show {name; symbol} =
+  Printf.sprintf "Symbol[%S, %d]" name symbol
diff --git a/compiler/src/lib/tiger/tiger_symbol.mli b/compiler/src/lib/tiger/tiger_symbol.mli
index e5c560f..1dd5acc 100644
--- a/compiler/src/lib/tiger/tiger_symbol.mli
+++ b/compiler/src/lib/tiger/tiger_symbol.mli
@@ -1,7 +1,13 @@
 type t
 
+val new_of_string : string -> t
+
 val of_string : string -> t
 
 val to_string : t -> string
+(* Reversable. Returns original. *)
+
+val show : t -> string
+(* Not-reversable. M-expression with name and symbol. *)
 
 val is_equal : t -> t -> bool
diff --git a/compiler/src/lib/tiger/tiger_test_cases.ml b/compiler/src/lib/tiger/tiger_test_cases.ml
index 082e02f..1ead5f5 100644
--- a/compiler/src/lib/tiger/tiger_test_cases.ml
+++ b/compiler/src/lib/tiger/tiger_test_cases.ml
@@ -120,6 +120,30 @@ let micro =
         "
         ~is_error_expected_semant:(Some Error.is_cycle_in_type_dec)
     )
+  ; ( Test.case
+        "Break outside loop"
+        ~code:
+          "break"
+        ~is_error_expected_semant:(Some Error.is_break_outside_loop)
+    )
+  ; ( Test.case
+        "Break within for loop"
+        ~code:"for i := 0 to 5 do (print(\"x\"); break)"
+    )
+  ; ( Test.case
+        "Break after for loop"
+        ~code:"(for i := 0 to 5 do (print(\"x\"); break); break)"
+        ~is_error_expected_semant:(Some Error.is_break_outside_loop)
+    )
+  ; ( Test.case
+        "Break within while loop"
+        ~code:"while 1 do (print(\"x\"); break)"
+    )
+  ; ( Test.case
+        "Break after while loop"
+        ~code:"(while 1 do (print(\"x\"); break); break)"
+        ~is_error_expected_semant:(Some Error.is_break_outside_loop)
+    )
   ]
 
 let book ~dir =
diff --git a/screenshots/tests-tail.jpg b/screenshots/tests-tail.jpg
index b0c72d7..10e7dbe 100644
Binary files a/screenshots/tests-tail.jpg and b/screenshots/tests-tail.jpg differ