From 43b264110f5581af0cc93308f9433fe8053f01cc Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 18 Sep 2019 08:33:07 +0000 Subject: [PATCH] [Ada] Spurious run time error on anonymous access formals This patch fixes an issue whereby subprograms with anonymous access formals may trigger spurious runtime accessibility errors when such formals are used as actuals in calls to nested subprograms. Running these commands: gnatmake -q pass.adb gnatmake -q fail.adb gnatmake -q test_main.adb gnatmake -q indirect_call_test.adb pass fail test_main indirect_call_test On the following sources: -- pass.adb procedure Pass is function A (Param : access Integer) return Boolean is type Typ is access all Integer; function A_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end; begin return A_Inner (Param) = Typ (Param); end; function B (Param : access Integer) return Boolean; function B (Param : access Integer) return Boolean is type Typ is access all Integer; function B_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end; begin return B_Inner (Param) = Typ (Param); end; procedure C (Param : access Integer) is type Typ is access all Integer; Var : Typ; procedure C_Inner (Param : access Integer) is begin Var := Typ (Param); -- OK end; begin C_Inner (Param); end; procedure D (Param : access Integer); procedure D (Param : access Integer) is type Typ is access all Integer; Var : Typ; procedure D_Inner (Param : access Integer) is begin Var := Typ (Param); -- OK end; begin D_Inner (Param); end; protected type E is function G (Param : access Integer) return Boolean; procedure I (Param : access Integer); end; protected body E is function F (Param : access Integer) return Boolean is type Typ is access all Integer; function F_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end; begin return F_Inner (Param) = Typ (Param); end; function G (Param : access Integer) return Boolean is type Typ is access all Integer; function G_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end; B : Boolean := F (Param); -- OK begin return G_Inner (Param) = Typ (Param); end; procedure H (Param : access Integer) is type Typ is access all Integer; Var : Typ; procedure H_Inner (Param : access Integer) is begin Var := Typ (Param); -- OK end; begin H_Inner (Param); end; procedure I (Param : access Integer) is type Typ is access all Integer; Var : Typ; procedure I_Inner (Param : access Integer) is begin Var := Typ (Param); -- OK end; begin H (Param); -- OK I_Inner (Param); end; end; task type J is end; task body J is function K (Param : access Integer) return Boolean is type Typ is access all Integer; function K_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end; begin return K_Inner (Param) = Typ (Param); end; function L (Param : access Integer) return Boolean; function L (Param : access Integer) return Boolean is type Typ is access all Integer; function L_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end; begin return L_Inner (Param) = Typ (Param); end; procedure M (Param : access Integer) is type Typ is access all Integer; Var : Typ; procedure M_Inner (Param : access Integer) is begin Var := Typ (Param); -- OK end; begin M_Inner (Param); end; procedure N (Param : access Integer); procedure N (Param : access Integer) is type Typ is access all Integer; Var : Typ; procedure N_Inner (Param : access Integer) is begin Var := Typ (Param); -- OK end; begin N_Inner (Param); end; Var : aliased Integer := 666; begin if K (Var'Access) then null; end if; -- OK if L (Var'Access) then null; end if; -- OK M (Var'Access); -- OK N (Var'Access); -- OK end; begin begin begin declare Var : aliased Integer := 666; T : J; Prot : E; begin if A (Var'Access) then null; end if; -- OK if B (Var'Access) then null; end if; -- OK C (Var'Access); -- OK D (Var'Access); -- OK if Prot.G (Var'Access) then null; end if; -- OK Prot.I (Var'Access); -- OK end; end; end; end; -- fail.adb procedure Fail is Failures : Integer := 0; type Base_Typ is access all Integer; function A (Param : access Integer) return Boolean is subtype Typ is Base_Typ; function A_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- ERROR end; begin return A_Inner (Param) = Typ (Param); exception when others => Failures := Failures + 1; return False; end; function B (Param : access Integer) return Boolean; function B (Param : access Integer) return Boolean is subtype Typ is Base_Typ; function B_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- ERROR end; begin return B_Inner (Param) = Typ (Param); exception when others => Failures := Failures + 1; return False; end; procedure C (Param : access Integer) is subtype Typ is Base_Typ; Var : Typ; procedure C_Inner (Param : access Integer) is begin Var := Typ (Param); -- ERROR end; begin C_Inner (Param); exception when others => Failures := Failures + 1; end; procedure D (Param : access Integer); procedure D (Param : access Integer) is subtype Typ is Base_Typ; Var : Typ; procedure D_Inner (Param : access Integer) is begin Var := Typ (Param); -- ERROR end; begin D_Inner (Param); exception when others => Failures := Failures + 1; end; protected type E is function G (Param : access Integer) return Boolean; procedure I (Param : access Integer); end; protected body E is function F (Param : access Integer) return Boolean is subtype Typ is Base_Typ; function F_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- ERROR end; begin return F_Inner (Param) = Typ (Param); exception when others => Failures := Failures + 1; return False; end; function G (Param : access Integer) return Boolean is subtype Typ is Base_Typ; function G_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- ERROR end; B : Boolean := F (Param); -- ERROR begin return G_Inner (Param) = Typ (Param); exception when others => Failures := Failures + 1; return False; end; procedure H (Param : access Integer) is subtype Typ is Base_Typ; Var : Typ; procedure H_Inner (Param : access Integer) is begin Var := Typ (Param); -- ERROR end; begin H_Inner (Param); exception when others => Failures := Failures + 1; end; procedure I (Param : access Integer) is subtype Typ is Base_Typ; Var : Typ; procedure I_Inner (Param : access Integer) is begin Var := Typ (Param); -- ERROR end; begin H (Param); -- ERROR I_Inner (Param); exception when others => Failures := Failures + 1; end; end; task type J is end; task body J is function K (Param : access Integer) return Boolean is subtype Typ is Base_Typ; function K_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- ERROR end; begin return K_Inner (Param) = Typ (Param); exception when others => Failures := Failures + 1; return False; end; function L (Param : access Integer) return Boolean; function L (Param : access Integer) return Boolean is subtype Typ is Base_Typ; function L_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- ERROR end; begin return L_Inner (Param) = Typ (Param); exception when others => Failures := Failures + 1; return False; end; procedure M (Param : access Integer) is subtype Typ is Base_Typ; Var : Typ; procedure M_Inner (Param : access Integer) is begin Var := Typ (Param); -- ERROR end; begin M_Inner (Param); exception when others => Failures := Failures + 1; end; procedure N (Param : access Integer); procedure N (Param : access Integer) is subtype Typ is Base_Typ; Var : Typ; procedure N_Inner (Param : access Integer) is begin Var := Typ (Param); -- ERROR end; begin N_Inner (Param); exception when others => Failures := Failures + 1; end; Var : aliased Integer := 666; begin if K (Var'Access) then null; end if; -- ERROR if L (Var'Access) then null; end if; -- ERROR M (Var'Access); -- ERROR N (Var'Access); -- ERROR end; begin begin begin declare Var : aliased Integer := 666; T : J; Prot : E; begin if A (Var'Access) then null; end if; -- ERROR if B (Var'Access) then null; end if; -- ERROR C (Var'Access); -- ERROR D (Var'Access); -- ERROR if Prot.G (Var'Access) then null; end if; -- ERROR Prot.I (Var'Access); -- ERROR if Failures /= 12 then raise Program_Error; end if; end; end; end; end; -- indirect_call_test.adb with Text_IO; procedure Indirect_Call_Test is Tracing_Enabled : constant Boolean := False; procedure Trace (S : String) is begin if Tracing_Enabled then Text_IO.Put_Line (S); end if; end; package Pkg is type Root is abstract tagged null record; function F (X : Root; Param : access Integer) return Boolean is abstract; end Pkg; function F_Wrapper (X : Pkg.Root; Param : access Integer) return Boolean is (Pkg.F (Pkg.Root'Class (X), Param)); -- dispatching call function A (Param : access Integer) return Boolean is type Typ is access all Integer; package Nested is type Ext is new Pkg.Root with null record; overriding function F (X : Ext; Param : access Integer) return Boolean; end Nested; function A_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end A_Inner; package body Nested is function F (X : Ext; Param : access Integer) return Boolean is begin return A_Inner (Param) = null; end; end; Ext_Obj : Nested.Ext; begin Trace ("In subtest A"); return F_Wrapper (Pkg.Root (Ext_Obj), Param); exception when Program_Error => Trace ("Failed"); return True; end A; function B (Param : access Integer) return Boolean is type Typ is access all Integer; function B_Inner (Param : access Integer) return Typ is begin return Typ (Param); -- OK end B_Inner; type Ref is access function (Param : access Integer) return Typ; Ptr : Ref := B_Inner'Access; function Ptr_Caller return Typ is (Ptr.all (Param)); -- access-to-subp value begin Trace ("In subtest B"); return Ptr_Caller = null; exception when Program_Error => Trace ("*** failed"); return True; end B; begin begin begin declare Var : aliased Integer := 666; begin if A (Var'Access) then null; end if; Trace ("Subtest A done"); if B (Var'Access) then null; end if; Trace ("Subtest B done"); end; end; end; end Indirect_Call_Test; Should produce the following output: Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure Failure 2019-09-18 Justin Squirek gcc/ada/ * einfo.adb, einfo.ads (Minimum_Accessibility): Added new field. (Set_Minimum_Accessibility): Added to set new field. (Minimum_Accessibility): Added to fetch new field. * exp_ch6.adb (Expand_Subprogram_Call): Modify calls to fetch accessibility levels to the new subprogram Get_Accessibility which handles cases where minimum accessibility might be needed. * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Add section to generate a Minimum_Accessibility object within relevant subprograms. * sem_util.adb, sem_util.ads (Dynamic_Accessibility_Level): Additional documentation added and modify section to use new function Get_Accessibility. (Get_Accessibility): Added to centralize processing of accessibility levels. From-SVN: r275858 --- gcc/ada/ChangeLog | 17 ++++++ gcc/ada/einfo.adb | 16 ++++++ gcc/ada/einfo.ads | 13 +++++ gcc/ada/exp_ch6.adb | 34 ++++++------ gcc/ada/sem_ch6.adb | 120 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.adb | 33 ++++++++++-- gcc/ada/sem_util.ads | 4 ++ 7 files changed, 216 insertions(+), 21 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 452243a9589..384f9820542 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2019-09-18 Justin Squirek + + * einfo.adb, einfo.ads (Minimum_Accessibility): Added new field. + (Set_Minimum_Accessibility): Added to set new field. + (Minimum_Accessibility): Added to fetch new field. + * exp_ch6.adb (Expand_Subprogram_Call): Modify calls to fetch + accessibility levels to the new subprogram Get_Accessibility + which handles cases where minimum accessibility might be needed. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Add section to + generate a Minimum_Accessibility object within relevant + subprograms. + * sem_util.adb, sem_util.ads (Dynamic_Accessibility_Level): + Additional documentation added and modify section to use new + function Get_Accessibility. + (Get_Accessibility): Added to centralize processing of + accessibility levels. + 2019-09-18 Steve Baird * sem_util.ads (Interval_Lists): A new visible package. This diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ebef3a0ca74..dcbeac5780c 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -215,6 +215,7 @@ package body Einfo is -- Stored_Constraint Elist23 -- Incomplete_Actuals Elist24 + -- Minimum_Accessibility Node24 -- Related_Expression Node24 -- Subps_Index Uint24 @@ -2847,6 +2848,12 @@ package body Einfo is return UI_To_Int (Uint8 (Id)); end Mechanism; + function Minimum_Accessibility (Id : E) return E is + begin + pragma Assert (Ekind (Id) in Formal_Kind); + return Node24 (Id); + end Minimum_Accessibility; + function Modulus (Id : E) return Uint is begin pragma Assert (Is_Modular_Integer_Type (Id)); @@ -6076,6 +6083,12 @@ package body Einfo is Set_Uint8 (Id, UI_From_Int (V)); end Set_Mechanism; + procedure Set_Minimum_Accessibility (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) in Formal_Kind); + Set_Node24 (Id, V); + end Set_Minimum_Accessibility; + procedure Set_Modulus (Id : E; V : U) is begin pragma Assert (Ekind (Id) = E_Modular_Integer_Type); @@ -10913,6 +10926,9 @@ package body Einfo is => Write_Str ("Related_Expression"); + when Formal_Kind => + Write_Str ("Minimum_Accessibility"); + when E_Function | E_Operator | E_Procedure diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e93a837b82e..3e968a29bd8 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3516,6 +3516,14 @@ package Einfo is -- is also set (to the default value of zero = Default_Mechanism) in a -- subprogram body entity but not used in this context. +-- Minimum_Accessibility (Node24) +-- Defined in formal parameters in the non-generic case. Normally Empty, +-- but if expansion is active, and a parameter exists for which a +-- dynamic accessibility check is required, then an object is generated +-- within such a subprogram representing the accessibility level of the +-- subprogram or the formal's Extra_Accessibility - whichever one is +-- lesser. The Minimum_Accessibility field then points to this object. + -- Modulus (Uint17) [base type only] -- Defined in modular types. Contains the modulus. For the binary case, -- this will be a power of 2, but if Non_Binary_Modulus is set, then it @@ -6273,6 +6281,7 @@ package Einfo is -- Default_Expr_Function (Node21) -- Protected_Formal (Node22) -- Extra_Constrained (Node23) + -- Minimum_Accessibility (Node24) -- Last_Assignment (Node26) (OUT, IN-OUT only) -- Activation_Record_Component (Node31) -- Has_Initial_Value (Flag219) @@ -7398,6 +7407,7 @@ package Einfo is function Materialize_Entity (Id : E) return B; function May_Inherit_Delayed_Rep_Aspects (Id : E) return B; function Mechanism (Id : E) return M; + function Minimum_Accessibility (Id : E) return E; function Modulus (Id : E) return U; function Must_Be_On_Byte_Boundary (Id : E) return B; function Must_Have_Preelab_Init (Id : E) return B; @@ -8103,6 +8113,7 @@ package Einfo is procedure Set_Materialize_Entity (Id : E; V : B := True); procedure Set_May_Inherit_Delayed_Rep_Aspects (Id : E; V : B := True); procedure Set_Mechanism (Id : E; V : M); + procedure Set_Minimum_Accessibility (Id : E; V : E); procedure Set_Modulus (Id : E; V : U); procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True); procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True); @@ -8973,6 +8984,7 @@ package Einfo is pragma Inline (Materialize_Entity); pragma Inline (May_Inherit_Delayed_Rep_Aspects); pragma Inline (Mechanism); + pragma Inline (Minimum_Accessibility); pragma Inline (Modulus); pragma Inline (Must_Be_On_Byte_Boundary); pragma Inline (Must_Have_Preelab_Init); @@ -9466,6 +9478,7 @@ package Einfo is pragma Inline (Set_Materialize_Entity); pragma Inline (Set_May_Inherit_Delayed_Rep_Aspects); pragma Inline (Set_Mechanism); + pragma Inline (Set_Minimum_Accessibility); pragma Inline (Set_Modulus); pragma Inline (Set_Must_Be_On_Byte_Boundary); pragma Inline (Set_Must_Have_Preelab_Init); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3277b46b0cc..78a1496d011 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3221,7 +3221,7 @@ package body Exp_Ch6 is -- Create possible extra actual for accessibility level - if Present (Extra_Accessibility (Formal)) then + if Present (Get_Accessibility (Formal)) then -- Ada 2005 (AI-252): If the actual was rewritten as an Access -- attribute, then the original actual may be an aliased object @@ -3297,8 +3297,8 @@ package body Exp_Ch6 is Add_Extra_Actual (Expr => - New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), - EF => Extra_Accessibility (Formal)); + New_Occurrence_Of (Get_Accessibility (Parm_Ent), Loc), + EF => Get_Accessibility (Formal)); end; elsif Is_Entity_Name (Prev_Orig) then @@ -3327,12 +3327,12 @@ package body Exp_Ch6 is begin pragma Assert (Present (Parm_Ent)); - if Present (Extra_Accessibility (Parm_Ent)) then + if Present (Get_Accessibility (Parm_Ent)) then Add_Extra_Actual (Expr => New_Occurrence_Of - (Extra_Accessibility (Parm_Ent), Loc), - EF => Extra_Accessibility (Formal)); + (Get_Accessibility (Parm_Ent), Loc), + EF => Get_Accessibility (Formal)); -- If the actual access parameter does not have an -- associated extra formal providing its scope level, @@ -3344,7 +3344,7 @@ package body Exp_Ch6 is (Expr => Make_Integer_Literal (Loc, Intval => Scope_Depth (Standard_Standard)), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); end if; end; @@ -3354,7 +3354,7 @@ package body Exp_Ch6 is else Add_Extra_Actual (Expr => Dynamic_Accessibility_Level (Prev_Orig), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); end if; -- If the actual is an access discriminant, then pass the level @@ -3370,7 +3370,7 @@ package body Exp_Ch6 is (Expr => Make_Integer_Literal (Loc, Intval => Object_Access_Level (Prefix (Prev_Orig))), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); -- All other cases @@ -3440,19 +3440,19 @@ package body Exp_Ch6 is Make_Integer_Literal (Loc, Intval => Type_Access_Level (Pref_Entity)), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); elsif Nkind (Prev_Orig) = N_Explicit_Dereference and then Present (Pref_Entity) and then Is_Formal (Pref_Entity) and then Present - (Extra_Accessibility (Pref_Entity)) + (Get_Accessibility (Pref_Entity)) then Add_Extra_Actual (Expr => New_Occurrence_Of - (Extra_Accessibility (Pref_Entity), Loc), - EF => Extra_Accessibility (Formal)); + (Get_Accessibility (Pref_Entity), Loc), + EF => Get_Accessibility (Formal)); else Add_Extra_Actual @@ -3460,7 +3460,7 @@ package body Exp_Ch6 is Make_Integer_Literal (Loc, Intval => Object_Access_Level (Prev_Orig)), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); end if; -- Treat the unchecked attributes as library-level @@ -3472,7 +3472,7 @@ package body Exp_Ch6 is (Expr => Make_Integer_Literal (Loc, Intval => Scope_Depth (Standard_Standard)), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); -- No other cases of attributes returning access -- values that can be passed to access parameters. @@ -3494,7 +3494,7 @@ package body Exp_Ch6 is (Expr => Make_Integer_Literal (Loc, Intval => Scope_Depth (Current_Scope) + 1), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); -- For most other cases we simply pass the level of the -- actual's access type. The type is retrieved from @@ -3505,7 +3505,7 @@ package body Exp_Ch6 is when others => Add_Extra_Actual (Expr => Dynamic_Accessibility_Level (Prev), - EF => Extra_Accessibility (Formal)); + EF => Get_Accessibility (Formal)); end case; end if; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ddb12ec52f5..eb6768d3ae2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3376,6 +3376,9 @@ package body Sem_Ch6 is -- Local variables + Body_Nod : Node_Id := Empty; + Minimum_Acc_Objs : List_Id := No_List; + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; Saved_IGR : constant Node_Id := Ignored_Ghost_Region; Saved_EA : constant Boolean := Expander_Active; @@ -4254,6 +4257,110 @@ package body Sem_Ch6 is end; end if; + -- Generate minimum accessibility local objects to correspond with + -- any extra formal added for anonymous access types. This new local + -- object can then be used instead of the formal in case it is used + -- in an actual to a call to a nested subprogram. + + -- This method is used to suppliment our "small integer model" for + -- accessibility check generation (for more information see + -- Dynamic_Accessibility_Level). + + -- Because we allow accesibility values greater than our expected value + -- passing along the same extra accessibility formal as an actual + -- to a nested subprogram becomes a problem because high values mean + -- different things to the callee even though they are the same to the + -- caller. So, as described in the first section, we create a local + -- object representing the minimum of the accessibility level value that + -- is passed in and the accessibility level of the callee's parameter + -- and locals and use it in the case of a call to a nested subprogram. + -- This generated object is refered to as a "minimum accessiblity + -- level." + + if Present (Spec_Id) or else Present (Body_Id) then + Body_Nod := Unit_Declaration_Node (Body_Id); + + declare + Form : Entity_Id; + begin + -- Grab the appropriate formal depending on whether there exists + -- an actual spec for the subprogram or whether we are dealing + -- with a protected subprogram. + + if Present (Spec_Id) then + if Present (Protected_Body_Subprogram (Spec_Id)) then + Form := First_Formal (Protected_Body_Subprogram (Spec_Id)); + else + Form := First_Formal (Spec_Id); + end if; + else + Form := First_Formal (Body_Id); + end if; + + -- Loop through formals if the subprogram is capable of accepting + -- a generated local object. If it is not then it is also not + -- capable of having local subprograms meaning it would not need + -- a minimum accessibility level object anyway. + + if Present (Body_Nod) + and then Has_Declarations (Body_Nod) + and then Nkind (Body_Nod) /= N_Package_Specification + then + while Present (Form) loop + + if Present (Extra_Accessibility (Form)) + and then No (Minimum_Accessibility (Form)) + then + -- Generate the minimum accessibility level object + + -- A60b : integer := integer'min(2, paramL); + + declare + Loc : constant Source_Ptr := Sloc (Body_Nod); + Obj_Node : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Temporary + (Loc, 'A', Extra_Accessibility (Form)), + Object_Definition => New_Occurrence_Of + (Standard_Integer, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (Standard_Integer, Loc), + Attribute_Name => Name_Min, + Expressions => New_List ( + Make_Integer_Literal (Loc, + Object_Access_Level (Form)), + New_Occurrence_Of + (Extra_Accessibility (Form), Loc)))); + begin + -- Add the new local object to the Minimum_Acc_Obj to + -- be later prepended to the subprogram's list of + -- declarations after we are sure all expansion is + -- done. + + if Present (Minimum_Acc_Objs) then + Prepend (Obj_Node, Minimum_Acc_Objs); + else + Minimum_Acc_Objs := New_List (Obj_Node); + end if; + + -- Register the object and analyze it + + Set_Minimum_Accessibility + (Form, Defining_Identifier (Obj_Node)); + + Analyze (Obj_Node); + end; + end if; + + Next_Formal (Form); + end loop; + end if; + end; + end if; + -- Now we can go on to analyze the body HSS := Handled_Statement_Sequence (N); @@ -4358,6 +4465,19 @@ package body Sem_Ch6 is Inspect_Deferred_Constant_Completion (Declarations (N)); Analyze (HSS); + -- Add the generated minimum accessibility objects to the subprogram + -- body's list of declarations after analysis of the statements and + -- contracts. + + while Is_Non_Empty_List (Minimum_Acc_Objs) loop + if Present (Declarations (Body_Nod)) then + Prepend (Remove_Head (Minimum_Acc_Objs), Declarations (Body_Nod)); + else + Set_Declarations + (Body_Nod, New_List (Remove_Head (Minimum_Acc_Objs))); + end if; + end loop; + -- Deal with end of scope processing for the body Process_End_Label (HSS, 't', Current_Scope); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 13555a56cbe..1bcda5fa172 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6531,10 +6531,11 @@ package body Sem_Util is return Dynamic_Accessibility_Level (Renamed_Object (E)); end if; - if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then - if Present (Extra_Accessibility (E)) then - return New_Occurrence_Of (Extra_Accessibility (E), Loc); - end if; + if (Is_Formal (E) + or else Ekind_In (E, E_Variable, E_Constant)) + and then Present (Get_Accessibility (E)) + then + return New_Occurrence_Of (Get_Accessibility (E), Loc); end if; end if; @@ -9212,6 +9213,30 @@ package body Sem_Util is end if; end Gather_Components; + ----------------------- + -- Get_Accessibility -- + ----------------------- + + function Get_Accessibility (E : Entity_Id) return Node_Id is + begin + -- When minimum accessibility is set for E then we utilize it - except + -- in a few edge cases like the expansion of select statements where + -- generated subprogram may attempt to unnecessarily use a minimum + -- accessibility object declared outside of scope. + + -- To avoid these situations where expansion may get complex we verify + -- that the minimum accessibility object is within scope. + + if Ekind (E) in Formal_Kind + and then Present (Minimum_Accessibility (E)) + and then In_Open_Scopes (Scope (Minimum_Accessibility (E))) + then + return Minimum_Accessibility (E); + end if; + + return Extra_Accessibility (E); + end Get_Accessibility; + ------------------------ -- Get_Actual_Subtype -- ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c77f4414a74..b41b8750fd2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -983,6 +983,10 @@ package Sem_Util is -- discriminants. Otherwise all components of the parent must be included -- in the subtype for semantic analysis. + function Get_Accessibility (E : Entity_Id) return Node_Id; + -- Obtain the accessibility level for a given entity formal taking into + -- account both extra and minimum accessibility. + function Get_Actual_Subtype (N : Node_Id) return Entity_Id; -- Given a node for an expression, obtain the actual subtype of the -- expression. In the case of a parameter where the formal is an -- 2.30.2