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 =
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
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
; 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}
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).")
match t with
| Unknown_id _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Invalid_syntax _
| Unknown_type _
match t with
| Unknown_type _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Unknown_id _
| Invalid_syntax _
match t with
| Wrong_type _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Unknown_type _
| Unknown_id _
match t with
| Wrong_number_of_args _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Wrong_type _
| Unknown_type _
match t with
| Invalid_syntax _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Wrong_type _
| Unknown_type _
match t with
| Exp_not_a_record _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Invalid_syntax _
| Wrong_type _
match t with
| Exp_not_an_array _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Exp_not_a_record _
| Invalid_syntax _
match t with
| No_such_field_in_record _ ->
true
+ | Break_outside_loop _
| Cycle_in_type_decs _
| Exp_not_an_array _
| Exp_not_a_record _
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 _
; 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}
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
| 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 *)
; 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
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
"
~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 =
home / code / tiger.ml.git / commitdiff
