https://gcc.gnu.org/g:acc245a1aebc522c644f21f0d119b82c5971b49f
commit r17-1324-gacc245a1aebc522c644f21f0d119b82c5971b49f Author: Eric Botcazou <[email protected]> Date: Sat May 16 18:58:41 2026 +0200 ada: Get rid of Effective_Extra_Accessibility function The computation of accessibility levels does not consistently look through object renamings when extra accessibility objects are used. This attempts to address the issue by making Extra_Accessibility do it automatically. gcc/ada/ChangeLog: * einfo.ads (Extra_Accessibility): Rename to... (Extra_Accessibility_Of_Object): ...this and adjust description. * gen_il-fields.ads (Opt_Field_Enum): Replace Extra_Accessibility with Extra_Accessibility_Of_Object. * gen_il-gen-gen_entities.adb (Constant_Or_Variable_Kind): Ditto. (Formal_Kind): Ditto. * accessibility.ads (Effective_Extra_Accessibility): Rename to... (Extra_Accessibility): ...this. * accessibility.adb (Apply_Accessibility_Check_For_Parameter): Do not manually look through renamings and adjust. (Effective_Extra_Accessibility): Rename to... (Extra_Accessibility): ...this and add guard. * exp_ch3.adb (Expand_N_Object_Declaration): Adjust. * exp_ch4.adb (Expand_N_Type_Conversion): Likewise. * exp_ch5.adb (Expand_N_Assignment_Statement): Likewise. * exp_ch6.adb (Expand_Actuals): Likewise. * sem_ch3.adb (Derive_Subprogram): Likewise. * sem_ch6.adb (Create_Extra_Formals): Likewise. Diff: --- gcc/ada/accessibility.adb | 52 +++++++++++++++++++------------------ gcc/ada/accessibility.ads | 5 ++-- gcc/ada/einfo.ads | 26 +++++++++---------- gcc/ada/exp_ch3.adb | 2 +- gcc/ada/exp_ch4.adb | 26 +++---------------- gcc/ada/exp_ch5.adb | 5 ++-- gcc/ada/exp_ch6.adb | 5 ++-- gcc/ada/gen_il-fields.ads | 2 +- gcc/ada/gen_il-gen-gen_entities.adb | 4 +-- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 2 +- 11 files changed, 56 insertions(+), 75 deletions(-) diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 36ecd0a35465..a8ba9c85ec37 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -1558,42 +1558,40 @@ package body Accessibility is Loc : constant Source_Ptr := Sloc (N); Check_Cond : Node_Id; - Param_Ent : Entity_Id := Param_Entity (N); + Param_Ent : Entity_Id; Param_Level : Node_Id; Type_Level : Node_Id; begin + if Inside_A_Generic then + return; + end if; + -- Verify we haven't tried to add a dynamic accessibility check when we -- shouldn't. pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N)); + Param_Ent := Param_Entity (N); + + -- Stand-alone object of an anonymous access type (SAOOAAAT) + if Ada_Version >= Ada_2012 and then No (Param_Ent) and then Is_Entity_Name (N) and then Ekind (Entity (N)) in E_Constant | E_Variable - and then Present (Effective_Extra_Accessibility (Entity (N))) + and then Present (Extra_Accessibility (Entity (N))) then Param_Ent := Entity (N); - while Present (Renamed_Object (Param_Ent)) loop - -- Renamed_Object must return an Entity_Name here - -- because of preceding "Present (E_E_A (...))" test. - - Param_Ent := Entity (Renamed_Object (Param_Ent)); - end loop; end if; - if Inside_A_Generic then - return; + -- Apply the run-time check only if the access object has an associated + -- extra access level object and when accessibility checks are enabled. - -- Only apply the run-time check if the access parameter has an - -- associated extra access level parameter and when accessibility checks - -- are enabled. - - elsif Present (Param_Ent) - and then Present (Get_Dynamic_Accessibility (Param_Ent)) - and then not Accessibility_Checks_Suppressed (Param_Ent) - and then not Accessibility_Checks_Suppressed (Typ) + if Present (Param_Ent) + and then Present (Get_Dynamic_Accessibility (Param_Ent)) + and then not Accessibility_Checks_Suppressed (Param_Ent) + and then not Accessibility_Checks_Suppressed (Typ) then -- Obtain the parameter's accessibility level @@ -2268,20 +2266,24 @@ package body Accessibility is end if; end Deepest_Type_Access_Level; - ----------------------------------- - -- Effective_Extra_Accessibility -- - ----------------------------------- + ------------------------- + -- Extra_Accessibility -- + ------------------------- - function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is + function Extra_Accessibility (Id : Entity_Id) return Entity_Id is begin if Present (Renamed_Object (Id)) and then Is_Entity_Name (Renamed_Object (Id)) then - return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); + return Extra_Accessibility (Entity (Renamed_Object (Id))); + end if; + + if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then + return Extra_Accessibility_Of_Object (Id); else - return Extra_Accessibility (Id); + return Empty; end if; - end Effective_Extra_Accessibility; + end Extra_Accessibility; ------------------------------- -- Get_Dynamic_Accessibility -- diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads index 3b52986a1fb7..cfec56d3507a 100644 --- a/gcc/ada/accessibility.ads +++ b/gcc/ada/accessibility.ads @@ -138,8 +138,9 @@ package Accessibility is -- The Allow_Alt_Model parameter allows the alternative level calculation -- under the restriction No_Dynamic_Accessibility_Checks to be performed. - function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; - -- Same as Extra_Accessibility in Einfo, but looks through object renamings + function Extra_Accessibility (Id : Entity_Id) return Entity_Id; + -- Same as Extra_Accessibility_Of_Object in Einfo, but looks through object + -- renamings per the RM 3.10.2(8) rule. function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id; -- Obtain the accessibility level for a given entity formal taking into diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b156de6ee051..8d8ee1cd3627 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1251,17 +1251,17 @@ package Einfo is -- Note one obscure case: for pragma Default_Storage_Pool (null), the -- Etype of the N_Null node is Empty. --- Extra_Accessibility --- Defined in formal parameters in the non-generic case. Normally Empty, --- but if expansion is active, and a parameter is one for which a +-- Extra_Accessibility_Of_Object +-- Defined in formal parameters in the non-generic case: normally Empty, +-- but if expansion is active, and a formal parameter is one for which a -- dynamic accessibility check is required, then an extra formal of type -- Natural is created (see description of field Extra_Formal), and the --- Extra_Accessibility field of the formal parameter points to the entity --- for this extra formal. Also defined in variables when compiling --- receiving stubs. In this case, a non Empty value means that this --- variable's accessibility depth has been transmitted by the caller and --- must be retrieved through the entity designed by this field instead of --- being computed. +-- Extra_Accessibility_Of_Object of the formal parameter points to the +-- entity of this extra formal. Defined in stand-alone objects: normally +-- Empty, but if expansion is active, and the object is one for which a +-- dynamic accessibility check is required (AI05-0148), then a variable +-- of type Natural is created and the Extra_Accessibility_Of_Object of +-- the object points to the entity of this variable. -- Extra_Accessibility_Of_Result -- Defined in (non-generic) Function, Operator, and Subprogram_Type @@ -1289,7 +1289,7 @@ package Einfo is -- parameters require extra implicit information to be passed (e.g. the -- flag indicating if an unconstrained variant record argument is -- constrained, and the accessibility level for access parameters). See --- description of Extra_Constrained, Extra_Accessibility fields for +-- description of Extra_Constrained and Extra_Accessibility_Of_Object for -- further details. Extra formal parameters are constructed to represent -- these values, and chained to the end of the list of formals using the -- Extra_Formal field (i.e. the Extra_Formal field of the last "real" @@ -5392,7 +5392,7 @@ package Einfo is -- Discriminal_Link -- Full_View -- Esize - -- Extra_Accessibility (constants only) + -- Extra_Accessibility_Of_Object (constants only) -- Alignment -- Actual_Subtype -- Renamed_Object @@ -5744,7 +5744,7 @@ package Einfo is -- Discriminal_Link (discriminals only) -- Entry_Component -- Esize - -- Extra_Accessibility + -- Extra_Accessibility_Of_Object -- Alignment -- Extra_Formal -- Unset_Reference @@ -6292,7 +6292,7 @@ package Einfo is -- Part_Of_Constituents -- Part_Of_References -- Esize - -- Extra_Accessibility + -- Extra_Accessibility_Of_Object -- Alignment -- Unset_Reference -- Actual_Subtype diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 036a8010631f..b67e784c6c4c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8771,7 +8771,7 @@ package body Exp_Ch3 is Insert_Action_After (Init_After, Level_Decl); - Set_Extra_Accessibility (Def_Id, Level); + Set_Extra_Accessibility_Of_Object (Def_Id, Level); end; end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b90107f09cab..41448c9df617 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -11531,10 +11531,6 @@ package body Exp_Ch4 is procedure Real_Range_Check; -- Handles generation of range check for real target value - function Has_Extra_Accessibility (Id : Entity_Id) return Boolean; - -- True iff Present (Effective_Extra_Accessibility (Id)) successfully - -- evaluates to True. - function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id) return Boolean; -- Given a target type for a conversion, determine whether the @@ -12047,22 +12043,6 @@ package body Exp_Ch4 is Rewrite (Expr, New_Occurrence_Of (Tnn, Loc)); end Real_Range_Check; - ----------------------------- - -- Has_Extra_Accessibility -- - ----------------------------- - - -- Returns true for a formal of an anonymous access type or for an Ada - -- 2012-style stand-alone object of an anonymous access type. - - function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is - begin - if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then - return Present (Effective_Extra_Accessibility (Id)); - else - return False; - end if; - end Has_Extra_Accessibility; - ---------------------------------------- -- Statically_Deeper_Relation_Applies -- ---------------------------------------- @@ -12342,9 +12322,9 @@ package body Exp_Ch4 is -- 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)) - and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type + elsif Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type + and then Is_Entity_Name (Operand_Acc) + and then Present (Extra_Accessibility (Entity (Operand_Acc))) and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) and then not No_Dynamic_Accessibility_Checks_Enabled (N) diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index ead0425214c9..5d7c78f82f67 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2871,7 +2871,7 @@ package body Exp_Ch5 is if Is_Access_Type (Typ) and then Is_Entity_Name (Lhs) and then Ekind (Entity (Lhs)) /= E_Loop_Parameter - and then Present (Effective_Extra_Accessibility (Entity (Lhs))) + and then Present (Extra_Accessibility (Entity (Lhs))) then if not Accessibility_Checks_Suppressed (Entity (Lhs)) then Insert_Action (N, @@ -2888,8 +2888,7 @@ package body Exp_Ch5 is Insert_Action (N, Make_Assignment_Statement (Loc, Name => - New_Occurrence_Of - (Effective_Extra_Accessibility (Entity (Lhs)), Loc), + New_Occurrence_Of (Extra_Accessibility (Entity (Lhs)), Loc), Expression => Accessibility_Level (Expr => Rhs, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 79359f5f846c..a31dd269d92e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1803,8 +1803,7 @@ package body Exp_Ch6 is if Is_Access_Type (E_Formal) and then Is_Entity_Name (Lhs) - and then - Present (Effective_Extra_Accessibility (Entity (Lhs))) + and then Present (Extra_Accessibility (Entity (Lhs))) and then not No_Dynamic_Accessibility_Checks_Enabled (Lhs) then -- Copyback target is an Ada 2012 stand-alone object of an @@ -1829,7 +1828,7 @@ package body Exp_Ch6 is Append_To (Post_Call, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of ( - Effective_Extra_Accessibility (Entity (Lhs)), Loc), + Extra_Accessibility (Entity (Lhs)), Loc), Expression => Make_Integer_Literal (Loc, Type_Access_Level (E_Formal)))); diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 31e7cb458fd7..e354b242427d 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -535,7 +535,7 @@ package Gen_IL.Fields is Enumeration_Rep_Expr, Equivalent_Type, Esize, - Extra_Accessibility, + Extra_Accessibility_Of_Object, Extra_Accessibility_Of_Result, Extra_Constrained, Extra_Formal, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 60de3aa27d81..6d94315031d6 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -347,7 +347,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Contract, Node_Id), Sm (Discriminal_Link, Node_Id), Sm (Encapsulating_State, Node_Id), - Sm (Extra_Accessibility, Node_Id), + Sm (Extra_Accessibility_Of_Object, Node_Id), Sm (Initialization_Statements, Node_Id), Sm (Is_Elaboration_Checks_OK_Id, Flag), Sm (Is_Elaboration_Warnings_OK_Id, Flag), @@ -401,7 +401,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Alignment, Unat), Sm (Default_Value, Node_Id), Sm (Entry_Component, Node_Id), - Sm (Extra_Accessibility, Node_Id), + Sm (Extra_Accessibility_Of_Object, Node_Id), Sm (Extra_Constrained, Node_Id), Sm (Extra_Formal, Node_Id), Sm (Has_Initial_Value, Flag), diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1bc9e288bc63..337c99c03248 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16868,7 +16868,7 @@ package body Sem_Ch3 is if Is_Limited_Interface (Parent_Type) then Set_Extra_Formal (New_Formal, Empty); - Set_Extra_Accessibility (New_Formal, Empty); + Set_Extra_Accessibility_Of_Object (New_Formal, Empty); end if; -- Normally we do not go copying parents, but in the case of diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 95cd7c0f35e1..d1704b00919c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9306,7 +9306,7 @@ package body Sem_Ch6 is pragma Assert (No (Alias_Formal) or else Present (Extra_Accessibility (Alias_Formal))); - Set_Extra_Accessibility + Set_Extra_Accessibility_Of_Object (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L")); else
