diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml index 238e3e5b0f1..3d52f23a1d9 100644 --- a/src/boot/me/effect.ml +++ b/src/boot/me/effect.ml @@ -273,8 +273,8 @@ let process_crate let root_scope = [ SCOPE_crate crate ] in let auth_effect name eff = match lookup_by_name cx [] root_scope name with - None -> () - | Some (_, id) -> + RES_failed _ -> () + | RES_ok (_, id) -> if defn_id_is_item cx id then htab_put item_auth id eff else err (Some id) "auth clause in crate refers to non-item" diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml index fa5dcc06a57..ed8011c33bb 100644 --- a/src/boot/me/resolve.ml +++ b/src/boot/me/resolve.ml @@ -228,6 +228,13 @@ let all_item_collecting_visitor Walk.visit_stmt_pre = visit_stmt_pre; } ;; +let report_error (full_name:Ast.name) (unbound_name:Ast.name) = + if full_name = unbound_name then + err None "unbound name '%a'" Ast.sprintf_name full_name + else + err None "unbound name '%a' in name '%a'" Ast.sprintf_name unbound_name + Ast.sprintf_name full_name +;; let lookup_type_node_by_name (cx:ctxt) @@ -238,8 +245,8 @@ let lookup_type_node_by_name log cx "lookup_simple_type_by_name %a" Ast.sprintf_name name); match lookup_by_name cx [] scopes name with - None -> err None "unknown name: %a" Ast.sprintf_name name - | Some (_, id) -> + RES_failed name' -> report_error name name' + | RES_ok (_, id) -> match htab_search cx.ctxt_all_defns id with Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type _; Ast.decl_params = _ }) @@ -274,8 +281,8 @@ let rec lookup_type_by_name log cx "+++ lookup_type_by_name %a" Ast.sprintf_name name); match lookup_by_name cx [] scopes name with - None -> err None "unknown name: %a" Ast.sprintf_name name - | Some (scopes', id) -> + RES_failed name' -> report_error name name' + | RES_ok (scopes', id) -> let ty, params = match htab_search cx.ctxt_all_defns id with Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type (_, t); @@ -614,17 +621,17 @@ let lval_base_resolving_visitor let lookup_defn_by_ident id ident = log cx "looking up slot or item with ident '%s'" ident; match lookup cx (!scopes) (Ast.KEY_ident ident) with - None -> err (Some id) "unresolved identifier '%s'" ident - | Some (_, id) -> (log cx "resolved to node id #%d" + RES_failed _ -> err (Some id) "unresolved identifier '%s'" ident + | RES_ok (_, id) -> (log cx "resolved to node id #%d" (int_of_node id); id) in let lookup_slot_by_temp id temp = log cx "looking up temp slot #%d" (int_of_temp temp); let res = lookup cx (!scopes) (Ast.KEY_temp temp) in match res with - None -> err + RES_failed _ -> err (Some id) "unresolved temp node #%d" (int_of_temp temp) - | Some (_, id) -> + | RES_ok (_, id) -> (log cx "resolved to node id #%d" (int_of_node id); id) in let lookup_defn_by_name_base id nb = diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index f7ad923e25d..56c52a3cb17 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -1950,7 +1950,13 @@ visitor = (* Generic lookup, used for slots, items, types, etc. *) -type resolved = ((scope list * node_id) option) ;; +type resolved = + RES_ok of scope list * node_id + | RES_failed of Ast.name +;; + +let no_such_ident ident = RES_failed (Ast.NAME_base (Ast.BASE_ident ident)) +let no_such_temp temp = RES_failed (Ast.NAME_base (Ast.BASE_temp temp)) let get_mod_item (cx:ctxt) @@ -2000,20 +2006,20 @@ let rec project_ident_from_items in if not (inside || (exports_permit view ident)) - then None + then no_such_ident ident else match htab_search items ident with Some i -> found cx scopes i.id | None -> match htab_search view.Ast.view_imports ident with - None -> None + None -> no_such_ident ident | Some name -> lookup_by_name cx lchk scopes name and found cx scopes id = Hashtbl.replace cx.ctxt_node_referenced id (); - Some (scopes, id) + RES_ok (scopes, id) and project_name_comp_from_resolved (cx:ctxt) @@ -2022,8 +2028,8 @@ and project_name_comp_from_resolved (ext:Ast.name_component) : resolved = match mod_res with - None -> None - | Some (scopes, id) -> + RES_failed _ -> mod_res + | RES_ok (scopes, id) -> let scope = (SCOPE_mod_item {id=id; node=get_item cx id}) in let scopes = scope :: scopes in let ident = get_name_comp_ident ext in @@ -2054,27 +2060,37 @@ and lookup_by_ident : resolved = let check_slots scopes islots = - arr_search islots - (fun _ (sloti,ident') -> - if ident = ident' - then found cx scopes sloti.id - else None) + let rec search i = + if i == (Array.length islots) then + no_such_ident ident + else + let (sloti, ident') = islots.(i) in + if ident = ident' + then found cx scopes sloti.id + else search (i + 1) + in + search 0 in let check_params scopes params = - arr_search params - (fun _ {node=(i,_); id=id} -> - if i = ident - then found cx scopes id - else None) + let rec search i = + if i == (Array.length params) then + no_such_ident ident + else + let { node = (ident', _); id = id } = params.(i) in + if ident = ident' + then found cx scopes id + else search (i + 1) + in + search 0 in let passed_capture_scope = ref false in let would_capture r = match r with - None -> None - | Some _ -> + RES_failed _ -> r + | RES_ok _ -> if !passed_capture_scope then err None "attempted dynamic environment-capture" else r @@ -2091,7 +2107,7 @@ and lookup_by_ident | None -> match htab_search block_items ident with Some id -> found cx scopes id - | None -> None + | None -> no_such_ident ident end | SCOPE_crate crate -> @@ -2115,21 +2131,21 @@ and lookup_by_ident project_ident_from_items cx lchk scopes item.id md ident true - | _ -> None + | _ -> no_such_ident ident in match item_match with - Some _ -> item_match - | None -> + RES_ok _ -> item_match + | RES_failed _ -> would_capture (check_params scopes item.node.Ast.decl_params) end in let rec search scopes = match scopes with - [] -> None + [] -> no_such_ident ident | scope::rest -> match check_scope scopes scope with - None -> + RES_failed _ -> begin let is_ty_item i = match i.node.Ast.decl_item with @@ -2157,28 +2173,26 @@ let lookup_by_temp (cx:ctxt) (scopes:scope list) (temp:temp_id) - : ((scope list * node_id) option) = - let passed_item_scope = ref false in - let check_scope scope = - if !passed_item_scope - then None - else - match scope with - SCOPE_block block_id -> + : resolved = + let rec search scopes' = + match scopes' with + (SCOPE_block block_id)::scopes'' -> let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in - htab_search block_slots (Ast.KEY_temp temp) - | _ -> - passed_item_scope := true; - None + begin + match htab_search block_slots (Ast.KEY_temp temp) with + Some slot -> RES_ok (scopes', slot) + | None -> search scopes'' + end + | _ -> no_such_temp temp in - list_search_ctxt scopes check_scope + search scopes ;; let lookup (cx:ctxt) (scopes:scope list) (key:Ast.slot_key) - : ((scope list * node_id) option) = + : resolved = match key with Ast.KEY_temp temp -> lookup_by_temp cx scopes temp | 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 0579775f7de..4ca0caf28bb 100644 --- a/src/boot/me/typestate.ml +++ b/src/boot/me/typestate.ml @@ -119,7 +119,7 @@ let determine_constr_key let cid = match lookup_by_name cx [] scopes c.Ast.constr_name with - Some (_, cid) -> + RES_ok (_, cid) -> if defn_id_is_item cx cid then begin @@ -134,7 +134,7 @@ let determine_constr_key end else bug () "slot used as predicate" - | None -> bug () "predicate not found" + | RES_failed _ -> bug () "predicate not found" in let constr_arg_of_carg carg = @@ -153,8 +153,8 @@ let determine_constr_key | Ast.CARG_base (Ast.BASE_named nb) -> begin match lookup_by_name cx [] scopes (Ast.NAME_base nb) with - None -> bug () "constraint-arg not found" - | Some (_, aid) -> + RES_failed _ -> bug () "constraint-arg not found" + | RES_ok (_, aid) -> if defn_id_is_slot cx aid then if type_has_state cx