diff options
author | Justin Squirek <squirek@adacore.com> | 2022-11-17 15:34:57 +0000 |
---|---|---|
committer | Marc Poulhiès <poulhies@adacore.com> | 2022-12-06 14:58:48 +0100 |
commit | f459afaa679956df1f3c0243a87583e4d4b43a2e (patch) | |
tree | a94e0a86c619a30b2465ea1c941b3fcb3554d180 /gcc/ada/sem_ch6.adb | |
parent | c690f116b64be820cd47a554bffeadd9907fed2a (diff) | |
download | gcc-f459afaa679956df1f3c0243a87583e4d4b43a2e.zip gcc-f459afaa679956df1f3c0243a87583e4d4b43a2e.tar.gz gcc-f459afaa679956df1f3c0243a87583e4d4b43a2e.tar.bz2 |
ada: Accessibility code reorganization and bug fixes
This patch performs a large reorganization of accessibility related sources,
and also corrects some latent issues with accessibility checks - namely the
calculation of accessibility levels for expanded iterators and type
conversions.
gcc/ada/
* accessibility.adb, accessibility.ads
(Accessibility_Message): Moved from sem_attr.
(Apply_Accessibility_Check): Moved from checks.
(Apply_Accessibility_Check_For_Allocator): Moved from exp_ch4 and
renamed
(Check_Return_Construct_Accessibility): Moved from sem_ch6.
(Innermost_Master_Scope_Depth): Moved from sem_util. Add condition
to detect expanded iterators.
(Prefix_With_Safe_Accessibility_Level): Moved from sem_attr.
(Static_Accessibility_Level): Moved from sem_util.
(Has_Unconstrained_Access_Discriminants): Likewise.
(Has_Anonymous_Access_Discriminant): Likewise.
(Is_Anonymous_Access_Actual): Likewise.
(Is_Special_Aliased_Formal_Access): Likewise.
(Needs_Result_Accessibility_Level): Likewise.
(Subprogram_Access_Level): Likewise.
(Type_Access_Level): Likewise.
(Deepest_Type_Access_Level): Likewise.
(Effective_Extra_Accessibility): Likewise.
(Get_Dynamic_Accessibility): Likewise.
(Has_Access_Values): Likewise.
(Accessibility_Level): Likewise.
* exp_attr.adb (Access_Cases): Obtain the proper enclosing object
which applies to a given 'Access by looking through type
conversions.
* exp_ch4.adb (Apply_Accessibility_Check): Moved to accessibility.
* exp_ch5.adb: Likewise.
* exp_ch6.adb: Likewise.
* exp_ch9.adb: Likewise.
* exp_disp.adb: Likewise.
* gen_il-fields.ads: Add new flag Comes_From_Iterator.
* gen_il-gen-gen_nodes.adb: Add new flag Comes_From_Iterator for
N_Object_Renaming_Declaration.
* sem_ch5.adb (Analyze_Iterator_Specification): Mark object
renamings resulting from iterator expansion with the new flag
Comes_From_Iterator.
* sem_aggr.adb (Resolve_Container_Aggregate): Refine test.
* sem_ch13.adb: Add dependence on the accessibility package.
* sem_ch3.adb: Likewise.
* sem_ch4.adb: Likewise.
* sem_ch9.adb: Likewise.
* sem_res.adb: Likewise.
* sem_warn.adb: Likewise.
* exp_ch3.adb: Likewise.
* sem_attr.adb (Accessibility_Message): Moved to accessibility.
(Prefix_With_Safe_Accessibility_Level): Likewise.
* checks.adb, checks.ads (Apply_Accessibility_Check): Likewise.
* sem_ch6.adb (Check_Return_Construct_Accessibility): Likewise.
* sem_util.adb, sem_util.ads
(Accessibility_Level): Likewise.
(Deepest_Type_Access_Level): Likewise.
(Effective_Extra_Accessibility): Likewise.
(Get_Dynamic_Accessibility): Likewise.
(Has_Access_Values): Likewise.
(Has_Anonymous_Access_Discriminant): Likewise.
(Static_Accessibility_Level): Likewise.
(Has_Unconstrained_Access_Discriminants): Likewise.
(Is_Anonymous_Access_Actual): Likewise.
(Is_Special_Aliased_Formal_Access): Likewise.
(Needs_Result_Accessibility_Level): Likewise.
(Subprogram_Access_Level): Likewise.
(Type_Access_Level): Likewise.
* sinfo.ads: Document new flag Comes_From_Iterator.
* gcc-interface/Make-lang.in: Add entry for new Accessibility package.
Diffstat (limited to 'gcc/ada/sem_ch6.adb')
-rw-r--r-- | gcc/ada/sem_ch6.adb | 519 |
1 files changed, 3 insertions, 516 deletions
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index cb982b3..d567f79 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; @@ -745,10 +746,6 @@ package body Sem_Ch6 is -- Ada 2022: Check that the return expression in a No_Return function -- meets the conditions specified by RM 6.5.1(5.1/5). - procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id); - -- Apply legality rule of 6.5 (5.9) to the access discriminants of an - -- aggregate in a return statement. - procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); -- Check that the return_subtype_indication properly matches the result -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). @@ -781,516 +778,6 @@ package body Sem_Ch6 is Return_Expr); end Check_No_Return_Expression; - ------------------------------------------ - -- Check_Return_Construct_Accessibility -- - ------------------------------------------ - - procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is - - function First_Selector (Assoc : Node_Id) return Node_Id; - -- Obtain the first selector or choice from a given association - - function Is_Formal_Of_Current_Function - (Assoc_Expr : Entity_Id) return Boolean; - -- Predicate to test if a given expression associated with a - -- discriminant is a formal parameter to the function in which the - -- return construct we checking applies to. - - -------------------- - -- First_Selector -- - -------------------- - - function First_Selector (Assoc : Node_Id) return Node_Id is - begin - if Nkind (Assoc) = N_Component_Association then - return First (Choices (Assoc)); - - elsif Nkind (Assoc) = N_Discriminant_Association then - return (First (Selector_Names (Assoc))); - - else - raise Program_Error; - end if; - end First_Selector; - - ----------------------------------- - -- Is_Formal_Of_Current_Function -- - ----------------------------------- - - function Is_Formal_Of_Current_Function - (Assoc_Expr : Entity_Id) return Boolean is - begin - return Is_Entity_Name (Assoc_Expr) - and then Enclosing_Subprogram - (Entity (Assoc_Expr)) = Scope_Id - and then Is_Formal (Entity (Assoc_Expr)); - end Is_Formal_Of_Current_Function; - - -- Local declarations - - Assoc : Node_Id := Empty; - -- Assoc should perhaps be renamed and declared as a - -- Node_Or_Entity_Id since it encompasses not only component and - -- discriminant associations, but also discriminant components within - -- a type declaration or subtype indication ??? - - Assoc_Expr : Node_Id; - Assoc_Present : Boolean := False; - - Check_Cond : Node_Id; - Unseen_Disc_Count : Nat := 0; - Seen_Discs : Elist_Id; - Disc : Entity_Id; - First_Disc : Entity_Id; - - Obj_Decl : Node_Id; - Return_Con : Node_Id; - Unqual : Node_Id; - - -- Start of processing for Check_Return_Construct_Accessibility - - begin - -- Only perform checks on record types with access discriminants and - -- non-internally generated functions. - - if not Is_Record_Type (R_Type) - or else not Has_Anonymous_Access_Discriminant (R_Type) - or else not Comes_From_Source (Return_Stmt) - then - return; - end if; - - -- We are only interested in return statements - - if Nkind (Return_Stmt) not in - N_Extended_Return_Statement | N_Simple_Return_Statement - then - return; - end if; - - -- Fetch the object from the return statement, in the case of a - -- simple return statement the expression is part of the node. - - if Nkind (Return_Stmt) = N_Extended_Return_Statement then - -- Obtain the object definition from the expanded extended return - - Return_Con := First (Return_Object_Declarations (Return_Stmt)); - while Present (Return_Con) loop - -- Inspect the original node to avoid object declarations - -- expanded into renamings. - - if Nkind (Original_Node (Return_Con)) = N_Object_Declaration - and then Comes_From_Source (Original_Node (Return_Con)) - then - exit; - end if; - - Nlists.Next (Return_Con); - end loop; - - pragma Assert (Present (Return_Con)); - - -- Could be dealing with a renaming - - Return_Con := Original_Node (Return_Con); - else - Return_Con := Expression (Return_Stmt); - end if; - - -- Obtain the accessibility levels of the expressions associated - -- with all anonymous access discriminants, then generate a - -- dynamic check or static error when relevant. - - -- Note the repeated use of Original_Node to avoid checking - -- expanded code. - - Unqual := Original_Node (Unqualify (Original_Node (Return_Con))); - - -- Get the corresponding declaration based on the return object's - -- identifier. - - if Nkind (Unqual) = N_Identifier - and then Nkind (Parent (Entity (Unqual))) - in N_Object_Declaration - | N_Object_Renaming_Declaration - then - Obj_Decl := Original_Node (Parent (Entity (Unqual))); - - -- We were passed the object declaration directly, so use it - - elsif Nkind (Unqual) in N_Object_Declaration - | N_Object_Renaming_Declaration - then - Obj_Decl := Unqual; - - -- Otherwise, we are looking at something else - - else - Obj_Decl := Empty; - - end if; - - -- Hop up object renamings when present - - if Present (Obj_Decl) - and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration - then - while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop - - if Nkind (Name (Obj_Decl)) not in N_Entity then - -- We may be looking at the expansion of iterators or - -- some other internally generated construct, so it is safe - -- to ignore checks ??? - - if not Comes_From_Source (Obj_Decl) then - return; - end if; - - Obj_Decl := Original_Node - (Declaration_Node - (Ultimate_Prefix (Name (Obj_Decl)))); - - -- Move up to the next declaration based on the object's name - - else - Obj_Decl := Original_Node - (Declaration_Node (Name (Obj_Decl))); - end if; - end loop; - end if; - - -- Obtain the discriminant values from the return aggregate - - -- Do we cover extension aggregates correctly ??? - - if Nkind (Unqual) = N_Aggregate then - if Present (Expressions (Unqual)) then - Assoc := First (Expressions (Unqual)); - else - Assoc := First (Component_Associations (Unqual)); - end if; - - -- There is an object declaration for the return object - - elsif Present (Obj_Decl) then - -- When a subtype indication is present in an object declaration - -- it must contain the object's discriminants. - - if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then - Assoc := First - (Constraints - (Constraint - (Object_Definition (Obj_Decl)))); - - -- The object declaration contains an aggregate - - elsif Present (Expression (Obj_Decl)) then - - if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then - -- Grab the first associated discriminant expresion - - if Present - (Expressions (Unqualify (Expression (Obj_Decl)))) - then - Assoc := First - (Expressions - (Unqualify (Expression (Obj_Decl)))); - else - Assoc := First - (Component_Associations - (Unqualify (Expression (Obj_Decl)))); - end if; - - -- Otherwise, this is something else - - else - return; - end if; - - -- There are no supplied discriminants in the object declaration, - -- so get them from the type definition since they must be default - -- initialized. - - -- Do we handle constrained subtypes correctly ??? - - elsif Nkind (Unqual) = N_Object_Declaration then - Assoc := First_Discriminant - (Etype (Object_Definition (Obj_Decl))); - - else - Assoc := First_Discriminant (Etype (Unqual)); - end if; - - -- When we are not looking at an aggregate or an identifier, return - -- since any other construct (like a function call) is not - -- applicable since checks will be performed on the side of the - -- callee. - - else - return; - end if; - - -- Obtain the discriminants so we know the actual type in case the - -- value of their associated expression gets implicitly converted. - - if No (Obj_Decl) then - pragma Assert (Nkind (Unqual) = N_Aggregate); - - Disc := First_Discriminant (Etype (Unqual)); - - else - Disc := First_Discriminant - (Etype (Defining_Identifier (Obj_Decl))); - end if; - - -- Preserve the first discriminant for checking named associations - - First_Disc := Disc; - - -- Count the number of discriminants for processing an aggregate - -- which includes an others. - - Disc := First_Disc; - while Present (Disc) loop - Unseen_Disc_Count := Unseen_Disc_Count + 1; - - Next_Discriminant (Disc); - end loop; - - Seen_Discs := New_Elmt_List; - - -- Loop through each of the discriminants and check each expression - -- associated with an anonymous access discriminant. - - -- When named associations occur in the return aggregate then - -- discriminants can be in any order, so we need to ensure we do - -- not continue to loop when all discriminants have been seen. - - Disc := First_Disc; - while Present (Assoc) - and then (Present (Disc) or else Assoc_Present) - and then Unseen_Disc_Count > 0 - loop - -- Handle named associations by searching through the names of - -- the relevant discriminant components. - - if Nkind (Assoc) - in N_Component_Association | N_Discriminant_Association - then - Assoc_Expr := Expression (Assoc); - Assoc_Present := True; - - -- We currently don't handle box initialized discriminants, - -- however, since default initialized anonymous access - -- discriminants are a corner case, this is ok for now ??? - - if Nkind (Assoc) = N_Component_Association - and then Box_Present (Assoc) - then - if Nkind (First_Selector (Assoc)) = N_Others_Choice then - Unseen_Disc_Count := 0; - end if; - - -- When others is present we must identify a discriminant we - -- haven't already seen so as to get the appropriate type for - -- the static accessibility check. - - -- This works because all components within an others clause - -- must have the same type. - - elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then - - Disc := First_Disc; - Outer : while Present (Disc) loop - declare - Current_Seen_Disc : Elmt_Id; - begin - -- Move through the list of identified discriminants - - Current_Seen_Disc := First_Elmt (Seen_Discs); - while Present (Current_Seen_Disc) loop - -- Exit the loop when we found a match - - exit when - Chars (Node (Current_Seen_Disc)) = Chars (Disc); - - Next_Elmt (Current_Seen_Disc); - end loop; - - -- When we have exited the above loop without finding - -- a match then we know that Disc has not been seen. - - exit Outer when No (Current_Seen_Disc); - end; - - Next_Discriminant (Disc); - end loop Outer; - - -- If we got to an others clause with a non-zero - -- discriminant count there must be a discriminant left to - -- check. - - pragma Assert (Present (Disc)); - - -- Set the unseen discriminant count to zero because we know - -- an others clause sets all remaining components of an - -- aggregate. - - Unseen_Disc_Count := 0; - - -- Move through each of the selectors in the named association - -- and obtain a discriminant for accessibility checking if one - -- is referenced in the list. Also track which discriminants - -- are referenced for the purpose of handling an others clause. - - else - declare - Assoc_Choice : Node_Id; - Curr_Disc : Node_Id; - begin - - Disc := Empty; - Curr_Disc := First_Disc; - while Present (Curr_Disc) loop - -- Check each of the choices in the associations for a - -- match to the name of the current discriminant. - - Assoc_Choice := First_Selector (Assoc); - while Present (Assoc_Choice) loop - -- When the name matches we track that we have seen - -- the discriminant, but instead of exiting the - -- loop we continue iterating to make sure all the - -- discriminants within the named association get - -- tracked. - - if Chars (Assoc_Choice) = Chars (Curr_Disc) then - Append_Elmt (Curr_Disc, Seen_Discs); - - Disc := Curr_Disc; - Unseen_Disc_Count := Unseen_Disc_Count - 1; - end if; - - Next (Assoc_Choice); - end loop; - - Next_Discriminant (Curr_Disc); - end loop; - end; - end if; - - -- Unwrap the associated expression if we are looking at a default - -- initialized type declaration. In this case Assoc is not really - -- an association, but a component declaration. Should Assoc be - -- renamed in some way to be more clear ??? - - -- This occurs when the return object does not initialize - -- discriminant and instead relies on the type declaration for - -- their supplied values. - - elsif Nkind (Assoc) in N_Entity - and then Ekind (Assoc) = E_Discriminant - then - Append_Elmt (Disc, Seen_Discs); - - Assoc_Expr := Discriminant_Default_Value (Assoc); - Unseen_Disc_Count := Unseen_Disc_Count - 1; - - -- Otherwise, there is nothing to do because Assoc is an - -- expression within the return aggregate itself. - - else - Append_Elmt (Disc, Seen_Discs); - - Assoc_Expr := Assoc; - Unseen_Disc_Count := Unseen_Disc_Count - 1; - end if; - - -- Check the accessibility level of the expression when the - -- discriminant is of an anonymous access type. - - if Present (Assoc_Expr) - and then Present (Disc) - and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type - - -- We disable the check when we have a tagged return type and - -- the associated expression for the discriminant is a formal - -- parameter since the check would require us to compare the - -- accessibility level of Assoc_Expr to the level of the - -- Extra_Accessibility_Of_Result of the function - which is - -- currently disabled for functions with tagged return types. - -- This may change in the future ??? - - -- See Needs_Result_Accessibility_Level for details. - - and then not - (No (Extra_Accessibility_Of_Result (Scope_Id)) - and then Is_Formal_Of_Current_Function (Assoc_Expr) - and then Is_Tagged_Type (Etype (Scope_Id))) - then - -- Generate a dynamic check based on the extra accessibility of - -- the result or the scope of the current function. - - Check_Cond := - Make_Op_Gt (Loc, - Left_Opnd => Accessibility_Level - (Expr => Assoc_Expr, - Level => Dynamic_Level, - In_Return_Context => True), - Right_Opnd => - (if Present (Extra_Accessibility_Of_Result (Scope_Id)) - - -- When Assoc_Expr is a formal we have to look at the - -- extra accessibility-level formal associated with - -- the result. - - and then Is_Formal_Of_Current_Function (Assoc_Expr) - then - New_Occurrence_Of - (Extra_Accessibility_Of_Result (Scope_Id), Loc) - - -- Otherwise, we compare the level of Assoc_Expr to the - -- scope of the current function. - - else - Make_Integer_Literal - (Loc, Scope_Depth (Scope (Scope_Id))))); - - Insert_Before_And_Analyze (Return_Stmt, - Make_Raise_Program_Error (Loc, - Condition => Check_Cond, - Reason => PE_Accessibility_Check_Failed)); - - -- If constant folding has happened on the condition for the - -- generated error, then warn about it being unconditional when - -- we know an error will be raised. - - if Nkind (Check_Cond) = N_Identifier - and then Entity (Check_Cond) = Standard_True - then - Error_Msg_N - ("access discriminant in return object would be a dangling" - & " reference", Return_Stmt); - end if; - end if; - - -- Iterate over the discriminants, except when we have encountered - -- a named association since the discriminant order becomes - -- irrelevant in that case. - - if not Assoc_Present then - Next_Discriminant (Disc); - end if; - - -- Iterate over associations - - if not Is_List_Member (Assoc) then - exit; - else - Nlists.Next (Assoc); - end if; - end loop; - end Check_Return_Construct_Accessibility; - ------------------------------------- -- Check_Return_Subtype_Indication -- ------------------------------------- @@ -1495,7 +982,7 @@ package body Sem_Ch6 is Resolve (Expr, R_Type); Check_Limited_Return (N, Expr, R_Type); - Check_Return_Construct_Accessibility (N); + Check_Return_Construct_Accessibility (N, Stm_Entity); -- Ada 2022 (AI12-0269): Any return statement that applies to a -- nonreturning function shall be a simple_return_statement with @@ -1551,7 +1038,7 @@ package body Sem_Ch6 is Check_References (Stm_Entity); - Check_Return_Construct_Accessibility (N); + Check_Return_Construct_Accessibility (N, Stm_Entity); -- Check RM 6.5 (5.9/3) |