https://gcc.gnu.org/g:c6d349f173492d9671462d03e5cab3c4cc84b03a
commit r16-6632-gc6d349f173492d9671462d03e5cab3c4cc84b03a Author: Eric Botcazou <[email protected]> Date: Thu Dec 11 16:14:32 2025 +0100 ada: Reimplement AI12-0345, AI12-0372 and implement AI12-0402 The first two are binding interpretations, so apply to Ada 2012, and have been only partially implemented. The third is Ada 2022 and has not been implemented, but is very convenient to tame the effects of the first two. They mostly pertain to explicitly aliased parameters and to adjusting the rules determining the master of a function call, so that the RM 6.4.1(6.4) legality rule is applied judiciously. The change also does some housekeeping work in the implementation of static accessibility checks, plugging a few loopholes: in Ada 2005 for objects of anonymous access types, in Ada 2005 and 2012 for conversions between access types done in extended return statements, and in Ada 2012 for explicitly aliased parameters. gcc/ada/ChangeLog: * accessibility.ads (Is_Special_Aliased_Formal_Access): Delete. * accessibility.adb (Is_Special_Aliased_Formal_Access): Likewise. (Accessibility_Level.Innermost_Master_Scope_Depth): Look for non- package bodies and statements directly. (Accessibility_Level.Function_Call_Or_Allocator_Level): For a function call in a return context, return the extra level of the master of the call only for dynamic checks. (Accessibility_Level) <N_Defining_Identifier>: Always return the library level for an explicitly aliased parameter in the context of a return from the subprogram where it is declared. * exp_ch4.adb (Expand_N_Allocator): Test manually whether the context is a return statement instead of calling In_Return_Value. (Expand_N_Type_Conversion): Do not apply accessibility checks to actuals of a tagged type in a synthesized subprogram call. * sem_attr.adb (Resolve_Attribute) <Access>: Remove specific test for explicitly aliased parameters. * sem_ch4.adb: Remove clauses for Accessibility package. (Analyze_Call): Do not apply static accessibility checks here... * sem_res.adb (Resolve_Actuals): ...but here instead. Implement a generalized form of AI12-0402. (Valid_Conversion): Apply static accessibility checks in extended return statements too. * sem_util.ads (In_Return_Value): Adjust description. (Is_Master): Delete. * sem_util.adb (Is_Explicitly_Aliased): Reindent. (In_Return_Value): Reimplement. (Is_Master): Delete. Diff: --- gcc/ada/accessibility.adb | 111 +++++++--------- gcc/ada/accessibility.ads | 15 --- gcc/ada/exp_ch4.adb | 21 +-- gcc/ada/sem_attr.adb | 9 -- gcc/ada/sem_ch4.adb | 46 ------- gcc/ada/sem_res.adb | 70 +++++++--- gcc/ada/sem_util.adb | 330 ++++++++++++++++++++++++---------------------- gcc/ada/sem_util.ads | 18 ++- 8 files changed, 288 insertions(+), 332 deletions(-) diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 220427a46516..1e2dcbb475bf 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -217,9 +217,13 @@ package body Accessibility is then return Scope_Depth (Enclosing_Subprogram (Node_Par)); - -- Statements are counted as masters + -- Non-package bodies and statements are counted as masters - elsif Is_Master (Node_Par) then + elsif Nkind (Node_Par) in N_Entry_Body + | N_Subprogram_Body + | N_Task_Body + or else Is_Statement (Node_Par) + then Master_Lvl_Modifier := Master_Lvl_Modifier + 1; end if; @@ -313,36 +317,37 @@ package body Accessibility is end if; end if; - if Nkind (N) = N_Function_Call then - -- Dynamic checks are generated when we are within a return - -- value or we are in a function call within an anonymous - -- access discriminant constraint of a return object (signified - -- by In_Return_Context) on the side of the callee. + -- Dynamic checks are generated when we are within a return + -- value or we are in a function call within an anonymous + -- access discriminant constraint of a return object (signified + -- by In_Return_Context) on the side of the callee. + + if Nkind (N) = N_Function_Call + and then (In_Return_Value (N) or else In_Return_Context) + then + declare + Extra_Formal : constant Entity_Id := + Extra_Accessibility_Of_Result (Current_Subprogram); - -- So, in this case, return accessibility level of the - -- enclosing subprogram. + begin + -- If a function is passed an extra "level of the + -- master of the call" parameter and that function + -- returns a call to another such function (or + -- possibly to the same function, in the case of a + -- recursive call), then that parameter should be + -- "passed along". + + if Present (Extra_Formal) and then Level = Dynamic_Level then + return New_Occurrence_Of (Extra_Formal, Loc); + + -- Otherwise, return accessibility level of the enclosing + -- subprogram. - if In_Return_Value (N) - or else In_Return_Context - then - if Present (Extra_Accessibility_Of_Result - (Current_Subprogram)) - then - -- If a function is passed an extra "level of the - -- master of the call" parameter and that function - -- returns a call to another such function (or - -- possibly to the same function, in the case of a - -- recursive call), then that parameter should be - -- "passed along". - - return New_Occurrence_Of - (Extra_Accessibility_Of_Result - (Current_Subprogram), Loc); else return Make_Level_Literal (Subprogram_Access_Level (Current_Subprogram)); end if; - end if; + end; end if; -- When the call is being dereferenced the level is that of the @@ -561,15 +566,20 @@ package body Accessibility is -- means we are near the end of our recursive traversal. when N_Defining_Identifier => - -- A dynamic check is performed on the side of the callee when we - -- are within a return statement, so return a library-level - -- accessibility level to null out checks on the side of the - -- caller. + -- RM 3.10.2(21.1/5): Notwithstanding other rules [in 3.10.2], + -- the accessibility level of an entity that is tied to that of + -- an explicitly aliased formal parameter of an enclosing function + -- is considered (both statically and dynamically) to be the same + -- as that of an entity whose accessibility level is tied to that + -- of the return object of that function. + + -- This means that no checks are needed for an explicitly aliased + -- formal parameter in a return context and we return the library + -- level to null them out there. if Is_Explicitly_Aliased (E) - and then (In_Return_Context - or else (Level /= Dynamic_Level - and then In_Return_Value (Expr))) + and then Scope (E) = Current_Subprogram + and then (In_Return_Value (Expr) or else In_Return_Context) then return Make_Level_Literal (Scope_Depth (Standard_Standard)); @@ -812,8 +822,7 @@ package body Accessibility is -- So, in this case, return a library accessibility level to -- null out the check on the side of the caller. - if (In_Return_Value (E) - or else In_Return_Context) + if (In_Return_Value (E) or else In_Return_Context) and then Level /= Dynamic_Level then return Make_Level_Literal @@ -1932,38 +1941,6 @@ package body Accessibility is return Nkind (Par) in N_Subprogram_Call; end Is_Anonymous_Access_Actual; - -------------------------------------- - -- Is_Special_Aliased_Formal_Access -- - -------------------------------------- - - function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - In_Return_Context : Boolean := False) return Boolean - is - Scop : constant Entity_Id := Current_Subprogram; - begin - -- Verify the expression is an access reference to 'Access within a - -- return statement as this is the only time an explicitly aliased - -- formal has different semantics. - - if Nkind (Exp) /= N_Attribute_Reference - or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access - or else not (In_Return_Value (Exp) - or else In_Return_Context) - or else not Needs_Result_Accessibility_Level (Scop) - then - return False; - end if; - - -- Check if the prefix of the reference is indeed an explicitly aliased - -- formal parameter for the function Scop. Additionally, we must check - -- that Scop returns an anonymous access type, otherwise the special - -- rules dictating a need for a dynamic check are not in effect. - - return Is_Entity_Name (Prefix (Exp)) - and then Is_Explicitly_Aliased (Entity (Prefix (Exp))); - end Is_Special_Aliased_Formal_Access; - -------------------------------------- -- Needs_Result_Accessibility_Level -- -------------------------------------- diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads index fb29be3814da..336e633d2347 100644 --- a/gcc/ada/accessibility.ads +++ b/gcc/ada/accessibility.ads @@ -182,21 +182,6 @@ package Accessibility is -- Determine if N is used as an actual for a call whose corresponding -- formal is of an anonymous access type. - function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - In_Return_Context : Boolean := False) return Boolean; - -- Determines whether a dynamic check must be generated for explicitly - -- aliased formals within a function Scop for the expression Exp. - - -- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume - -- that Exp is within a return value which is useful for checking - -- expressions within discriminant associations of return objects. - - -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a - -- 'Access attribute reference within a return statement where the ultimate - -- prefix is an aliased formal of Scop and that Scop returns an anonymous - -- access type. See RM 3.10.2 for more details. - function Needs_Result_Accessibility_Level (Func_Id : Entity_Id) return Boolean; -- Ada 2012 (AI05-0234): Return True if the function needs an implicit diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 92196a433052..2ba18827f372 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4958,7 +4958,9 @@ package body Exp_Ch4 is and then Ekind (Current_Scope) = E_Function and then Ekind (Etype (Current_Scope)) = E_General_Access_Type - and then In_Return_Value (N) + and then Nkind (Parent (N)) = N_Type_Conversion + and then + Nkind (Parent (Parent (N))) = N_Simple_Return_Statement then Set_Master_Id (PtrT, Master_Id (Etype (Current_Scope))); @@ -12146,9 +12148,9 @@ package body Exp_Ch4 is -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was -- expanded from an Unchecked_ or Unrestricted_Access attribute, - -- or for the actual of a class-wide interface parameter. Note that - -- other checks may still need to be applied below (such as tagged - -- type checks). + -- or for the actual of a tagged type parameter in a synthesized + -- subprogram call. Note that other checks may still need to be + -- applied below (such as tagged type checks). elsif Is_Entity_Name (Operand_Acc) and then Has_Extra_Accessibility (Entity (Operand_Acc)) @@ -12157,12 +12159,11 @@ package body Exp_Ch4 is or else Attribute_Name (Original_Node (N)) = Name_Access) and then not No_Dynamic_Accessibility_Checks_Enabled (N) then - if not Comes_From_Source (N) - and then Nkind (Parent (N)) in N_Function_Call - | N_Parameter_Association - | N_Procedure_Call_Statement - and then Is_Interface (Designated_Type (Target_Type)) - and then Is_Class_Wide_Type (Designated_Type (Target_Type)) + if Nkind (Parent (N)) in N_Function_Call + | N_Parameter_Association + | N_Procedure_Call_Statement + and then not Comes_From_Source (Parent (N)) + and then Is_Tagged_Type (Designated_Type (Target_Type)) then null; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index b4d5f38d68aa..d312fc887fb9 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -12047,15 +12047,6 @@ package body Sem_Attr is or else Nkind (Associated_Node_For_Itype (Btyp)) = N_Object_Declaration) - - -- Verify that static checking is OK (namely that we aren't - -- in a specific context requiring dynamic checks on - -- expicitly aliased parameters), and then check the level. - - -- Otherwise a check will be generated later when the return - -- statement gets expanded. - - and then not Is_Special_Aliased_Formal_Access (N) and then Static_Accessibility_Level (N, Zero_On_Dynamic_Level) > Deepest_Type_Access_Level (Btyp) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e725c013ad78..8a7399dbb746 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; @@ -1537,51 +1536,6 @@ package body Sem_Ch4 is end if; end if; - -- Check the accessibility level for actuals for explicitly aliased - -- formals when a function call appears within a return statement. - -- This is only checked if the enclosing subprogram Comes_From_Source, - -- to avoid issuing errors on calls occurring in wrapper subprograms - -- (for example, where the call is part of an expression of an aspect - -- associated with a wrapper, such as Pre'Class). - - if Nkind (N) = N_Function_Call - and then Comes_From_Source (N) - and then Present (Nam_Ent) - and then In_Return_Value (N) - and then Comes_From_Source (Current_Subprogram) - then - declare - Form : Node_Id; - Act : Node_Id; - begin - Act := First_Actual (N); - Form := First_Formal (Nam_Ent); - - while Present (Form) and then Present (Act) loop - -- Check whether the formal is aliased and if the accessibility - -- level of the actual is deeper than the accessibility level - -- of the enclosing subprogram to which the current return - -- statement applies. - - -- Should we be checking Is_Entity_Name on Act? Won't this miss - -- other cases ??? - - if Is_Explicitly_Aliased (Form) - and then Is_Entity_Name (Act) - and then Static_Accessibility_Level - (Act, Zero_On_Dynamic_Level) - > Subprogram_Access_Level (Current_Subprogram) - then - Error_Msg_N ("actual for explicitly aliased formal is too" - & " short lived", Act); - end if; - - Next_Formal (Form); - Next_Actual (Act); - end loop; - end; - end if; - if Ada_Version >= Ada_2012 then -- Check if the call contains a function with writable actuals diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 108a4f9d06be..f8e974d96aae 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3734,6 +3734,19 @@ package body Sem_Res is procedure Check_Aliased_Parameter is Nominal_Subt : Entity_Id; + procedure Accessibility_Error (S : String); + -- Give an error about the accessibility level of the actual + + ------------------------- + -- Accessibility_Error -- + ------------------------- + + procedure Accessibility_Error (S : String) is + begin + Error_Msg_NE ("actual for aliased formal& has wrong accessibility" + & " in " & S & " (RM 6.4.1(6.4))", A, F); + end Accessibility_Error; + begin if Is_Aliased (F) then if Is_Tagged_Type (A_Typ) then @@ -3769,24 +3782,43 @@ package body Sem_Res is & "aliased object", A, F); end if; - if Ekind (Nam) = E_Procedure then + -- RM 6.4.1(6.4): In a function call, the accessibility level of + -- the actual object for each explicitly aliased parameter shall + -- not be statically deeper than the accessibility level of the + -- master of the call. + + -- AI12-0402: The master of the function call for a function + -- whose result type is a scalar or named access type is always + -- the innermost master invoking the function. + + if Ekind (Etype (Nam)) = E_Void + or else (Ada_Version >= Ada_2022 + and then (Is_Scalar_Type (Etype (Nam)) + or else Is_Named_Access_Type (Etype (Nam)))) + then null; - elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then - if Nkind (Parent (N)) = N_Type_Conversion - and then Type_Access_Level (Etype (Parent (N))) - < Static_Accessibility_Level (A, Object_Decl_Level) - then - Error_Msg_N ("aliased actual has wrong accessibility", A); - end if; + elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type + and then Nkind (Parent (N)) = N_Type_Conversion + and then Type_Access_Level (Etype (Parent (N))) + < Static_Accessibility_Level (A, Object_Decl_Level) + then + Accessibility_Error ("conversion"); elsif Nkind (Parent (N)) = N_Qualified_Expression and then Nkind (Parent (Parent (N))) = N_Allocator and then Type_Access_Level (Etype (Parent (Parent (N)))) < Static_Accessibility_Level (A, Object_Decl_Level) then - Error_Msg_N - ("aliased actual in allocator has wrong accessibility", A); + Accessibility_Error ("allocator"); + + elsif In_Return_Value (N) + and then Comes_From_Source (N) + and then Subprogram_Access_Level (Current_Subprogram) + < Static_Accessibility_Level + (A, Object_Decl_Level, In_Return_Context => True) + then + Accessibility_Error ("return"); end if; end if; end Check_Aliased_Parameter; @@ -14515,24 +14547,26 @@ package body Sem_Res is -- Check if the operand is deeper than the target type, taking -- care to avoid the case where we are converting a result of a -- function returning an anonymous access type since the "master - -- of the call" would be target type of the conversion unless - -- the target type is anonymous access as well - see RM 3.10.2 - -- (10.3/3). + -- of the call" would be target type of the conversion, unless + -- the target type is anonymous access as well (RM 3.10.2(10.3)). -- Note that when the restriction No_Dynamic_Accessibility_Checks - -- is in effect wei also want to proceed with the conversion check + -- is in effect we also want to proceed with the conversion check -- described above. + -- Moreover, in the latter case, if the function call defines the + -- result of the enclosing function, the master of the call is the + -- master of the call to the enclosing function (RM 3.10.2(10.3), + -- 3.10.2(14) and 3.10.2(10.5)). + elsif Type_Access_Level (Opnd_Type, Assoc_Ent => Operand) > Deepest_Type_Access_Level (Target_Type) and then (Nkind (Associated_Node_For_Itype (Opnd_Type)) /= N_Function_Specification or else Ekind (Target_Type) in Anonymous_Access_Kind or else No_Dynamic_Accessibility_Checks_Enabled (N)) - - -- Check we are not in a return value ??? - - and then (not In_Return_Value (N) + and then (Nkind (Operand) /= N_Function_Call + or else not In_Return_Value (N) or else Nkind (Associated_Node_For_Itype (Target_Type)) = N_Component_Declaration) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9cc4af9dc758..c44af46ced5a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12759,9 +12759,9 @@ package body Sem_Util is function Is_Explicitly_Aliased (N : Node_Id) return Boolean is begin return Is_Formal (N) - and then Present (Parent (N)) - and then Nkind (Parent (N)) = N_Parameter_Specification - and then Aliased_Present (Parent (N)); + and then Present (Parent (N)) + and then Nkind (Parent (N)) = N_Parameter_Specification + and then Aliased_Present (Parent (N)); end Is_Explicitly_Aliased; ---------------------------- @@ -14741,6 +14741,173 @@ package body Sem_Util is end loop; end In_Quantified_Expression; + --------------------- + -- In_Return_Value -- + --------------------- + + function In_Return_Value (Exp : Node_Id) return Boolean is + Prev : Node_Id := Exp; + P : Node_Id := Parent (Exp); + -- P and Prev will be used for traversing the AST, while maintaining an + -- invariant that P = Parent (Prev). + + In_Component : Boolean := False; + -- Whether Exp occurs within a component reference + + In_Dereference : Boolean := False; + -- Whether Exp occurs within a dereference + + function Exp_Defines_Or_Is_Tied_To_Return_Value return Boolean is + (not In_Component + and then not In_Dereference + + -- RM 3.10.2(14.5/3): Within a return statement, the accessibility + -- level of the anonymous access type of an access result is that + -- of the master of the call. + + and then + (Nkind (Prev) /= N_Attribute_Reference + or else + Ekind (Etype (Current_Subprogram)) = E_Anonymous_Access_Type)); + -- Whether Exp defines or is tied to the return value + + -- Start of processing for In_Return_Value + + begin + -- Move through parent nodes to determine if Expr contributes to the + -- return value of the current subprogram. + + Parent_Loop : while Present (P) loop + + case Nkind (P) is + -- A return expression is obviously a return value + + when N_Simple_Return_Statement => + return Exp_Defines_Or_Is_Tied_To_Return_Value; + + -- A return object obviously contains a return value + + when N_Object_Declaration => + return Is_Return_Object (Defining_Identifier (P)) + and then Exp_Defines_Or_Is_Tied_To_Return_Value; + + -- An allocator is not a return value unless specially built + + when N_Allocator => + return For_Special_Return_Object (P) + and then Exp_Defines_Or_Is_Tied_To_Return_Value; + + -- Check if we are the actual of an explicitly aliased parameter + -- of a function call. This specific case seems to be missing in + -- the RM 10.3.2(10.5/5) rule, but is necessary to propagate the + -- master of the call down the chain of nested function calls. + + when N_Function_Call => declare + Subp : constant Node_Id := Name (P); + + A : Node_Id; + F : Node_Id; + Nam : Entity_Id; + + begin + exit Parent_Loop when Prev = Subp; + + if Ekind (Etype (Subp)) = E_Subprogram_Type then + Nam := Etype (Subp); + elsif Is_Entity_Name (Subp) then + Nam := Entity (Subp); + else + exit Parent_Loop; + end if; + + F := First_Formal (Nam); + A := First_Actual (P); + + while Present (F) loop + exit Parent_Loop when No (A); + + if A = Prev + or else (Nkind (Prev) = N_Parameter_Association + and then A = Explicit_Actual_Parameter (Prev)) + then + if Is_Aliased (F) then + exit; + else + exit Parent_Loop; + end if; + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + -- The actual should have been seen + + pragma Assert (Present (F)); + end; + + -- Operators do not have explicitly aliased operands + + when N_Op => + exit Parent_Loop; + + -- Ignore ranges as they don't contribute to the return value + + when N_Range => + exit Parent_Loop; + + -- Accept operative constituents + + when N_Case_Expression => + exit Parent_Loop when Prev = Expression (P); + + when N_If_Expression => + exit Parent_Loop when Prev = First (Expressions (P)); + + when N_Case_Expression_Alternative + | N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + null; + + -- Record whether we are in a component + + when N_Indexed_Component + | N_Selected_Component + | N_Slice + => + In_Component := True; + + -- Record whether we are in a dereference + + when N_Explicit_Dereference => + In_Dereference := True; + + when N_Attribute_Reference => + exit Parent_Loop when Attribute_Name (P) /= Name_Access; + + -- 'Access kills a previous component or dereference + + In_Component := False; + In_Dereference := False; + + when others => + -- Prevent the search from going too far + + exit Parent_Loop when Is_Statement (P) + or else Is_Body_Or_Package_Declaration (P); + end case; + + -- Iterate up to the next parent, keeping track of the previous one + + Prev := P; + P := Parent (P); + end loop Parent_Loop; + + return False; + end In_Return_Value; + ------------------------------------- -- In_Reverse_Storage_Order_Object -- ------------------------------------- @@ -14894,107 +15061,6 @@ package body Sem_Util is return False; end In_Subtree; - --------------------- - -- In_Return_Value -- - --------------------- - - function In_Return_Value (Expr : Node_Id) return Boolean is - Par : Node_Id; - Prev_Par : Node_Id; - Pre : Node_Id; - In_Function_Call : Boolean := False; - - begin - -- Move through parent nodes to determine if Expr contributes to the - -- return value of the current subprogram. - - Par := Expr; - Prev_Par := Empty; - while Present (Par) loop - - case Nkind (Par) is - -- Ignore ranges and they don't contribute to the result - - when N_Range => - return False; - - -- An object declaration whose parent is an extended return - -- statement is a return object. - - when N_Object_Declaration => - if Present (Parent (Par)) - and then Nkind (Parent (Par)) = N_Extended_Return_Statement - then - return True; - end if; - - -- We hit a simple return statement, so we know we are in one - - when N_Simple_Return_Statement => - return True; - - -- Only include one nexting level of function calls - - when N_Function_Call => - if not In_Function_Call then - In_Function_Call := True; - - -- When the function return type has implicit dereference - -- specified we know it cannot directly contribute to the - -- return value. - - if Present (Etype (Par)) - and then Has_Implicit_Dereference - (Get_Full_View (Etype (Par))) - then - return False; - end if; - else - return False; - end if; - - -- Check if we are on the right-hand side of an assignment - -- statement to a return object. - - -- This is not specified in the RM ??? - - when N_Assignment_Statement => - if Prev_Par = Name (Par) then - return False; - end if; - - Pre := Name (Par); - while Present (Pre) loop - if Is_Entity_Name (Pre) - and then Is_Return_Object (Entity (Pre)) - then - return True; - end if; - - exit when Nkind (Pre) not in N_Selected_Component - | N_Indexed_Component - | N_Slice; - - Pre := Prefix (Pre); - end loop; - - -- Otherwise, we hit a master which was not relevant - - when others => - if Is_Master (Par) then - return False; - end if; - end case; - - -- Iterate up to the next parent, keeping track of the previous one - - Prev_Par := Par; - Par := Parent (Par); - end loop; - - return False; - end In_Return_Value; - ----------------------------------------- -- In_Statement_Condition_With_Actions -- ----------------------------------------- @@ -18992,62 +19058,6 @@ package body Sem_Util is end if; end Is_Local_Variable_Reference; - --------------- - -- Is_Master -- - --------------- - - function Is_Master (N : Node_Id) return Boolean is - Disable_Subexpression_Masters : constant Boolean := True; - - begin - if Nkind (N) in N_Subprogram_Body | N_Task_Body | N_Entry_Body - or else Is_Statement (N) - then - return True; - end if; - - -- We avoid returning True when the master is a subexpression described - -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation - -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ??? - - if not Disable_Subexpression_Masters - and then Nkind (N) in N_Subexpr - then - declare - Par : Node_Id := N; - - subtype N_Simple_Statement_Other_Than_Simple_Return - is Node_Kind with Static_Predicate => - N_Simple_Statement_Other_Than_Simple_Return - in N_Abort_Statement - | N_Assignment_Statement - | N_Code_Statement - | N_Delay_Statement - | N_Entry_Call_Statement - | N_Free_Statement - | N_Goto_Statement - | N_Null_Statement - | N_Raise_Statement - | N_Requeue_Statement - | N_Exit_Statement - | N_Procedure_Call_Statement; - begin - while Present (Par) loop - Par := Parent (Par); - if Nkind (Par) in N_Subexpr | - N_Simple_Statement_Other_Than_Simple_Return - then - return False; - end if; - end loop; - - return True; - end; - end if; - - return False; - end Is_Master; - ----------------------- -- Is_Name_Reference -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b90d875594cf..821ef1a5f4f8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1747,10 +1747,17 @@ package Sem_Util is function In_Quantified_Expression (N : Node_Id) return Boolean; -- Returns true if the expression N occurs within a quantified expression - function In_Return_Value (Expr : Node_Id) return Boolean; - -- Returns true if the expression Expr occurs within a simple return - -- statement or is part of an assignment to the return object in an - -- extended return statement. + function In_Return_Value (Exp : Node_Id) return Boolean; + -- Returns true if expression Exp occurs within a simple return statement + -- or within the declaration of the return object in an extended return + -- statement. + + -- This predicate is intended to be used for accessibility purposes and + -- thus implements the criterion defined by RM 10.3.2(10.5/5): Exp must + -- either define the result of the enclosing function, in other words be + -- an operative constituent of the return value, or else must be part of + -- the return value and have its accessibility level tied to that of the + -- result of the enclosing function. function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean; -- Returns True if N denotes a component or subcomponent in a record or @@ -2302,9 +2309,6 @@ package Sem_Util is -- Determines whether Expr is a reference to a variable or formal parameter -- of mode OUT or IN OUT of the current enclosing subprogram. - function Is_Master (N : Node_Id) return Boolean; - -- Determine if the given node N constitutes a finalization master - function Is_Name_Reference (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is a reference to a name. This is -- similar to Is_Object_Reference but returns True only if N can be renamed
