From: Siraaj Khandkar Date: Tue, 18 Sep 2018 18:43:58 +0000 (-0400) Subject: Detect cycles in type declarations X-Git-Url: https://git.xandkar.net/?p=tiger.ml.git;a=commitdiff_plain;h=e6e82c0866db4eb08f956b2582e5c2ed5399e986 Detect cycles in type declarations --- diff --git a/README.md b/README.md index 571377a..cae72e2 100644 --- a/README.md +++ b/README.md @@ -5,9 +5,9 @@ A Tiger-compiler implementation in (OCa)ML Status ------ -![screenshot-tests-semant-done-head](screenshots/tests-semant-done-head.jpg) +![screenshot-tests-head](screenshots/tests-head.jpg) ... -![screenshot-tests-semant-done-tail](screenshots/tests-semant-done-tail.jpg) +![screenshot-tests-tail](screenshots/tests-tail.jpg) ### Features #### Done @@ -49,6 +49,8 @@ Status - [-] 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 diff --git a/compiler/src/lib/tiger/tiger_dag.ml b/compiler/src/lib/tiger/tiger_dag.ml new file mode 100644 index 0000000..f843506 --- /dev/null +++ b/compiler/src/lib/tiger/tiger_dag.ml @@ -0,0 +1,39 @@ +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 diff --git a/compiler/src/lib/tiger/tiger_dag.mli b/compiler/src/lib/tiger/tiger_dag.mli new file mode 100644 index 0000000..0968482 --- /dev/null +++ b/compiler/src/lib/tiger/tiger_dag.mli @@ -0,0 +1,3 @@ +type t + +val of_list : ('a * 'a) list -> (t, [`Cycle]) result diff --git a/compiler/src/lib/tiger/tiger_error.ml b/compiler/src/lib/tiger/tiger_error.ml index 88096a2..11b4b95 100644 --- a/compiler/src/lib/tiger/tiger_error.ml +++ b/compiler/src/lib/tiger/tiger_error.ml @@ -4,6 +4,12 @@ module Sym = Tiger_symbol 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} @@ -74,6 +80,15 @@ let to_string = 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} -> @@ -152,6 +167,7 @@ let is_unknown_id t = match t with | Unknown_id _ -> true + | Cycle_in_type_decs _ | Invalid_syntax _ | Unknown_type _ | Id_is_a_function _ @@ -174,6 +190,7 @@ let is_unknown_type t = match t with | Unknown_type _ -> true + | Cycle_in_type_decs _ | Unknown_id _ | Invalid_syntax _ | Id_is_a_function _ @@ -196,6 +213,7 @@ let is_wrong_type t = match t with | Wrong_type _ -> true + | Cycle_in_type_decs _ | Unknown_type _ | Unknown_id _ | Invalid_syntax _ @@ -218,6 +236,7 @@ let is_wrong_number_of_args t = match t with | Wrong_number_of_args _ -> true + | Cycle_in_type_decs _ | Wrong_type _ | Unknown_type _ | Unknown_id _ @@ -240,6 +259,7 @@ let is_invalid_syntax t = match t with | Invalid_syntax _ -> true + | Cycle_in_type_decs _ | Wrong_type _ | Unknown_type _ | Unknown_id _ @@ -262,6 +282,7 @@ let is_not_a_record t = match t with | Exp_not_a_record _ -> true + | Cycle_in_type_decs _ | Invalid_syntax _ | Wrong_type _ | Unknown_type _ @@ -284,6 +305,7 @@ let is_not_an_array t = match t with | Exp_not_an_array _ -> true + | Cycle_in_type_decs _ | Exp_not_a_record _ | Invalid_syntax _ | Wrong_type _ @@ -306,6 +328,30 @@ let is_no_such_field_in_record t = 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 _ diff --git a/compiler/src/lib/tiger/tiger_error.mli b/compiler/src/lib/tiger/tiger_error.mli index 9090ad4..73505b8 100644 --- a/compiler/src/lib/tiger/tiger_error.mli +++ b/compiler/src/lib/tiger/tiger_error.mli @@ -4,6 +4,12 @@ module Sym = Tiger_symbol 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} @@ -78,3 +84,4 @@ val is_invalid_syntax : t -> bool 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 diff --git a/compiler/src/lib/tiger/tiger_map_red_black.ml b/compiler/src/lib/tiger/tiger_map_red_black.ml index 30ba479..4713943 100644 --- a/compiler/src/lib/tiger/tiger_map_red_black.ml +++ b/compiler/src/lib/tiger/tiger_map_red_black.ml @@ -102,3 +102,9 @@ let to_dot t ~k_to_string = 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)) diff --git a/compiler/src/lib/tiger/tiger_map_sig.ml b/compiler/src/lib/tiger/tiger_map_sig.ml index ed21d33..6356ed3 100644 --- a/compiler/src/lib/tiger/tiger_map_sig.ml +++ b/compiler/src/lib/tiger/tiger_map_sig.ml @@ -11,5 +11,6 @@ module type S = sig 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 diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index b19c6fc..6bb45fd 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -1,8 +1,11 @@ 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 @@ -77,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 @@ -285,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=_}) -> diff --git a/compiler/src/lib/tiger/tiger_test_cases.ml b/compiler/src/lib/tiger/tiger_test_cases.ml index 73b1a26..082e02f 100644 --- a/compiler/src/lib/tiger/tiger_test_cases.ml +++ b/compiler/src/lib/tiger/tiger_test_cases.ml @@ -96,6 +96,30 @@ let micro = 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 = diff --git a/compiler/src/lib/tiger/tiger_test_cases_book.ml b/compiler/src/lib/tiger/tiger_test_cases_book.ml index 928373b..215fa62 100644 --- a/compiler/src/lib/tiger/tiger_test_cases_book.ml +++ b/compiler/src/lib/tiger/tiger_test_cases_book.ml @@ -96,6 +96,9 @@ let is_error_expected_parsing_of_filename = 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 diff --git a/screenshots/tests-semant-done-head.jpg b/screenshots/tests-head.jpg similarity index 100% rename from screenshots/tests-semant-done-head.jpg rename to screenshots/tests-head.jpg diff --git a/screenshots/tests-semant-done-tail.jpg b/screenshots/tests-semant-done-tail.jpg deleted file mode 100644 index cdc2060..0000000 Binary files a/screenshots/tests-semant-done-tail.jpg and /dev/null differ diff --git a/screenshots/tests-tail.jpg b/screenshots/tests-tail.jpg new file mode 100644 index 0000000..b0c72d7 Binary files /dev/null and b/screenshots/tests-tail.jpg differ