From cbc31ea01ef28f60639e4752ee6413b17f038fbc Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Thu, 8 Jul 2010 21:55:15 -0700 Subject: [PATCH] Add detection for cyclic imports. --- src/boot/me/effect.ml | 2 +- src/boot/me/resolve.ml | 6 +++--- src/boot/me/semant.ml | 29 +++++++++++++++++++++-------- src/boot/me/typestate.ml | 4 ++-- 4 files changed, 27 insertions(+), 14 deletions(-) diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml index 795f19906f4..3ec492c8d02 100644 --- a/src/boot/me/effect.ml +++ b/src/boot/me/effect.ml @@ -320,7 +320,7 @@ let process_crate in let root_scope = [ SCOPE_crate crate ] in let auth_effect name eff = - match lookup_by_name cx root_scope name with + match lookup_by_name cx [] root_scope name with None -> () | Some (_, id) -> if referent_is_item cx id diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml index 641df88443a..77fdbb3b2dc 100644 --- a/src/boot/me/resolve.ml +++ b/src/boot/me/resolve.ml @@ -233,7 +233,7 @@ let lookup_type_node_by_name iflog cx (fun _ -> log cx "lookup_simple_type_by_name %a" Ast.sprintf_name name); - match lookup_by_name cx scopes name with + match lookup_by_name cx [] scopes name with None -> err None "unknown name: %a" Ast.sprintf_name name | Some (_, id) -> match htab_search cx.ctxt_all_defns id with @@ -390,7 +390,7 @@ and lookup_type_by_name iflog cx (fun _ -> log cx "+++ lookup_type_by_name %a" Ast.sprintf_name name); - match lookup_by_name cx scopes name with + match lookup_by_name cx [] scopes name with None -> err None "unknown name: %a" Ast.sprintf_name name | Some (scopes', id) -> let ty, params = @@ -746,7 +746,7 @@ let lval_base_resolving_visitor | _ -> false in if lval_is_name lv && lval_is_item cx lv - then ignore (lookup_by_name cx (!scopes) (lval_to_name lv)) + then ignore (lookup_by_name cx [] (!scopes) (lval_to_name lv)) in lookup_lval lv; diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index c67bb822268..61eb148527b 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -1539,8 +1539,11 @@ let get_name_base_ident bug () "get_name_base_ident on BASE_temp" ;; +type loop_check = (node_id * Ast.ident) list;; + let rec project_ident_from_items (cx:ctxt) + (lchk:loop_check) (scopes:scope list) ((view:Ast.mod_view),(items:Ast.mod_items)) (ident:Ast.ident) @@ -1555,7 +1558,7 @@ let rec project_ident_from_items | None -> match htab_search view.Ast.view_imports ident with None -> None - | Some name -> lookup_by_name cx scopes name + | Some name -> lookup_by_name cx lchk scopes name and found cx scopes id = Hashtbl.replace cx.ctxt_node_referenced id (); @@ -1563,6 +1566,7 @@ and found cx scopes id = and project_name_comp_from_resolved (cx:ctxt) + (lchk:loop_check) (mod_res:resolved) (ext:Ast.name_component) : resolved = @@ -1574,10 +1578,11 @@ and project_name_comp_from_resolved let ident = get_name_comp_ident ext in let md = get_mod_item cx id in Hashtbl.replace cx.ctxt_node_referenced id (); - project_ident_from_items cx scopes md ident false + project_ident_from_items cx lchk scopes md ident false and lookup_by_name (cx:ctxt) + (lchk:loop_check) (scopes:scope list) (name:Ast.name) : resolved = @@ -1585,17 +1590,24 @@ and lookup_by_name match name with Ast.NAME_base nb -> let ident = get_name_base_ident nb in - lookup_by_ident cx scopes ident + lookup_by_ident cx lchk scopes ident | Ast.NAME_ext (name, ext) -> - let base_res = lookup_by_name cx scopes name in - project_name_comp_from_resolved cx base_res ext + let base_res = lookup_by_name cx lchk scopes name in + project_name_comp_from_resolved cx lchk base_res ext and lookup_by_ident (cx:ctxt) + (lchk:loop_check) (scopes:scope list) (ident:Ast.ident) : resolved = + let passing id = + if List.mem (id, ident) lchk + then err (Some id) "cyclic import for ident %s" ident + else (id, ident)::lchk + in + let check_slots scopes islots = arr_search islots (fun _ (sloti,ident') -> @@ -1639,7 +1651,7 @@ and lookup_by_ident | SCOPE_crate crate -> project_ident_from_items - cx scopes crate.node.Ast.crate_items ident true + cx (passing crate.id) scopes crate.node.Ast.crate_items ident true | SCOPE_obj_fn fn -> would_capture (check_slots scopes fn.node.Ast.fn_input_slots) @@ -1659,7 +1671,8 @@ and lookup_by_ident end | Ast.MOD_ITEM_mod md -> - project_ident_from_items cx scopes md ident true + project_ident_from_items cx (passing item.id) + scopes md ident true | _ -> None in @@ -1727,7 +1740,7 @@ let lookup : ((scope list * node_id) option) = match key with Ast.KEY_temp temp -> lookup_by_temp cx scopes temp - | Ast.KEY_ident ident -> lookup_by_ident cx scopes ident + | Ast.KEY_ident ident -> lookup_by_ident cx [] scopes ident ;; diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml index 6f7a300f5a5..3a13561ae3a 100644 --- a/src/boot/me/typestate.ml +++ b/src/boot/me/typestate.ml @@ -28,7 +28,7 @@ let determine_constr_key : constr_key = let cid = - match lookup_by_name cx scopes c.Ast.constr_name with + match lookup_by_name cx [] scopes c.Ast.constr_name with Some (_, cid) -> if referent_is_item cx cid then @@ -62,7 +62,7 @@ let determine_constr_key | Ast.CARG_ext (pth, _) -> node_base_of pth | Ast.CARG_base (Ast.BASE_named nb) -> begin - match lookup_by_name cx scopes (Ast.NAME_base nb) with + match lookup_by_name cx [] scopes (Ast.NAME_base nb) with None -> bug () "constraint-arg not found" | Some (_, aid) -> if referent_is_slot cx aid