Status
------
-
+
...
-
+
### Features
#### Done
- [-] grid view (cols: lex, pars, semant, etc.; rows: test cases.)
- [x] implementation
- [ ] refactoring
+ - [ ] test time-outs (motive: cycle non-detection caused an infinite loop)
+ - [ ] parallel test execution
- [ ] Travis CI
Implementation Notes
--- /dev/null
+module List = ListLabels
+
+module Map = Tiger_map
+module Opt = Tiger_opt
+
+type t =
+ unit
+
+type count =
+ { parents : int
+ ; children : int
+ }
+
+let of_list pairs =
+ let incr counts k incr =
+ let prev = Opt.get (Map.get counts ~k) ~default:{parents=0; children=0} in
+ Map.set counts ~k ~v:(incr prev)
+ in
+ let incr_parents count = {count with parents = succ count.parents} in
+ let incr_children count = {count with children = succ count.children} in
+ let zero_children counts =
+ List.filter (Map.to_list counts) ~f:(fun (_, {children=c; _}) -> c = 0 )
+ in
+ let zero_parents counts =
+ List.filter (Map.to_list counts) ~f:(fun (_, {parents=p; _}) -> p = 0 )
+ in
+ let counts =
+ List.fold_left pairs ~init:Map.empty ~f:(
+ fun counts (p, c) ->
+ let counts = incr counts p incr_children in
+ let counts = incr counts c incr_parents in
+ counts
+ )
+ in
+ (* At least one node with no in-coming links and
+ * at least one node with no out-going links. *)
+ match (zero_parents counts, zero_children counts) with
+ | _ :: _, _ :: _ -> Ok ()
+ | _, _ -> Error `Cycle
--- /dev/null
+type t
+
+val of_list : ('a * 'a) list -> (t, [`Cycle]) result
module Typ = Tiger_env_type
type t =
+ | Cycle_in_type_decs of
+ { from_id : Sym.t
+ ; from_pos : Pos.t
+ ; to_id : Sym.t
+ ; to_pos : 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)
+ | 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).")
+ (Sym.to_string from_id)
+ (Sym.to_string to_id)
+ (Sym.to_string from_id)
+ (Pos.to_string from_pos)
+ (Sym.to_string to_id)
+ (Pos.to_string to_pos)
| Unknown_id {id; pos} ->
s "Unknown identifier %S in %s" (Sym.to_string id) (Pos.to_string pos)
| Unknown_type {ty_id; pos} ->
match t with
| Unknown_id _ ->
true
+ | Cycle_in_type_decs _
| Invalid_syntax _
| Unknown_type _
| Id_is_a_function _
match t with
| Unknown_type _ ->
true
+ | Cycle_in_type_decs _
| Unknown_id _
| Invalid_syntax _
| Id_is_a_function _
match t with
| Wrong_type _ ->
true
+ | Cycle_in_type_decs _
| Unknown_type _
| Unknown_id _
| Invalid_syntax _
match t with
| Wrong_number_of_args _ ->
true
+ | Cycle_in_type_decs _
| Wrong_type _
| Unknown_type _
| Unknown_id _
match t with
| Invalid_syntax _ ->
true
+ | Cycle_in_type_decs _
| Wrong_type _
| Unknown_type _
| Unknown_id _
match t with
| Exp_not_a_record _ ->
true
+ | Cycle_in_type_decs _
| Invalid_syntax _
| Wrong_type _
| Unknown_type _
match t with
| Exp_not_an_array _ ->
true
+ | Cycle_in_type_decs _
| Exp_not_a_record _
| Invalid_syntax _
| Wrong_type _
match t with
| No_such_field_in_record _ ->
true
+ | Cycle_in_type_decs _
+ | 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_cycle_in_type_dec t =
+ match t with
+ | Cycle_in_type_decs _ ->
+ true
+ | No_such_field_in_record _
| Exp_not_an_array _
| Exp_not_a_record _
| Invalid_syntax _
module Typ = Tiger_env_type
type t =
+ | Cycle_in_type_decs of
+ { from_id : Sym.t
+ ; from_pos : Pos.t
+ ; to_id : Sym.t
+ ; to_pos : 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_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
let of_list pairs =
List.fold_left pairs ~init:empty ~f:(fun t (k, v) -> set t ~k ~v)
+
+let rec to_list = function
+ | Leaf ->
+ []
+ | Node (_, pair, left, right) ->
+ pair :: ((to_list left) @ (to_list right))
val to_dot : ('k, 'v) t -> k_to_string:('k -> string) -> string
- val of_list : ('k * 'v) list -> ('k, 'v) t
+ val of_list : ('k * 'v) list -> ('k , 'v) t
+ val to_list : ('k , 'v) t -> ('k * 'v) list
end
module List = ListLabels
module A = Tiger_absyn
+module Dag = Tiger_dag
module Env = Tiger_env
module E = Tiger_error
+module Pos = Tiger_position
+module Sym = Tiger_symbol
module Translate = Tiger_translate
module Type = Tiger_env_type
module Value = Tiger_env_value
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
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=_}) ->
lst \n\
end"
)
+ ; ( Test.case
+ "Cycle in type dec"
+ ~code:"\
+ let \n\
+ type a = b \n\
+ type b = a \n\
+ in \n\
+ end \
+ "
+ ~is_error_expected_semant:(Some Error.is_cycle_in_type_dec)
+ )
+ ; ( Test.case
+ "Cycle in type dec"
+ ~code:"\
+ let \n\
+ type a = b \n\
+ type b = c \n\
+ type c = a \n\
+ var x : a := 1 \n\
+ in \n\
+ end \
+ "
+ ~is_error_expected_semant:(Some Error.is_cycle_in_type_dec)
+ )
]
let book ~dir =
let is_error_expected_semant_of_filename =
let module E = Tiger_error in
function
+ | "test16.tig" ->
+ Some Error.is_cycle_in_type_dec
+ (* TODO: Be more specific - between which decs? *)
| "test17.tig"
| "test33.tig" ->
Some Error.is_unknown_type
home / code / tiger.ml.git / commitdiff
