https://gcc.gnu.org/g:9ad0debac132b46496171e83f120dff1bbb3fc17
commit r17-1322-g9ad0debac132b46496171e83f120dff1bbb3fc17 Author: Eric Botcazou <[email protected]> Date: Sat May 16 13:35:22 2026 +0200 ada: Fix small inaccuracy in Function_Call_Or_Allocator_Level In the case of an object declaration, the function returns the depth of the enclosing static scope, instead of that of the enclosing dynamic scope like its parent function Accessibility_Level. The change contains a couple of cleanups in the expander, which resort to calling Accessibility_Level in more cases instead of doing manual work. gcc/ada/ChangeLog: * accessibility.ads (Accessibility_Level_Kind): Tweak description. * accessibility.adb (Function_Call_Or_Allocator_Level): Recurse on the defining identifier for an N_Object_Declaration node. (Accessibility_Level): Minor tweaks. * exp_ch3.adb (Expand_N_Object_Declaration): Do not special case function calls in the computation of accessibility levels. * exp_ch5.adb (Expand_N_Assignment_Statement): Do not manually compute the accessibility level of the LHS. Diff: --- gcc/ada/accessibility.adb | 28 ++++++++-------- gcc/ada/accessibility.ads | 35 +++++++++++--------- gcc/ada/exp_ch3.adb | 13 +------- gcc/ada/exp_ch5.adb | 82 +++++++++++++---------------------------------- 4 files changed, 56 insertions(+), 102 deletions(-) diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index f29e846a98e0..36ecd0a35465 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -444,8 +444,8 @@ package body Accessibility is when N_Object_Declaration => return - Make_Level_Literal - (Scope_Depth (Scope (Defining_Identifier (Par)))); + Accessibility_Level + (Defining_Identifier (Par), Object_Decl_Level); -- For the dynamic allocation of an object, return the -- accessibility level of the allocator. @@ -612,7 +612,7 @@ package body Accessibility is -- Anonymous access types - elsif Nkind (Pre) in N_Has_Entity + elsif Is_Entity_Name (Pre) and then Ekind (Entity (Pre)) not in Subprogram_Kind and then Present (Get_Dynamic_Accessibility (Entity (Pre))) and then Level = Dynamic_Level @@ -666,27 +666,26 @@ package body Accessibility is then return Make_Level_Literal (Scope_Depth (Standard_Standard)); - -- Something went wrong and an extra accessibility formal has not - -- been generated when one should have ??? + -- Return the library level for formal parameters of an anonymous + -- access type without extra accessiblity formal. This may happen + -- for subprograms with foreign convention or when expansion is + -- disabled, see Sem_Ch6.Create_Extra_Formals. elsif Is_Formal (E) - and then No (Get_Dynamic_Accessibility (E)) and then Ekind (Etype (E)) = E_Anonymous_Access_Type + and then No (Get_Dynamic_Accessibility (E)) then return Make_Level_Literal (Scope_Depth (Standard_Standard)); - -- Stand-alone object of an anonymous access type "SAOAAT" + -- Formal parameters with an extra accessibility formal, as well + -- as stand-alone objects of an anonymous access type (SAOOAAAT). - elsif (Is_Formal (E) - or else Ekind (E) in E_Variable - | E_Constant) + elsif (Is_Formal (E) or else Ekind (E) in E_Constant | E_Variable) and then Present (Get_Dynamic_Accessibility (E)) - and then (Level = Dynamic_Level - or else Level = Zero_On_Dynamic_Level) + and then (Level in Dynamic_Level | Zero_On_Dynamic_Level) then if Level = Zero_On_Dynamic_Level then - return Make_Level_Literal - (Scope_Depth (Standard_Standard)); + return Make_Level_Literal (Scope_Depth (Standard_Standard)); end if; -- No_Dynamic_Accessibility_Checks restriction override for @@ -776,6 +775,7 @@ package body Accessibility is elsif Level = Dynamic_Level and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter + and then Is_Subprogram (Scope (E)) and then Present (Init_Proc_Level_Formal (Scope (E))) then return New_Occurrence_Of diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads index 552074e085d8..3b52986a1fb7 100644 --- a/gcc/ada/accessibility.ads +++ b/gcc/ada/accessibility.ads @@ -35,22 +35,25 @@ package Accessibility is -- rules of 3.10.2 are violated. type Accessibility_Level_Kind is - (Dynamic_Level, - Object_Decl_Level, - Zero_On_Dynamic_Level); - -- Accessibility_Level_Kind is an enumerated type which captures the - -- different modes in which an accessibility level could be obtained for - -- a given expression. - - -- When in the context of the function Accessibility_Level, - -- Accessibility_Level_Kind signals what type of accessibility level to - -- obtain. For example, when Level is Dynamic_Level, a defining identifier - -- associated with a saooaaat may be returned or an N_Integer_Literal node. - -- When the level is Object_Decl_Level, an N_Integer_Literal node is - -- returned containing the level of the declaration of the object if - -- relevant (be it a saooaaat or otherwise). Finally, Zero_On_Dynamic_Level - -- returns library level for all cases where the accessibility level is - -- dynamic (used to bypass static accessibility checks in dynamic cases). + (Dynamic_Level, Object_Decl_Level, Zero_On_Dynamic_Level); + -- Captures the different modes in which an accessibility level could be + -- obtained for a given expression. In the context of Accessibility_Level + -- function, Accessibility_Level_Kind signals what type of accessibility + -- level to obtain. + + -- When Level is Dynamic_Level, a defining identifier associated with an + -- access parameter, an access result, or an SAOOAAAT, may be returned, + -- and an N_Integer_Literal node in the other cases. + + -- When Level is Object_Decl_Level, an N_Integer_Literal node whose value + -- is the level of the declaration of the object is returned in the cases + -- where Dynamic_Level returns a defining identifier; in the other cases, + -- the same N_Integer_Literal node as Dynamic_Level is returned. + + -- When Level is Zero_On_Dynamic_Level, an N_Integer_Literal node whose + -- value is zero (i.e. that of the library level) is returned in the cases + -- where Dynamic_Level returns a defining identifier; in the other cases, + -- the same N_Integer_Literal node as Dynamic_Level is returned. function Accessibility_Level (Expr : Node_Id; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d92ab21976d9..036a8010631f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8752,18 +8752,7 @@ package body Exp_Ch3 is if No (Expr) then Level_Expr := - Make_Integer_Literal - (Loc, Scope_Depth (Standard_Standard)); - - -- When the expression of the object is a function which returns - -- an anonymous access type the master of the call is the object - -- being initialized instead of the type. - - elsif Nkind (Expr) = N_Function_Call - and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type - then - Level_Expr := Accessibility_Level - (Def_Id, Object_Decl_Level); + Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); -- General case diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 92c1ef0bb79e..ead0425214c9 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2863,7 +2863,7 @@ package body Exp_Ch5 is Apply_Constraint_Check (Rhs, Etype (Lhs)); end if; - -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a + -- Ada 2012 (AI05-148): Update current accessibility level if Lhs is a -- stand-alone obj of an anonymous access type. Do not install the check -- when the Lhs denotes a container cursor and the Next function employs -- an access type, because this can never result in a dangling pointer. @@ -2873,66 +2873,28 @@ package body Exp_Ch5 is and then Ekind (Entity (Lhs)) /= E_Loop_Parameter and then Present (Effective_Extra_Accessibility (Entity (Lhs))) then - declare - function Lhs_Entity return Entity_Id; - -- Look through renames to find the underlying entity. - -- For assignment to a rename, we don't care about the - -- Enclosing_Dynamic_Scope of the rename declaration. - - ---------------- - -- Lhs_Entity -- - ---------------- - - function Lhs_Entity return Entity_Id is - Result : Entity_Id := Entity (Lhs); - - begin - while Present (Renamed_Object (Result)) loop - - -- Renamed_Object must return an Entity_Name here - -- because of preceding "Present (E_E_A (...))" test. - - Result := Entity (Renamed_Object (Result)); - end loop; - - return Result; - end Lhs_Entity; - - -- Local Declarations - - Access_Check : constant Node_Id := - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => - Accessibility_Level (Rhs, Dynamic_Level), - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => - Scope_Depth - (Enclosing_Dynamic_Scope - (Lhs_Entity)))), - Reason => PE_Accessibility_Check_Failed); - - Access_Level_Update : constant Node_Id := - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Effective_Extra_Accessibility - (Entity (Lhs)), Loc), - Expression => - Accessibility_Level - (Expr => Rhs, - Level => Dynamic_Level, - Allow_Alt_Model => False)); - - begin - if not Accessibility_Checks_Suppressed (Entity (Lhs)) then - Insert_Action (N, Access_Check); - end if; + if not Accessibility_Checks_Suppressed (Entity (Lhs)) then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Accessibility_Level (Rhs, Dynamic_Level), + Right_Opnd => + Accessibility_Level (Lhs, Object_Decl_Level)), + Reason => PE_Accessibility_Check_Failed)); + end if; - Insert_Action (N, Access_Level_Update); - end; + Insert_Action (N, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Effective_Extra_Accessibility (Entity (Lhs)), Loc), + Expression => + Accessibility_Level + (Expr => Rhs, + Level => Dynamic_Level, + Allow_Alt_Model => False))); end if; -- Case of assignment to a bit packed array element. If there is a
