From d7e20130650fb46d71e0403652e4e07bc14f9775 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Mon, 10 Aug 2020 12:05:07 -0400 Subject: [PATCH] [Ada] Reimplementation of accessibility checking gcc/ada/ * checks.adb (Apply_Accessibility_Check): Modify condition to avoid flawed optimization and use Get_Accessibility over Extra_Accessibility. * exp_attr.adb: Remove inclusion of Exp_Ch2.adb. * exp_ch2.adb, exp_ch2.ads (Param_Entity): Moved to sem_util. * exp_ch3.ads (Init_Proc_Level_Formal): New function. * exp_ch3.adb (Build_Init_Procedure): Add extra accessibility formal for init procs when the associated type is a limited record. (Build_Initialization_Call): Add condition to handle propagation of the new extra accessibility paramter actual needed for init procs. (Init_Proc_Level_Formal): Created to fetch a the extra accessibility parameter associated with init procs if one exists. * exp_ch4.adb (Build_Attribute_Reference): Modify static check to be dynamic. * exp_ch6.adb (Add_Cond_Expression_Extra_Actual): Move logic used to expand conditional expressions used as actuals for anonymous access formals. (Expand_Call_Helper): Remove extranious accessibility calculation logic. * exp_util.adb: Remove inclusion of Exp_Ch2.adb. * par-ch3.adb (P_Array_Type_Definition): Properly set Aliased_Present on access definitions * sem_attr.adb (Resolve_Attribute): Replace instances for Object_Access_Level with Static_Accessibility_Level. * sem_ch13.adb (Storage_Pool): Replace instances for Object_Access_Level with Static_Accessibility_Level. * sem_ch6.adb (Check_Return_Construct_Accessibility): Replace instances for Object_Access_Level with Static_Accessibility_Level. * sem_ch9.adb (Analyze_Requeue): Replace instances for Object_Access_Level with Static_Accessibility_Level. * sem_res.adb (Check_Aliased_Parameter, Check_Allocator_Discrim_Accessibility, Valid_Conversion): Replace instances for Object_Access_Level with Static_Accessibility_Level. * sem_util.adb, sem_util.ads (Accessibility_Level_Helper): Created to centralize calculation of accessibility levels. (Build_Component_Subtype): Replace instances for Object_Access_Level with Static_Accessibility_Level. (Defining_Entity): Add extra parameter to dictate whether an error is raised or empty is return in the case of an irrelevant N. (Dynamic_Accessibility_Level): Rewritten to use Accessibility_Level_Helper. (Is_View_Conversion): Check membership against Etype to capture nodes like explicit dereferences which have types but are not expanded names or identifers. (Object_Access_LeveL): Removed. (Param_Entity): Moved from sem_util. (Static_Accessibility_Level): Created as a replacement to Object_Access_Level, it also uses Accessibility_Level_Helper for its implementation. * snames.ads-tmpl: Added new name for extra accessibility parameter in init procs. --- gcc/ada/checks.adb | 12 +- gcc/ada/exp_attr.adb | 1 - gcc/ada/exp_ch2.adb | 94 ---- gcc/ada/exp_ch2.ads | 10 - gcc/ada/exp_ch3.adb | 66 ++- gcc/ada/exp_ch3.ads | 5 + gcc/ada/exp_ch4.adb | 43 +- gcc/ada/exp_ch6.adb | 835 ++++++++-------------------- gcc/ada/exp_util.adb | 1 - gcc/ada/par-ch3.adb | 2 +- gcc/ada/sem_attr.adb | 9 +- gcc/ada/sem_ch13.adb | 4 +- gcc/ada/sem_ch6.adb | 6 +- gcc/ada/sem_ch9.adb | 2 +- gcc/ada/sem_res.adb | 20 +- gcc/ada/sem_util.adb | 1159 +++++++++++++++++++++------------------ gcc/ada/sem_util.ads | 36 +- gcc/ada/snames.ads-tmpl | 1 + 18 files changed, 994 insertions(+), 1312 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b7c6110be42..6d20fbbb2e5 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Eval_Fat; use Eval_Fat; with Exp_Ch11; use Exp_Ch11; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch4; use Exp_Ch4; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; @@ -602,19 +601,16 @@ package body Checks is return; -- Only apply the run-time check if the access parameter has an - -- associated extra access level parameter and when the level of the - -- type is less deep than the level of the access parameter, and - -- accessibility checks are not suppressed. + -- associated extra access level parameter and when accessibility checks + -- are enabled. elsif Present (Param_Ent) - and then Present (Extra_Accessibility (Param_Ent)) - and then UI_Gt (Object_Access_Level (N), - Deepest_Type_Access_Level (Typ)) + and then Present (Get_Accessibility (Param_Ent)) and then not Accessibility_Checks_Suppressed (Param_Ent) and then not Accessibility_Checks_Suppressed (Typ) then Param_Level := - New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); + New_Occurrence_Of (Get_Accessibility (Param_Ent), Loc); -- Use the dynamic accessibility parameter for the function's result -- when one has been created instead of statically referring to the diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index fdd4e05b847..301479d8855 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -29,7 +29,6 @@ with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; with Exp_Atag; use Exp_Atag; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index ff1029cb5f7..5c3435b75a0 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -717,98 +717,4 @@ package body Exp_Ch2 is Analyze_And_Resolve (N, T); end Expand_Renaming; - ------------------ - -- Param_Entity -- - ------------------ - - -- This would be trivial, simply a test for an identifier that was a - -- reference to a formal, if it were not for the fact that a previous call - -- to Expand_Entry_Parameter will have modified the reference to the - -- identifier. A formal of a protected entity is rewritten as - - -- typ!(recobj).rec.all'Constrained - - -- where rec is a selector whose Entry_Formal link points to the formal - - -- If the type of the entry parameter has a representation clause, then an - -- extra temp is involved (see below). - - -- For a formal of a task entity, the formal is rewritten as a local - -- renaming. - - -- In addition, a formal that is marked volatile because it is aliased - -- through an address clause is rewritten as dereference as well. - - function Param_Entity (N : Node_Id) return Entity_Id is - Renamed_Obj : Node_Id; - - begin - -- Simple reference case - - if Nkind (N) in N_Identifier | N_Expanded_Name then - if Is_Formal (Entity (N)) then - return Entity (N); - - -- Handle renamings of formal parameters and formals of tasks that - -- are rewritten as renamings. - - elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then - Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); - - if Is_Entity_Name (Renamed_Obj) - and then Is_Formal (Entity (Renamed_Obj)) - then - return Entity (Renamed_Obj); - - elsif - Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement - then - return Entity (N); - end if; - end if; - - else - if Nkind (N) = N_Explicit_Dereference then - declare - P : Node_Id := Prefix (N); - S : Node_Id; - E : Entity_Id; - Decl : Node_Id; - - begin - -- If the type of an entry parameter has a representation - -- clause, then the prefix is not a selected component, but - -- instead a reference to a temp pointing at the selected - -- component. In this case, set P to be the initial value of - -- that temp. - - if Nkind (P) = N_Identifier then - E := Entity (P); - - if Ekind (E) = E_Constant then - Decl := Parent (E); - - if Nkind (Decl) = N_Object_Declaration then - P := Expression (Decl); - end if; - end if; - end if; - - if Nkind (P) = N_Selected_Component then - S := Selector_Name (P); - - if Present (Entry_Formal (Entity (S))) then - return Entry_Formal (Entity (S)); - end if; - - elsif Nkind (Original_Node (N)) = N_Identifier then - return Param_Entity (Original_Node (N)); - end if; - end; - end if; - end if; - - return (Empty); - end Param_Entity; - end Exp_Ch2; diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads index 04487d42631..8d11dd4de1e 100644 --- a/gcc/ada/exp_ch2.ads +++ b/gcc/ada/exp_ch2.ads @@ -32,14 +32,4 @@ package Exp_Ch2 is procedure Expand_N_Identifier (N : Node_Id); procedure Expand_N_Real_Literal (N : Node_Id); - function Param_Entity (N : Node_Id) return Entity_Id; - -- Given an expression N, determines if the expression is a reference - -- to a formal (of a subprogram or entry), and if so returns the Id - -- of the corresponding formal entity, otherwise returns Empty. The - -- reason that this is in Exp_Ch2 is that it has to deal with the case - -- where the reference is to an entry formal, and has been expanded - -- already. Since Exp_Ch2 is in charge of the expansion, it is best - -- suited to knowing how to detect this case. Also handles the case - -- of references to renamings of formals. - end Exp_Ch2; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3e677e6d5a5..777e661d837 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1335,6 +1335,31 @@ package body Exp_Ch3 is return Agg; end Build_Equivalent_Record_Aggregate; + ---------------------------- + -- Init_Proc_Level_Formal -- + ---------------------------- + + function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is + Form : Entity_Id; + begin + -- Move through the formals of the initialization procedure Proc to find + -- the extra accessibility level parameter associated with the object + -- being initialized. + + Form := First_Formal (Proc); + while Present (Form) loop + if Chars (Form) = Name_uInit_Level then + return Form; + end if; + + Next_Formal (Form); + end loop; + + -- No formal was found, return Empty + + return Empty; + end Init_Proc_Level_Formal; + ------------------------------- -- Build_Initialization_Call -- ------------------------------- @@ -1772,6 +1797,24 @@ package body Exp_Ch3 is New_Copy_List (Parameter_Associations (Constructor_Ref))); end if; + -- Pass the extra accessibility level parameter associated with the + -- level of the object being initialized when required. + + -- When no entity is present for Id_Ref it may not have been fully + -- analyzed, so allow the default value of standard standard to be + -- passed ??? + + if Is_Entity_Name (Id_Ref) + and then Present (Init_Proc_Level_Formal (Proc)) + then + Append_To (Args, + Make_Parameter_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_uInit_Level), + Explicit_Actual_Parameter => + Dynamic_Accessibility_Level (Id_Ref))); + end if; + Append_To (Res, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Proc, Loc), @@ -2513,6 +2556,21 @@ package body Exp_Ch3 is New_Occurrence_Of (Standard_True, Loc))); end if; + -- Create an extra accessibility parameter to capture the level of + -- the object being initialized when its type is a limited record. + + if Is_Limited_Record (Rec_Type) then + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier + (Loc, Name_uInit_Level), + Parameter_Type => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => + Make_Integer_Literal + (Loc, Scope_Depth (Standard_Standard)))); + end if; + Set_Parameter_Specifications (Proc_Spec_Node, Parameters); Set_Specification (Body_Node, Proc_Spec_Node); Set_Declarations (Body_Node, Decls); @@ -7449,7 +7507,8 @@ package body Exp_Ch3 is if No (Expr) then Level_Expr := - Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); + 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 @@ -7459,7 +7518,7 @@ package body Exp_Ch3 is and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type then Level_Expr := Make_Integer_Literal (Loc, - Object_Access_Level (Def_Id)); + Static_Accessibility_Level (Def_Id)); -- General case @@ -8143,7 +8202,8 @@ package body Exp_Ch3 is -- It is known that the accessibility level of the access -- type is deeper than that of the pool. - if Type_Access_Level (Def_Id) > Object_Access_Level (Pool) + if Type_Access_Level (Def_Id) + > Static_Accessibility_Level (Pool) and then Is_Class_Wide_Type (Etype (Pool)) and then not Accessibility_Checks_Suppressed (Def_Id) and then not Accessibility_Checks_Suppressed (Pool) diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 954b5a24a2b..a4b7f1fa1dc 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -135,6 +135,11 @@ package Exp_Ch3 is -- type is valid only when Normalize_Scalars or Initialize_Scalars is -- active, or if N is the node for a 'Invalid_Value attribute node. + function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id; + -- Fetch the extra formal from an initalization procedure "proc" + -- corresponding to the level of the object being initialized. When none + -- is present Empty is returned. + procedure Init_Secondary_Tags (Typ : Entity_Id; Target : Node_Id; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 5af4c4cd871..da2c629896d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -31,7 +31,6 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -6867,37 +6866,27 @@ package body Exp_Ch4 is -- Apply an accessibility check if the access object has an -- associated access level and when the level of the type is -- less deep than the level of the access parameter. This - -- only occur for access parameters and stand-alone objects - -- of an anonymous access type. + -- can only occur for access parameters and stand-alone + -- objects of an anonymous access type. else - if Present (Expr_Entity) - and then - Present - (Effective_Extra_Accessibility (Expr_Entity)) - and then UI_Gt (Object_Access_Level (Lop), - Type_Access_Level (Rtyp)) - then - Param_Level := - New_Occurrence_Of - (Effective_Extra_Accessibility (Expr_Entity), Loc); + Param_Level := Dynamic_Accessibility_Level (Expr_Entity); - Type_Level := - Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); + Type_Level := + Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); - -- Return True only if the accessibility level of the - -- expression entity is not deeper than the level of - -- the tested access type. + -- Return True only if the accessibility level of the + -- expression entity is not deeper than the level of + -- the tested access type. - Rewrite (N, - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (N), - Right_Opnd => Make_Op_Le (Loc, - Left_Opnd => Param_Level, - Right_Opnd => Type_Level))); + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => Make_Op_Le (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level))); - Analyze_And_Resolve (N); - end if; + Analyze_And_Resolve (N); -- If the designated type is tagged, do tagged membership -- operation. @@ -12296,7 +12285,7 @@ package body Exp_Ch4 is and then Ekind (Operand_Type) = E_Anonymous_Access_Type and then Nkind (Operand) = N_Selected_Component and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant - and then Object_Access_Level (Operand) > + and then Static_Accessibility_Level (Operand) > Type_Access_Level (Target_Type) then Raise_Accessibility_Error; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d8f74efeebb..2f39946a2c8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -34,7 +34,6 @@ with Elists; use Elists; with Expander; use Expander; with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; @@ -1807,13 +1806,7 @@ package body Exp_Ch6 is pragma Assert (Ada_Version >= Ada_2012); - if Type_Access_Level (E_Formal) > - Object_Access_Level (Lhs) - then - Append_To (Post_Call, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - end if; + Apply_Accessibility_Check (Lhs, E_Formal, N); Append_To (Post_Call, Make_Assignment_Statement (Loc, @@ -2782,6 +2775,15 @@ package body Exp_Ch6 is -- default parameters and for extra actuals (for Extra_Formals). The -- argument is an N_Parameter_Association node. + procedure Add_Cond_Expression_Extra_Actual (Formal : Entity_Id); + -- Adds extra accessibility actuals in the case of a conditional + -- expression corresponding to Formal. + + -- Note: Conditional expressions used as actuals for anonymous access + -- formals complicate the process of propagating extra accessibility + -- actuals and must be handled in a recursive fashion since they can + -- be embedded within each other. + procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); -- Adds an extra actual to the list of extra actuals. Expr is the -- expression for the value of the actual, EF is the entity for the @@ -2869,6 +2871,219 @@ package body Exp_Ch6 is Prev := Actual_Expr; end Add_Actual_Parameter; + -------------------------------------- + -- Add_Cond_Expression_Extra_Actual -- + -------------------------------------- + + procedure Add_Cond_Expression_Extra_Actual + (Formal : Entity_Id) + is + Decl : Node_Id; + + -- Suppress warning for the final removal loop + pragma Warnings (Off, Decl); + + Lvl : Entity_Id; + Res : Entity_Id; + Temp : Node_Id; + Typ : Node_Id; + + procedure Insert_Level_Assign (Branch : Node_Id); + -- Recursivly add assignment of the level temporary on each branch + -- while moving through nested conditional expressions. + + ------------------------- + -- Insert_Level_Assign -- + ------------------------- + + procedure Insert_Level_Assign (Branch : Node_Id) is + + procedure Expand_Branch (Res_Assn : Node_Id); + -- Perform expansion or iterate further within nested + -- conditionals given the object declaration or assignment to + -- result object created during expansion which represents a + -- branch of the conditional expression. + + ------------------- + -- Expand_Branch -- + ------------------- + + procedure Expand_Branch (Res_Assn : Node_Id) is + begin + pragma Assert (Nkind (Res_Assn) in + N_Assignment_Statement | + N_Object_Declaration); + + -- There are more nested conditional expressions so we must go + -- deeper. + + if Nkind (Expression (Res_Assn)) = + N_Expression_With_Actions + and then + Nkind + (Original_Node (Expression (Res_Assn))) + in N_Case_Expression | N_If_Expression + then + Insert_Level_Assign + (Expression (Res_Assn)); + + -- Add the level assignment + + else + Insert_Before_And_Analyze (Res_Assn, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Lvl, Loc), + Expression => + Dynamic_Accessibility_Level + (Expression (Res_Assn)))); + end if; + end Expand_Branch; + + Cond : Node_Id; + Alt : Node_Id; + + -- Start of processing for Insert_Level_Assign + + begin + -- Examine further nested condtionals + + pragma Assert (Nkind (Branch) = + N_Expression_With_Actions); + + -- Find the relevant statement in the actions + + Cond := First (Actions (Branch)); + while Present (Cond) loop + exit when Nkind (Cond) in + N_Case_Statement | N_If_Statement; + + Next (Cond); + end loop; + + -- The conditional expression may have been optimized away, so + -- examine the actions in the branch. + + if No (Cond) then + Expand_Branch (Last (Actions (Branch))); + + -- Iterate through if expression branches + + elsif Nkind (Cond) = N_If_Statement then + Expand_Branch (Last (Then_Statements (Cond))); + Expand_Branch (Last (Else_Statements (Cond))); + + -- Iterate through case alternatives + + elsif Nkind (Cond) = N_Case_Statement then + + Alt := First (Alternatives (Cond)); + while Present (Alt) loop + Expand_Branch (Last (Statements (Alt))); + + Next (Alt); + end loop; + end if; + end Insert_Level_Assign; + + -- Start of processing for cond expression case + + begin + -- Create declaration of a temporary to store the accessibility + -- level of each branch of the conditional expression. + + Lvl := Make_Temporary (Loc, 'L'); + Decl := Make_Object_Declaration (Loc, + Defining_Identifier => Lvl, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc)); + + -- Install the declaration and perform necessary expansion if we + -- are dealing with a function call. + + if Nkind (Call_Node) = N_Procedure_Call_Statement then + -- Generate: + -- Lvl : Natural; + -- Call ( + -- {do + -- If_Exp_Res : Typ; + -- if Cond then + -- Lvl := 0; -- Access level + -- If_Exp_Res := Exp; + -- ... + -- in If_Exp_Res end;}, + -- Lvl, + -- ... + -- ) + + Insert_Before_And_Analyze (Call_Node, Decl); + + -- A function call must be transformed into an expression with + -- actions. + + else + -- Generate: + -- do + -- Lvl : Natural; + -- in Call (do{ + -- If_Exp_Res : Typ + -- if Cond then + -- Lvl := 0; -- Access level + -- If_Exp_Res := Exp; + -- in If_Exp_Res end;}, + -- Lvl, + -- ... + -- ) + -- end; + + Res := Make_Temporary (Loc, 'R'); + Typ := Etype (Call_Node); + Temp := Relocate_Node (Call_Node); + + -- Perform the rewrite with the dummy + + Rewrite (Call_Node, + + Make_Expression_With_Actions (Loc, + Expression => New_Occurrence_Of (Res, Loc), + Actions => New_List ( + Decl, + + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => + New_Occurrence_Of (Typ, Loc))))); + + -- Analyze the expression with the dummy + + Analyze_And_Resolve (Call_Node, Typ); + + -- Properly set the expression and move our view of the call node + + Set_Expression (Call_Node, Relocate_Node (Temp)); + Call_Node := Expression (Call_Node); + + -- Remove the declaration of the dummy and the subsequent actions + -- its analysis has created. + + while Present (Remove_Next (Decl)) loop + null; + end loop; + end if; + + -- Decorate the conditional expression with assignments to our level + -- temporary. + + Insert_Level_Assign (Prev); + + -- Make our level temporary the passed actual + + Add_Extra_Actual + (Expr => New_Occurrence_Of (Lvl, Loc), + EF => Extra_Accessibility (Formal)); + end Add_Cond_Expression_Extra_Actual; + ---------------------- -- Add_Extra_Actual -- ---------------------- @@ -3300,7 +3515,6 @@ package body Exp_Ch6 is Param_Count : Positive; Parent_Formal : Entity_Id; Parent_Subp : Entity_Id; - Prev_Ult : Node_Id; Scop : Entity_Id; Subp : Entity_Id; @@ -3751,417 +3965,20 @@ package body Exp_Ch6 is EF => Extra_Accessibility (Formal)); end; - elsif Is_Entity_Name (Prev_Orig) then - - -- When passing an access parameter, or a renaming of an access - -- parameter, as the actual to another access parameter we need - -- to pass along the actual's own access level parameter. This - -- is done if we are within the scope of the formal access - -- parameter (if this is an inlined body the extra formal is - -- irrelevant). - - if (Is_Formal (Entity (Prev_Orig)) - or else - (Present (Renamed_Object (Entity (Prev_Orig))) - and then - Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) - and then - Is_Formal - (Entity (Renamed_Object (Entity (Prev_Orig)))))) - and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type - and then In_Open_Scopes (Scope (Entity (Prev_Orig))) - then - declare - Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); - - begin - pragma Assert (Present (Parm_Ent)); - - if Present (Get_Accessibility (Parm_Ent)) then - Add_Extra_Actual - (Expr => - New_Occurrence_Of - (Get_Accessibility (Parm_Ent), Loc), - EF => Extra_Accessibility (Formal)); - - -- If the actual access parameter does not have an - -- associated extra formal providing its scope level, - -- then treat the actual as having library-level - -- accessibility. - - else - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - EF => Extra_Accessibility (Formal)); - end if; - end; - - -- The actual is a normal access value, so just pass the level - -- of the actual's access type. - - else - Add_Extra_Actual - (Expr => Dynamic_Accessibility_Level (Prev_Orig), - EF => Extra_Accessibility (Formal)); - end if; - - -- If the actual is an access discriminant, then pass the level - -- of the enclosing object (RM05-3.10.2(12.4/2)). + -- Conditional expressions - elsif Nkind (Prev_Orig) = N_Selected_Component - and then Ekind (Entity (Selector_Name (Prev_Orig))) = - E_Discriminant - and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = - E_Anonymous_Access_Type + elsif Nkind (Prev) = N_Expression_With_Actions + and then Nkind (Original_Node (Prev)) in + N_If_Expression | N_Case_Expression then - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Object_Access_Level (Prefix (Prev_Orig))), - EF => Extra_Accessibility (Formal)); + Add_Cond_Expression_Extra_Actual (Formal); - -- All other cases + -- Normal case else - case Nkind (Prev_Orig) is - when N_Attribute_Reference => - case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is - -- Ignore 'Result, 'Loop_Entry, and 'Old as they can - -- be used to identify access objects and do not have - -- an effect on accessibility level. - - when Attribute_Loop_Entry - | Attribute_Old - | Attribute_Result - => - null; - - -- For X'Access, pass on the level of the prefix X - - when Attribute_Access => - - -- Accessibility level of S'Access is that of A - - Prev_Orig := Prefix (Prev_Orig); - - -- If the expression is a view conversion, the - -- accessibility level is that of the expression. - - if Nkind (Original_Node (Prev_Orig)) = - N_Type_Conversion - and then - Nkind (Expression (Original_Node (Prev_Orig))) = - N_Explicit_Dereference - then - Prev_Orig := - Expression (Original_Node (Prev_Orig)); - end if; - - -- Obtain the ultimate prefix so we can check for - -- the case where we are taking 'Access of a - -- component of an anonymous access formal - which - -- would mean we need to pass said formal's - -- corresponding extra accessibility formal. - - Prev_Ult := Ultimate_Prefix (Prev_Orig); - - if Is_Entity_Name (Prev_Ult) - and then not Is_Type (Entity (Prev_Ult)) - and then Present - (Get_Accessibility - (Entity (Prev_Ult))) - then - Add_Extra_Actual - (Expr => - New_Occurrence_Of - (Get_Accessibility - (Entity (Prev_Ult)), Loc), - EF => Extra_Accessibility (Formal)); - - -- Normal case, call Object_Access_Level. Note: - -- should be Dynamic_Accessibility_Level ??? - - else - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => - Object_Access_Level (Prev_Orig)), - EF => Extra_Accessibility (Formal)); - end if; - - -- Treat the unchecked attributes as library-level - - when Attribute_Unchecked_Access - | Attribute_Unrestricted_Access - => - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - EF => Extra_Accessibility (Formal)); - - -- No other cases of attributes returning access - -- values that can be passed to access parameters. - - when others => - raise Program_Error; - - end case; - - -- For allocators we pass the level of the execution of the - -- called subprogram, which is one greater than the current - -- scope level. However, according to RM 3.10.2(14/3) this - -- is wrong since for an anonymous allocator defining the - -- value of an access parameter, the accessibility level is - -- that of the innermost master of the call??? - - when N_Allocator => - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Current_Scope) + 1), - EF => Extra_Accessibility (Formal)); - - -- For most other cases we simply pass the level of the - -- actual's access type. The type is retrieved from - -- Prev rather than Prev_Orig, because in some cases - -- Prev_Orig denotes an original expression that has - -- not been analyzed. - - -- However, when the actual is wrapped in a conditional - -- expression we must add a local temporary to store the - -- level at each branch, and, possibly, expand the call - -- into an expression with actions. - - when others => - if Nkind (Prev) = N_Expression_With_Actions - and then Nkind (Original_Node (Prev)) in - N_If_Expression | N_Case_Expression - then - declare - Decl : Node_Id; - pragma Warnings (Off, Decl); - -- Suppress warning for the final removal loop - Lvl : Entity_Id; - Res : Entity_Id; - Temp : Node_Id; - Typ : Node_Id; - - procedure Insert_Level_Assign (Branch : Node_Id); - -- Recursivly add assignment of the level temporary - -- on each branch while moving through nested - -- conditional expressions. - - ------------------------- - -- Insert_Level_Assign -- - ------------------------- - - procedure Insert_Level_Assign (Branch : Node_Id) is - - procedure Expand_Branch (Res_Assn : Node_Id); - -- Perform expansion or iterate further within - -- nested conditionals given the object - -- declaration or assignment to result object - -- created during expansion which represents - -- a branch of the conditional expression. - - ------------------- - -- Expand_Branch -- - ------------------- - - procedure Expand_Branch (Res_Assn : Node_Id) is - begin - pragma Assert (Nkind (Res_Assn) in - N_Assignment_Statement | - N_Object_Declaration); - - -- There are more nested conditional - -- expressions so we must go deeper. - - if Nkind (Expression (Res_Assn)) = - N_Expression_With_Actions - and then - Nkind - (Original_Node (Expression (Res_Assn))) - in N_Case_Expression | N_If_Expression - then - Insert_Level_Assign - (Expression (Res_Assn)); - - -- Add the level assignment - - else - Insert_Before_And_Analyze (Res_Assn, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Lvl, Loc), - Expression => - Dynamic_Accessibility_Level - (Expression (Res_Assn)))); - end if; - end Expand_Branch; - - Cond : Node_Id; - Alt : Node_Id; - - -- Start of processing for Insert_Level_Assign - - begin - -- Examine further nested condtionals - - pragma Assert (Nkind (Branch) = - N_Expression_With_Actions); - - -- Find the relevant statement in the actions - - Cond := First (Actions (Branch)); - while Present (Cond) loop - exit when Nkind (Cond) in - N_Case_Statement | N_If_Statement; - - Next (Cond); - end loop; - - -- The conditional expression may have been - -- optimized away, so examine the actions in - -- the branch. - - if No (Cond) then - Expand_Branch (Last (Actions (Branch))); - - -- Iterate through if expression branches - - elsif Nkind (Cond) = N_If_Statement then - Expand_Branch (Last (Then_Statements (Cond))); - Expand_Branch (Last (Else_Statements (Cond))); - - -- Iterate through case alternatives - - elsif Nkind (Cond) = N_Case_Statement then - - Alt := First (Alternatives (Cond)); - while Present (Alt) loop - Expand_Branch (Last (Statements (Alt))); - - Next (Alt); - end loop; - end if; - end Insert_Level_Assign; - - -- Start of processing for cond expression case - - begin - -- Create declaration of a temporary to store the - -- accessibility level of each branch of the - -- conditional expression. - - Lvl := Make_Temporary (Loc, 'L'); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Lvl, - Object_Definition => - New_Occurrence_Of (Standard_Natural, Loc)); - - -- Install the declaration and perform necessary - -- expansion if we are dealing with a function - -- call. - - if Nkind (Call_Node) = N_Procedure_Call_Statement - then - -- Generate: - -- Lvl : Natural; - -- Call ( - -- {do - -- If_Exp_Res : Typ; - -- if Cond then - -- Lvl := 0; -- Access level - -- If_Exp_Res := Exp; - -- ... - -- in If_Exp_Res end;}, - -- Lvl, - -- ... - -- ) - - Insert_Before_And_Analyze (Call_Node, Decl); - - -- A function call must be transformed into an - -- expression with actions. - - else - -- Generate: - -- do - -- Lvl : Natural; - -- in Call (do{ - -- If_Exp_Res : Typ - -- if Cond then - -- Lvl := 0; -- Access level - -- If_Exp_Res := Exp; - -- in If_Exp_Res end;}, - -- Lvl, - -- ... - -- ) - -- end; - - Res := Make_Temporary (Loc, 'R'); - Typ := Etype (Call_Node); - Temp := Relocate_Node (Call_Node); - - -- Perform the rewrite with the dummy - - Rewrite (Call_Node, - - Make_Expression_With_Actions (Loc, - Expression => New_Occurrence_Of (Res, Loc), - Actions => New_List ( - Decl, - - Make_Object_Declaration (Loc, - Defining_Identifier => Res, - Object_Definition => - New_Occurrence_Of (Typ, Loc))))); - - -- Analyze the expression with the dummy - - Analyze_And_Resolve (Call_Node, Typ); - - -- Properly set the expression and move our view - -- of the call node - - Set_Expression (Call_Node, Relocate_Node (Temp)); - Call_Node := Expression (Call_Node); - - -- Remove the declaration of the dummy and the - -- subsequent actions its analysis has created. - - while Present (Remove_Next (Decl)) loop - null; - end loop; - end if; - - -- Decorate the conditional expression with - -- assignments to our level temporary. - - Insert_Level_Assign (Prev); - - -- Make our level temporary the passed actual - - Add_Extra_Actual - (Expr => New_Occurrence_Of (Lvl, Loc), - EF => Extra_Accessibility (Formal)); - end; - - -- General case uncomplicated by conditional expressions - - else - Add_Extra_Actual - (Expr => Dynamic_Accessibility_Level (Prev), - EF => Extra_Accessibility (Formal)); - end if; - end case; + Add_Extra_Actual + (Expr => Dynamic_Accessibility_Level (Prev), + EF => Extra_Accessibility (Formal)); end if; end if; @@ -4447,7 +4264,7 @@ package body Exp_Ch6 is else Level := Make_Integer_Literal (Loc, - Intval => Object_Access_Level (Def_Id)); + Intval => Static_Accessibility_Level (Def_Id)); end if; end; @@ -7838,190 +7655,8 @@ package body Exp_Ch6 is if Is_Special_Aliased_Formal_Access (Exp, Scope_Id) then Check_Against_Result_Level (Make_Integer_Literal (Loc, - Object_Access_Level (Entity (Ultimate_Prefix (Prefix (Exp)))))); - end if; - - -- AI05-0234: Check unconstrained access discriminants to ensure - -- that the result does not outlive an object designated by one - -- of its discriminants (RM 6.5(21/3)). - - if Present (Extra_Accessibility_Of_Result (Scope_Id)) - and then Has_Unconstrained_Access_Discriminants (R_Type) - then - declare - Discrim_Source : Node_Id; - begin - Discrim_Source := Exp; - while Nkind (Discrim_Source) = N_Qualified_Expression loop - Discrim_Source := Expression (Discrim_Source); - end loop; - - if Nkind (Discrim_Source) = N_Identifier - and then Is_Return_Object (Entity (Discrim_Source)) - then - Discrim_Source := Entity (Discrim_Source); - - if Is_Constrained (Etype (Discrim_Source)) then - Discrim_Source := Etype (Discrim_Source); - else - Discrim_Source := Expression (Parent (Discrim_Source)); - end if; - - elsif Nkind (Discrim_Source) = N_Identifier - and then Nkind (Original_Node (Discrim_Source)) in - N_Aggregate | N_Extension_Aggregate - then - Discrim_Source := Original_Node (Discrim_Source); - - elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then - Nkind (Original_Node (Discrim_Source)) = N_Function_Call - then - Discrim_Source := Original_Node (Discrim_Source); - end if; - - Discrim_Source := Unqual_Conv (Discrim_Source); - - case Nkind (Discrim_Source) is - when N_Defining_Identifier => - pragma Assert (Is_Composite_Type (Discrim_Source) - and then Has_Discriminants (Discrim_Source) - and then Is_Constrained (Discrim_Source)); - - declare - Discrim : Entity_Id := - First_Discriminant (Base_Type (R_Type)); - Disc_Elmt : Elmt_Id := - First_Elmt (Discriminant_Constraint - (Discrim_Source)); - begin - loop - if Ekind (Etype (Discrim)) = - E_Anonymous_Access_Type - then - Check_Against_Result_Level - (Dynamic_Accessibility_Level (Node (Disc_Elmt))); - end if; - - Next_Elmt (Disc_Elmt); - Next_Discriminant (Discrim); - exit when not Present (Discrim); - end loop; - end; - - when N_Aggregate - | N_Extension_Aggregate - => - -- Unimplemented: extension aggregate case where discrims - -- come from ancestor part, not extension part. - - declare - Discrim : Entity_Id := - First_Discriminant (Base_Type (R_Type)); - - Disc_Exp : Node_Id := Empty; - - Positionals_Exhausted - : Boolean := not Present (Expressions - (Discrim_Source)); - - function Associated_Expr - (Comp_Id : Entity_Id; - Associations : List_Id) return Node_Id; - - -- Given a component and a component associations list, - -- locate the expression for that component; returns - -- Empty if no such expression is found. - - --------------------- - -- Associated_Expr -- - --------------------- - - function Associated_Expr - (Comp_Id : Entity_Id; - Associations : List_Id) return Node_Id - is - Assoc : Node_Id; - Choice : Node_Id; - - begin - -- Simple linear search seems ok here - - Assoc := First (Associations); - while Present (Assoc) loop - Choice := First (Choices (Assoc)); - while Present (Choice) loop - if (Nkind (Choice) = N_Identifier - and then Chars (Choice) = Chars (Comp_Id)) - or else (Nkind (Choice) = N_Others_Choice) - then - return Expression (Assoc); - end if; - - Next (Choice); - end loop; - - Next (Assoc); - end loop; - - return Empty; - end Associated_Expr; - - begin - if not Positionals_Exhausted then - Disc_Exp := First (Expressions (Discrim_Source)); - end if; - - loop - if Positionals_Exhausted then - Disc_Exp := - Associated_Expr - (Discrim, - Component_Associations (Discrim_Source)); - end if; - - if Ekind (Etype (Discrim)) = - E_Anonymous_Access_Type - then - Check_Against_Result_Level - (Dynamic_Accessibility_Level (Disc_Exp)); - end if; - - Next_Discriminant (Discrim); - exit when not Present (Discrim); - - if not Positionals_Exhausted then - Next (Disc_Exp); - Positionals_Exhausted := not Present (Disc_Exp); - end if; - end loop; - end; - - when N_Function_Call => - - -- No check needed (check performed by callee) - - null; - - when others => - declare - Level : constant Node_Id := - Make_Integer_Literal (Loc, - Object_Access_Level (Discrim_Source)); - - begin - -- Unimplemented: check for name prefix that includes - -- a dereference of an access value with a dynamic - -- accessibility level (e.g., an access param or a - -- saooaaat) and use dynamic level in that case. For - -- example: - -- return Access_Param.all(Some_Index).Some_Component; - -- ??? - - Set_Etype (Level, Standard_Natural); - Check_Against_Result_Level (Level); - end; - end case; - end; + Static_Accessibility_Level + (Entity (Ultimate_Prefix (Prefix (Exp)))))); end if; -- If we are returning a nonscalar object that is possibly unaligned, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 866044f440e..2b05d8acff8 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -32,7 +32,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index adaa3e2a826..017a0a1abf8 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -2810,7 +2810,7 @@ package body Ch3 is -- end if; Set_Subtype_Indication (CompDef_Node, Empty); - Set_Aliased_Present (CompDef_Node, False); + Set_Aliased_Present (CompDef_Node, Aliased_Present); Set_Access_Definition (CompDef_Node, P_Access_Definition (Not_Null_Present)); else diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 9e7699f4d32..db34caef7de 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11280,7 +11280,8 @@ package body Sem_Attr is and then not Is_Special_Aliased_Formal_Access (N, Current_Scope) and then - Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) + Static_Accessibility_Level (P) > + Deepest_Type_Access_Level (Btyp) then -- In an instance, this is a runtime check, but one we know -- will fail, so generate an appropriate warning. As usual, @@ -11424,7 +11425,8 @@ package body Sem_Attr is if Attr_Id /= Attribute_Unchecked_Access and then Ekind (Btyp) = E_General_Access_Type and then - Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) + Static_Accessibility_Level (P) + > Deepest_Type_Access_Level (Btyp) then Accessibility_Message; return; @@ -11445,7 +11447,8 @@ package body Sem_Attr is -- anonymous_access_to_protected, there are no accessibility -- checks either. Omit check entirely for Unrestricted_Access. - elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) + elsif Static_Accessibility_Level (P) + > Deepest_Type_Access_Level (Btyp) and then Comes_From_Source (N) and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Attr_Id /= Attribute_Unrestricted_Access diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 564aafadfa3..fbddfc9aaa0 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7208,7 +7208,9 @@ package body Sem_Ch13 is -- check (B) - if Type_Access_Level (Ent) > Object_Access_Level (Pool) then + if Type_Access_Level (Ent) + > Static_Accessibility_Level (Pool) + then Error_Msg_N ("subpool access type has deeper accessibility " & "level than pool", Ent); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 9c42075edd4..7d8156f45df 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -965,7 +965,7 @@ package body Sem_Ch6 is -- special logic above, and call Object_Access_Level with -- the original expression. - elsif Object_Access_Level (Expr) > + elsif Static_Accessibility_Level (Expr) > Scope_Depth (Scope (Scope_Id)) then Error_Msg_N @@ -1436,7 +1436,7 @@ package body Sem_Ch6 is if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) and then Is_Limited_View (Etype (Scope_Id)) - and then Object_Access_Level (Expr) > + and then Static_Accessibility_Level (Expr) > Subprogram_Access_Level (Scope_Id) then -- Suppress the message in a generic, where the rewriting @@ -4718,7 +4718,7 @@ package body Sem_Ch6 is Attribute_Name => Name_Min, Expressions => New_List ( Make_Integer_Literal (Loc, - Object_Access_Level (Form)), + Scope_Depth (Current_Scope)), New_Occurrence_Of (Extra_Accessibility (Form), Loc)))); begin diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index bf266e08ca0..8f0ac17b6a8 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2360,7 +2360,7 @@ package body Sem_Ch9 is -- entry body) unless it is a parameter of the innermost enclosing -- accept statement (or entry body). - if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) + if Static_Accessibility_Level (Target_Obj) >= Scope_Depth (Outer_Ent) and then (not Is_Entity_Name (Target_Obj) or else not Is_Formal (Entity (Target_Obj)) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 47c743d01ef..3084012b444 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3499,16 +3499,16 @@ package body Sem_Res is elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then if Nkind (Parent (N)) = N_Type_Conversion - and then Type_Access_Level (Etype (Parent (N))) < - Object_Access_Level (A) + and then Type_Access_Level (Etype (Parent (N))) + < Static_Accessibility_Level (A) then Error_Msg_N ("aliased actual has wrong accessibility", A); end if; elsif Nkind (Parent (N)) = N_Qualified_Expression and then Nkind (Parent (Parent (N))) = N_Allocator - and then Type_Access_Level (Etype (Parent (Parent (N)))) < - Object_Access_Level (A) + and then Type_Access_Level (Etype (Parent (Parent (N)))) + < Static_Accessibility_Level (A) then Error_Msg_N ("aliased actual in allocator has wrong accessibility", A); @@ -5049,7 +5049,7 @@ package body Sem_Res is elsif Nkind (Disc_Exp) = N_Attribute_Reference and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) = Attribute_Access - and then Object_Access_Level (Prefix (Disc_Exp)) > + and then Static_Accessibility_Level (Prefix (Disc_Exp)) > Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N @@ -5061,7 +5061,7 @@ package body Sem_Res is elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type and then Nkind (Disc_Exp) = N_Selected_Component - and then Object_Access_Level (Prefix (Disc_Exp)) > + and then Static_Accessibility_Level (Prefix (Disc_Exp)) > Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N @@ -13343,8 +13343,8 @@ package body Sem_Res is -- checking the prefix of the operand for this case). if Nkind (Operand) = N_Selected_Component - and then Object_Access_Level (Operand) > - Deepest_Type_Access_Level (Target_Type) + and then Static_Accessibility_Level (Operand) + > Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -13550,8 +13550,8 @@ package body Sem_Res is -- checking the prefix of the operand for this case). if Nkind (Operand) = N_Selected_Component - and then Object_Access_Level (Operand) > - Deepest_Type_Access_Level (Target_Type) + and then Static_Accessibility_Level (Operand) + > Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9930eb6658e..1115dfc2b05 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -32,6 +32,7 @@ with Debug; use Debug; with Elists; use Elists; with Errout; use Errout; with Erroutc; use Erroutc; +with Exp_Ch3; use Exp_Ch3; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -96,6 +97,11 @@ package body Sem_Util is -- Local Subprograms -- ----------------------- + function Accessibility_Level_Helper + (Expr : Node_Id; + Static : Boolean := False) return Node_Id; + -- Unified static and dynamic accessibility level calculation subroutine + function Build_Component_Subtype (C : List_Id; Loc : Source_Ptr; @@ -265,6 +271,503 @@ package body Sem_Util is return Interface_List (Nod); end Abstract_Interface_List; + -------------------------------- + -- Accessibility_Level_Helper -- + -------------------------------- + + function Accessibility_Level_Helper + (Expr : Node_Id; + Static : Boolean := False) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + + function Make_Level_Literal (Level : Uint) return Node_Id; + -- Construct an integer literal representing an accessibility level + -- with its type set to Natural. + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint; + -- Returns the scope depth of the given node's innermost + -- enclosing dynamic scope (effectively the accessibility + -- level of the innermost enclosing master). + + function Subprogram_Call_Level (Call_Ent : Entity_Id) return Node_Id; + -- Centeralized processing of subprogram calls which may appear in + -- prefix notation. + + ---------------------------------- + -- Innermost_Master_Scope_Depth -- + ---------------------------------- + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint + is + Encl_Scop : Entity_Id; + Node_Par : Node_Id := Parent (N); + + begin + -- Locate the nearest enclosing node (by traversing Parents) + -- that Defining_Entity can be applied to, and return the + -- depth of that entity's nearest enclosing dynamic scope. + + -- The rules which define what a master are are defined in + -- RM 7.6.1 (3), and include statements and conditions for loops + -- among other things. These cases are detected properly ??? + + while Present (Node_Par) loop + if Present (Defining_Entity + (Node_Par, Empty_On_Errors => True)) + then + Encl_Scop := Nearest_Dynamic_Scope + (Defining_Entity (Node_Par)); + + -- Ignore transient scopes made during expansion + + if Comes_From_Source (Encl_Scop) then + return Scope_Depth (Encl_Scop); + end if; + + -- For a return statement within a function, return + -- the depth of the function itself. This is not just + -- a small optimization, but matters when analyzing + -- the expression in an expression function before + -- the body is created. + + elsif Nkind (Node_Par) in N_Extended_Return_Statement + | N_Simple_Return_Statement + and then Ekind (Current_Scope) = E_Function + then + return Scope_Depth (Current_Scope); + end if; + + Node_Par := Parent (Node_Par); + end loop; + + pragma Assert (False); + + -- Should never reach the following return + + return Scope_Depth (Current_Scope) + 1; + end Innermost_Master_Scope_Depth; + + ------------------------ + -- Make_Level_Literal -- + ------------------------ + + function Make_Level_Literal (Level : Uint) return Node_Id is + Result : constant Node_Id := Make_Integer_Literal (Loc, Level); + + begin + Set_Etype (Result, Standard_Natural); + return Result; + end Make_Level_Literal; + + --------------------------- + -- Subprogram_Call_Level -- + --------------------------- + + function Subprogram_Call_Level (Call_Ent : Entity_Id) return Node_Id is + begin + -- Results of functions are objects, so we either get the + -- accessibility of the function or, in case of a call which is + -- indirect, the level of the access to subprogram type. + + -- This code looks wrong ??? + + if Ada_Version < Ada_2005 then + if Is_Entity_Name (Name (Call_Ent)) then + return Make_Level_Literal + (Subprogram_Access_Level (Entity (Name (Call_Ent)))); + else + return Make_Level_Literal + (Type_Access_Level (Etype (Prefix (Name (Call_Ent))))); + end if; + end if; + + -- Named access types have a designated level + + if Is_Named_Access_Type (Etype (Call_Ent)) then + return Make_Level_Literal (Type_Access_Level (Etype (Call_Ent))); + + -- Otherwise, the level is that of the innermost master of the call, + -- according to RM 3.10.2 (10.6/2). + + -- Note: Expr is used here instead of Call_Ent since expansion may + -- have taken place, and we need to ensure we can climb the parent + -- chain. + + else + return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); + end if; + end Subprogram_Call_Level; + + -- Local variables + + E : Entity_Id := Original_Node (Expr); + Par : Node_Id; + Pre : Node_Id; + + -- Start of processing for Accessibility_Level_Helper + + begin + -- We could be looking at a reference to a formal due to the expansion + -- of entries and other cases, so obtain the renaming if necessary. + + if Present (Param_Entity (Expr)) then + E := Param_Entity (Expr); + end if; + + -- Extract the entity + + if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then + E := Entity (E); + + -- Deal with a possible renaming of a private protected component + + if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then + E := Prival_Link (E); + end if; + end if; + + -- Perform the processing on the expression + + case Nkind (E) is + -- The level of an aggregate is that of the innermost master that + -- evaluates it as defined in RM 3.10.2 (10/4). + + when N_Aggregate => + return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); + + -- The accessibility level is that of the access type, except for an + -- anonymous allocators which have special rules defined in RM 3.10.2 + -- (14/3). + + when N_Allocator => + -- Anonymous allocator + + if Ekind (Etype (Expr)) = E_Anonymous_Access_Type then + -- Hop up to find a relevant parent node + + Par := Parent (Expr); + while Present (Par) loop + exit when Nkind (Par) in N_Assignment_Statement + | N_Object_Declaration + | N_Subprogram_Call; + Par := Parent (Par); + end loop; + + -- Handle each of the static cases outlined in RM 3.10.2 (14) + + case Nkind (Par) is + -- For an anonymous allocator whose type is that of a + -- stand-alone object of an anonymous access-to-object + -- type, the accessibility level is that of the + -- declaration of the stand-alone object. + + when N_Object_Declaration => + return Make_Level_Literal + (Scope_Depth + (Scope (Defining_Identifier (Parent (Expr))))); + + -- In an assignment statement the level is that of the + -- object at the left-hand side. + + when N_Assignment_Statement => + return Make_Level_Literal + (Scope_Depth + (Scope (Entity (Name (Parent (Expr)))))); + + -- Subprogram calls have a level one deeper than the + -- nearest enclosing scope. + + when N_Subprogram_Call => + return Make_Level_Literal + (Innermost_Master_Scope_Depth + (Parent (Expr)) + 1); + + -- Should never get here + + when others => + declare + S : constant String := + Node_Kind'Image (Nkind (Parent (Expr))); + begin + Error_Msg_Strlen := S'Length; + Error_Msg_String (1 .. Error_Msg_Strlen) := S; + Error_Msg_N + ("unsupported context for anonymous allocator (~)", + Parent (Expr)); + end; + + -- Return standard in case of error + + return Make_Level_Literal + (Scope_Depth (Standard_Standard)); + end case; + + -- Normal case of a named access type + + else + return Make_Level_Literal + (Type_Access_Level (Etype (Expr))); + end if; + + -- We could reach this point for two reasons. Either the expression + -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or + -- we are looking at the access attributes directly ('Access, + -- 'Address, or 'Unchecked_Access). + + when N_Attribute_Reference => + Pre := Original_Node (Prefix (E)); + + -- Regular 'Access attribute presence means we have to look at the + -- prefix. + + if Attribute_Name (E) = Name_Access then + return Accessibility_Level_Helper (Prefix (E), Static); + + -- Unchecked or unrestricted attributes have unlimited depth + + elsif Attribute_Name (E) in Name_Address + | Name_Unchecked_Access + | Name_Unrestricted_Access + then + return Make_Level_Literal (Scope_Depth (Standard_Standard)); + + -- 'Access can be taken further against other special attributes, + -- so handle these cases explicitly. + + elsif Attribute_Name (E) + in Name_Old | Name_Loop_Entry | Name_Result + then + -- Named access types + + if Is_Named_Access_Type (Etype (Pre)) then + return Make_Level_Literal + (Type_Access_Level (Etype (Pre))); + + -- Anonymous access types + + elsif Nkind (Pre) in N_Has_Entity + and then Present (Get_Accessibility (Entity (Pre))) + and then not Static + then + return New_Occurrence_Of + (Get_Accessibility (Entity (Pre)), Loc); + + -- Otherwise the level is treated in a similar way as + -- aggregates according to RM 6.1.1 (35.1/4) which concerns + -- an implicit constant declaration - in turn defining the + -- accessibility level to be that of the implicit constant + -- declaration. + + else + return Make_Level_Literal + (Innermost_Master_Scope_Depth (Expr)); + end if; + + else + raise Program_Error; + end if; + + -- This is the "base case" for accessibility level calculations which + -- means we are near the end of our recursive traversal. + + when N_Defining_Identifier => + -- Stand-alone object of an anonymous access type "SAOAAT" + + if (Is_Formal (E) + or else Ekind (E) in E_Variable + | E_Constant) + and then Present (Get_Accessibility (E)) + and then not Static + then + return + New_Occurrence_Of (Get_Accessibility (E), Loc); + + -- Initialization procedures have a special extra accessitility + -- parameter associated with the level at which the object + -- begin initialized exists + + elsif Ekind (E) = E_Record_Type + and then Is_Limited_Record (E) + and then Current_Scope = Init_Proc (E) + and then Present (Init_Proc_Level_Formal (Current_Scope)) + then + return New_Occurrence_Of + (Init_Proc_Level_Formal (Current_Scope), Loc); + + -- Extra accessibility has not been added yet, but the formal + -- needs one. So return Standard_Standard ??? + + elsif Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Static + then + return Make_Level_Literal (Scope_Depth (Standard_Standard)); + + -- Current instance of the type is deeper than that of the type + -- according to RM 3.10.2 (21). + + elsif Is_Type (E) then + return Make_Level_Literal + (Type_Access_Level (E) + 1); + + -- Move up the renamed entity if it came from source since + -- expansion may have created a dummy renaming under certain + -- circumstances. + + elsif Present (Renamed_Object (E)) + and then Comes_From_Source (Renamed_Object (E)) + then + return Accessibility_Level_Helper + (Renamed_Object (E), Static); + + -- Named access types get their level from their associated type + + elsif Is_Named_Access_Type (Etype (E)) then + return Make_Level_Literal + (Type_Access_Level (Etype (E))); + + -- When E is a component of the current instance of a + -- protected type, we assume the level to be deeper than that of + -- the type itself. + + elsif not Is_Overloadable (E) + and then Ekind (Scope (E)) = E_Protected_Type + and then Comes_From_Source (Scope (E)) + then + return Make_Level_Literal + (Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1); + + -- Normal object - get the level of the enclosing scope + + else + return Make_Level_Literal + (Scope_Depth (Enclosing_Dynamic_Scope (E))); + end if; + + -- Handle indexed and selected components including the special cases + -- whereby there is an implicit dereference, a component of a + -- composite type, or a function call in prefix notation. + + -- We don't handle function calls in prefix notation correctly ??? + + when N_Indexed_Component | N_Selected_Component => + Pre := Original_Node (Prefix (E)); + + -- If the prefix is a named access type, then we are dealing + -- with an implicit deferences. In that case the level is that + -- of the named access type in the prefix. + + if Is_Named_Access_Type (Etype (Pre)) then + return Make_Level_Literal + (Type_Access_Level (Etype (Pre))); + + -- The current expression is a named access type, so there is no + -- reason to look at the prefix. Instead obtain the level of E's + -- named access type. + + elsif Is_Named_Access_Type (Etype (E)) then + return Make_Level_Literal + (Type_Access_Level (Etype (E))); + + -- A non-discriminant selected component where the component + -- is an anonymous access type means that its associated + -- level is that of the containing type - see RM 3.10.2 (16). + + elsif Nkind (E) = N_Selected_Component + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type + and then not (Nkind (Selector_Name (E)) in N_Has_Entity + and then Ekind (Entity (Selector_Name (E))) + = E_Discriminant) + then + return Make_Level_Literal + (Type_Access_Level (Etype (Prefix (E)))); + + -- Similar to the previous case - arrays featuring components of + -- anonymous access components get their corresponding level from + -- their containing type's declaration. + + elsif Nkind (E) = N_Indexed_Component + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Ekind (Etype (Pre)) in Array_Kind + and then Ekind (Component_Type (Base_Type (Etype (Pre)))) + = E_Anonymous_Access_Type + then + return Make_Level_Literal + (Type_Access_Level (Etype (Prefix (E)))); + + -- Otherwise, continue recursing over the expression prefixes + + else + return Accessibility_Level_Helper (Prefix (E), Static); + end if; + + -- Qualified expressions + + when N_Qualified_Expression => + if Is_Named_Access_Type (Etype (E)) then + return Make_Level_Literal + (Type_Access_Level (Etype (E))); + else + return Accessibility_Level_Helper (Expression (E), Static); + end if; + + -- Handle function calls + + when N_Function_Call => + return Subprogram_Call_Level (E); + + -- Explicit dereference accessibility level calculation + + when N_Explicit_Dereference => + Pre := Original_Node (Prefix (E)); + + -- The prefix is a named access type so the level is taken from + -- its type. + + if Is_Named_Access_Type (Etype (Pre)) then + return Make_Level_Literal (Type_Access_Level (Etype (Pre))); + + -- Otherwise, recurse deeper + + else + return Accessibility_Level_Helper (Prefix (E), Static); + end if; + + -- Type conversions + + when N_Type_Conversion | N_Unchecked_Type_Conversion => + -- View conversions are special in that they require use to + -- inspect the expression of the type conversion. + + -- Allocators of anonymous access types are internally generated, + -- so recurse deeper in that case as well. + + if Is_View_Conversion (E) + or else Ekind (Etype (E)) = E_Anonymous_Access_Type + then + return Accessibility_Level_Helper (Expression (E), Static); + + -- In section RM 3.10.2 (10/4) the accessibility rules for + -- aggregates and value conversions are outlined. Are these + -- followed in the case of initialization of an object ??? + + -- Should use Innermost_Master_Scope_Depth ??? + + else + return Accessibility_Level_Helper (Current_Scope, Static); + end if; + + -- Default to the type accessibility level for the type of the + -- expression's entity. + + when others => + return Make_Level_Literal (Type_Access_Level (Etype (E))); + end case; + end Accessibility_Level_Helper; + ---------------------------------- -- Acquire_Warning_Match_String -- ---------------------------------- @@ -4769,7 +5272,7 @@ package body Sem_Util is and then No (Cont_Encl_Typ) and then Is_Public_Operation and then Scope_Depth (Pref_Encl_Typ) >= - Object_Access_Level (Context) + Static_Accessibility_Level (Context) then Error_Msg_N ("??possible unprotected access to protected data", Expr); @@ -6243,9 +6746,9 @@ package body Sem_Util is end if; end Current_Subprogram; - ---------------------------------- + ------------------------------- -- Deepest_Type_Access_Level -- - ---------------------------------- + ------------------------------- function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is begin @@ -6276,7 +6779,10 @@ package body Sem_Util is -- Defining_Entity -- --------------------- - function Defining_Entity (N : Node_Id) return Entity_Id is + function Defining_Entity + (N : Node_Id; + Empty_On_Errors : Boolean := False) return Entity_Id + is begin case Nkind (N) is when N_Abstract_Subprogram_Declaration @@ -6375,6 +6881,10 @@ package body Sem_Util is return Entity (Identifier (N)); when others => + if Empty_On_Errors then + return Empty; + end if; + raise Program_Error; end case; end Defining_Entity; @@ -6896,197 +7406,9 @@ package body Sem_Util is -- Dynamic_Accessibility_Level -- --------------------------------- - function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (N); - - function Make_Level_Literal (Level : Uint) return Node_Id; - -- Construct an integer literal representing an accessibility level - -- with its type set to Natural. - - ------------------------ - -- Make_Level_Literal -- - ------------------------ - - function Make_Level_Literal (Level : Uint) return Node_Id is - Result : constant Node_Id := Make_Integer_Literal (Loc, Level); - - begin - Set_Etype (Result, Standard_Natural); - return Result; - end Make_Level_Literal; - - -- Local variables - - Expr : Node_Id := Original_Node (N); - -- Expr references the original node because at this stage N may be the - -- reference to a variable internally created by the frontend to remove - -- side effects of an expression. - - E : Entity_Id; - - -- Start of processing for Dynamic_Accessibility_Level - + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is begin - if Is_Entity_Name (Expr) then - E := Entity (Expr); - - if Present (Renamed_Object (E)) then - return Dynamic_Accessibility_Level (Renamed_Object (E)); - end if; - - if (Is_Formal (E) - or else Ekind (E) in E_Variable | E_Constant) - and then Present (Get_Accessibility (E)) - then - return New_Occurrence_Of (Get_Accessibility (E), Loc); - end if; - end if; - - -- Handle a constant-folded conditional expression by avoiding use of - -- the original node. - - if Nkind (Expr) in N_Case_Expression | N_If_Expression then - Expr := N; - end if; - - -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? - - case Nkind (Expr) is - -- It may be possible that we have an access object denoted by an - -- attribute reference for 'Loop_Entry which may, in turn, have an - -- indexed component representing a loop identifier. - - -- In this case we must climb up the indexed component and set expr - -- to the attribute reference so the rest of the machinery can - -- operate as expected. - - when N_Indexed_Component => - if Nkind (Prefix (Expr)) = N_Attribute_Reference - and then Get_Attribute_Id (Attribute_Name (Prefix (Expr))) - = Attribute_Loop_Entry - then - Expr := Prefix (Expr); - end if; - - -- For access discriminant, the level of the enclosing object - - when N_Selected_Component => - if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant - and then Ekind (Etype (Entity (Selector_Name (Expr)))) = - E_Anonymous_Access_Type - then - return Make_Level_Literal (Object_Access_Level (Expr)); - end if; - - when N_Attribute_Reference => - case Get_Attribute_Id (Attribute_Name (Expr)) is - - -- Ignore 'Loop_Entry, 'Result, and 'Old as they can be used to - -- identify access objects and do not have an effect on - -- accessibility level. - - when Attribute_Loop_Entry | Attribute_Old | Attribute_Result => - null; - - -- For X'Access, the level of the prefix X - - when Attribute_Access => - return Make_Level_Literal - (Object_Access_Level (Prefix (Expr))); - - -- Treat the unchecked attributes as library-level - - when Attribute_Unchecked_Access - | Attribute_Unrestricted_Access - => - return Make_Level_Literal (Scope_Depth (Standard_Standard)); - - -- No other access-valued attributes - - when others => - raise Program_Error; - end case; - - when N_Allocator => - - -- This is not fully implemented since it depends on context (see - -- 3.10.2(14/3-14.2/3). More work is needed in the following cases - -- - -- 1) For an anonymous allocator defining the value of an access - -- parameter, the accessibility level is that of the innermost - -- master of the call; however currently we pass the level of - -- execution of the called subprogram, which is one greater - -- than the current scope level (see Expand_Call_Helper). - -- - -- For example, a statement is a master and a declaration is - -- not a master; so we should not pass in the same level for - -- the following cases: - -- - -- function F (X : access Integer) return T is ... ; - -- Decl : T := F (new Integer); -- level is off by one - -- begin - -- Decl := F (new Integer); -- we get this case right - -- - -- 2) For an anonymous allocator that defines the result of a - -- function with an access result, the accessibility level is - -- determined as though the allocator were in place of the call - -- of the function. In the special case of a call that is the - -- operand of a type conversion the level is that of the target - -- access type of the conversion. - -- - -- 3) For an anonymous allocator defining an access discriminant - -- the accessibility level is determined as follows: - -- * for an allocator used to define the discriminant of an - -- object, the level of the object - -- * for an allocator used to define the constraint in a - -- subtype_indication in any other context, the level of - -- the master that elaborates the subtype_indication. - - case Nkind (Parent (N)) is - when N_Object_Declaration => - - -- For an anonymous allocator whose type is that of a - -- stand-alone object of an anonymous access-to-object type, - -- the accessibility level is that of the declaration of the - -- stand-alone object. - - return - Make_Level_Literal - (Object_Access_Level - (Defining_Identifier (Parent (N)))); - - when N_Assignment_Statement => - return - Make_Level_Literal - (Object_Access_Level (Name (Parent (N)))); - - when others => - declare - S : constant String := - Node_Kind'Image (Nkind (Parent (N))); - begin - Error_Msg_Strlen := S'Length; - Error_Msg_String (1 .. Error_Msg_Strlen) := S; - Error_Msg_N - ("unsupported context for anonymous allocator (~)", - Parent (N)); - end; - end case; - - when N_Type_Conversion => - if not Is_Local_Anonymous_Access (Etype (Expr)) then - - -- Handle type conversions introduced for a rename of an - -- Ada 2012 stand-alone object of an anonymous access type. - - return Dynamic_Accessibility_Level (Expression (Expr)); - end if; - - when others => - null; - end case; - - return Make_Level_Literal (Type_Access_Level (Etype (Expr))); + return Accessibility_Level_Helper (Expr); end Dynamic_Accessibility_Level; ------------------------ @@ -19670,7 +19992,7 @@ package body Sem_Util is function Is_View_Conversion (N : Node_Id) return Boolean is begin if Nkind (N) = N_Type_Conversion - and then Nkind (Unqual_Conv (N)) in N_Expanded_Name | N_Identifier + and then Nkind (Unqual_Conv (N)) in N_Has_Etype then if Is_Tagged_Type (Etype (N)) and then Is_Tagged_Type (Etype (Unqual_Conv (N))) @@ -24418,350 +24740,6 @@ package body Sem_Util is return Num; end Number_Of_Elements_In_Array; - ------------------------- - -- Object_Access_Level -- - ------------------------- - - -- Returns the static accessibility level of the view denoted by Obj. Note - -- that the value returned is the result of a call to Scope_Depth. Only - -- scope depths associated with dynamic scopes can actually be returned. - -- Since only relative levels matter for accessibility checking, the fact - -- that the distance between successive levels of accessibility is not - -- always one is immaterial (invariant: if level(E2) is deeper than - -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). - - function Object_Access_Level (Obj : Node_Id) return Uint is - function Is_Interface_Conversion (N : Node_Id) return Boolean; - -- Determine whether N is a construct of the form - -- Some_Type (Operand._tag'Address) - -- This construct appears in the context of dispatching calls. - - function Reference_To (Obj : Node_Id) return Node_Id; - -- An explicit dereference is created when removing side effects from - -- expressions for constraint checking purposes. In this case a local - -- access type is created for it. The correct access level is that of - -- the original source node. We detect this case by noting that the - -- prefix of the dereference is created by an object declaration whose - -- initial expression is a reference. - - ----------------------------- - -- Is_Interface_Conversion -- - ----------------------------- - - function Is_Interface_Conversion (N : Node_Id) return Boolean is - begin - return Nkind (N) = N_Unchecked_Type_Conversion - and then Nkind (Expression (N)) = N_Attribute_Reference - and then Attribute_Name (Expression (N)) = Name_Address; - end Is_Interface_Conversion; - - ------------------ - -- Reference_To -- - ------------------ - - function Reference_To (Obj : Node_Id) return Node_Id is - Pref : constant Node_Id := Prefix (Obj); - begin - if Is_Entity_Name (Pref) - and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration - and then Present (Expression (Parent (Entity (Pref)))) - and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference - then - return (Prefix (Expression (Parent (Entity (Pref))))); - else - return Empty; - end if; - end Reference_To; - - -- Local variables - - E : Entity_Id; - Orig_Obj : Node_Id := Original_Node (Obj); - Orig_Pre : Node_Id; - - -- Start of processing for Object_Access_Level - - begin - -- In the case of an expanded implicit dereference we swap the original - -- object to be the expanded conversion. - - if Nkind (Obj) = N_Explicit_Dereference - and then Nkind (Orig_Obj) /= N_Explicit_Dereference - then - Orig_Obj := Obj; - end if; - - -- Calculate the object node's accessibility level - - if Nkind (Orig_Obj) = N_Defining_Identifier - or else Is_Entity_Name (Orig_Obj) - then - if Nkind (Orig_Obj) = N_Defining_Identifier then - E := Orig_Obj; - else - E := Entity (Orig_Obj); - end if; - - if Is_Prival (E) then - E := Prival_Link (E); - end if; - - -- If E is a type then it denotes a current instance. For this case - -- we add one to the normal accessibility level of the type to ensure - -- that current instances are treated as always being deeper than - -- than the level of any visible named access type (see 3.10.2(21)). - - if Is_Type (E) then - return Type_Access_Level (E) + 1; - - elsif Present (Renamed_Object (E)) then - return Object_Access_Level (Renamed_Object (E)); - - -- Similarly, if E is a component of the current instance of a - -- protected type, any instance of it is assumed to be at a deeper - -- level than the type. For a protected object (whose type is an - -- anonymous protected type) its components are at the same level - -- as the type itself. - - elsif not Is_Overloadable (E) - and then Ekind (Scope (E)) = E_Protected_Type - and then Comes_From_Source (Scope (E)) - then - return Type_Access_Level (Scope (E)) + 1; - - -- An object of a named access type gets its level from its - -- associated type. - - elsif Is_Named_Access_Type (Etype (E)) then - return Type_Access_Level (Etype (E)); - - else - return Scope_Depth (Enclosing_Dynamic_Scope (E)); - end if; - - elsif Nkind (Orig_Obj) in N_Indexed_Component | N_Selected_Component then - Orig_Pre := Original_Node (Prefix (Orig_Obj)); - - if Is_Access_Type (Etype (Orig_Pre)) then - return Type_Access_Level (Etype (Orig_Pre)); - else - return Object_Access_Level (Prefix (Orig_Obj)); - end if; - - elsif Nkind (Orig_Obj) = N_Explicit_Dereference then - Orig_Pre := Original_Node (Prefix (Orig_Obj)); - - -- If the prefix is a selected access discriminant then we make a - -- recursive call on the prefix, which will in turn check the level - -- of the prefix object of the selected discriminant. - - -- In Ada 2012, if the discriminant has implicit dereference and - -- the context is a selected component, treat this as an object of - -- unknown scope (see below). This is necessary in compile-only mode; - -- otherwise expansion will already have transformed the prefix into - -- a temporary. - - if Nkind (Orig_Pre) = N_Selected_Component - and then Ekind (Etype (Orig_Pre)) = E_Anonymous_Access_Type - and then - Ekind (Entity (Selector_Name (Orig_Pre))) = E_Discriminant - and then - (not Has_Implicit_Dereference - (Entity (Selector_Name (Orig_Pre))) - or else Nkind (Parent (Obj)) /= N_Selected_Component) - then - return Object_Access_Level (Prefix (Orig_Obj)); - - -- Detect an interface conversion in the context of a dispatching - -- call. Use the original form of the conversion to find the access - -- level of the operand. - - elsif Is_Interface (Etype (Orig_Obj)) - and then Is_Interface_Conversion (Orig_Pre) - and then Nkind (Orig_Obj) = N_Type_Conversion - then - return Object_Access_Level (Orig_Obj); - - elsif not Comes_From_Source (Orig_Obj) then - declare - Ref : constant Node_Id := Reference_To (Orig_Obj); - begin - if Present (Ref) then - return Object_Access_Level (Ref); - else - return Type_Access_Level (Etype (Prefix (Orig_Obj))); - end if; - end; - - else - return Type_Access_Level (Etype (Prefix (Orig_Obj))); - end if; - - elsif Nkind (Orig_Obj) in N_Type_Conversion | N_Unchecked_Type_Conversion - then - return Object_Access_Level (Expression (Orig_Obj)); - - elsif Nkind (Orig_Obj) = N_Function_Call then - - -- Function results are objects, so we get either the access level of - -- the function or, in the case of an indirect call, the level of the - -- access-to-subprogram type. (This code is used for Ada 95, but it - -- looks wrong, because it seems that we should be checking the level - -- of the call itself, even for Ada 95. However, using the Ada 2005 - -- version of the code causes regressions in several tests that are - -- compiled with -gnat95. ???) - - if Ada_Version < Ada_2005 then - if Is_Entity_Name (Name (Orig_Obj)) then - return Subprogram_Access_Level (Entity (Name (Orig_Obj))); - else - return Type_Access_Level (Etype (Prefix (Name (Orig_Obj)))); - end if; - - -- For Ada 2005, the level of the result object of a function call is - -- defined to be the level of the call's innermost enclosing master. - -- We determine that by querying the depth of the innermost enclosing - -- dynamic scope. - - else - Return_Master_Scope_Depth_Of_Call : declare - function Innermost_Master_Scope_Depth - (N : Node_Id) return Uint; - -- Returns the scope depth of the given node's innermost - -- enclosing dynamic scope (effectively the accessibility - -- level of the innermost enclosing master). - - ---------------------------------- - -- Innermost_Master_Scope_Depth -- - ---------------------------------- - - function Innermost_Master_Scope_Depth - (N : Node_Id) return Uint - is - Node_Par : Node_Id := Parent (N); - - begin - -- Locate the nearest enclosing node (by traversing Parents) - -- that Defining_Entity can be applied to, and return the - -- depth of that entity's nearest enclosing dynamic scope. - - while Present (Node_Par) loop - case Nkind (Node_Par) is - when N_Abstract_Subprogram_Declaration - | N_Block_Statement - | N_Body_Stub - | N_Component_Declaration - | N_Entry_Body - | N_Entry_Declaration - | N_Exception_Declaration - | N_Formal_Object_Declaration - | N_Formal_Package_Declaration - | N_Formal_Subprogram_Declaration - | N_Formal_Type_Declaration - | N_Full_Type_Declaration - | N_Function_Specification - | N_Generic_Declaration - | N_Generic_Instantiation - | N_Implicit_Label_Declaration - | N_Incomplete_Type_Declaration - | N_Loop_Parameter_Specification - | N_Number_Declaration - | N_Object_Declaration - | N_Package_Declaration - | N_Package_Specification - | N_Parameter_Specification - | N_Private_Extension_Declaration - | N_Private_Type_Declaration - | N_Procedure_Specification - | N_Proper_Body - | N_Protected_Type_Declaration - | N_Renaming_Declaration - | N_Single_Protected_Declaration - | N_Single_Task_Declaration - | N_Subprogram_Declaration - | N_Subtype_Declaration - | N_Subunit - | N_Task_Type_Declaration - => - return Scope_Depth - (Nearest_Dynamic_Scope - (Defining_Entity (Node_Par))); - - -- For a return statement within a function, return - -- the depth of the function itself. This is not just - -- a small optimization, but matters when analyzing - -- the expression in an expression function before - -- the body is created. - - when N_Simple_Return_Statement => - if Ekind (Current_Scope) = E_Function then - return Scope_Depth (Current_Scope); - end if; - - when others => - null; - end case; - - Node_Par := Parent (Node_Par); - end loop; - - pragma Assert (False); - - -- Should never reach the following return - - return Scope_Depth (Current_Scope) + 1; - end Innermost_Master_Scope_Depth; - - -- Start of processing for Return_Master_Scope_Depth_Of_Call - - begin - -- Expanded code may have clobbered the scoping data from the - -- original object node - so use the expanded one. - - return Innermost_Master_Scope_Depth (Obj); - end Return_Master_Scope_Depth_Of_Call; - end if; - - -- For convenience we handle qualified expressions, even though they - -- aren't technically object names. - - elsif Nkind (Orig_Obj) = N_Qualified_Expression then - return Object_Access_Level (Expression (Orig_Obj)); - - -- Ditto for aggregates. They have the level of the temporary that - -- will hold their value. - - elsif Nkind (Orig_Obj) = N_Aggregate then - return Object_Access_Level (Current_Scope); - - -- Treat an Old/Loop_Entry attribute reference like an aggregate. - -- AARM 6.1.1(27.d) says "... the implicit constant declaration - -- defines the accessibility level of X'Old", so that is what - -- we are trying to implement here. - - elsif Nkind (Orig_Obj) = N_Attribute_Reference - and then Attribute_Name (Orig_Obj) in Name_Old | Name_Loop_Entry - then - return Object_Access_Level (Current_Scope); - - -- Move up the attribute reference when we encounter a 'Access variation - - elsif Nkind (Orig_Obj) = N_Attribute_Reference - and then Attribute_Name (Orig_Obj) in Name_Access - | Name_Unchecked_Access - | Name_Unrestricted_Access - then - return Object_Access_Level (Prefix (Orig_Obj)); - - -- Otherwise return the scope level of Standard. (If there are cases - -- that fall through to this point they will be treated as having - -- global accessibility for now. ???) - - else - return Scope_Depth (Standard_Standard); - end if; - end Object_Access_Level; - ---------------------------------- -- Old_Requires_Transient_Scope -- ---------------------------------- @@ -24988,6 +24966,100 @@ package body Sem_Util is Write_Eol; end Output_Name; + ------------------ + -- Param_Entity -- + ------------------ + + -- This would be trivial, simply a test for an identifier that was a + -- reference to a formal, if it were not for the fact that a previous call + -- to Expand_Entry_Parameter will have modified the reference to the + -- identifier. A formal of a protected entity is rewritten as + + -- typ!(recobj).rec.all'Constrained + + -- where rec is a selector whose Entry_Formal link points to the formal + + -- If the type of the entry parameter has a representation clause, then an + -- extra temp is involved (see below). + + -- For a formal of a task entity, the formal is rewritten as a local + -- renaming. + + -- In addition, a formal that is marked volatile because it is aliased + -- through an address clause is rewritten as dereference as well. + + function Param_Entity (N : Node_Id) return Entity_Id is + Renamed_Obj : Node_Id; + + begin + -- Simple reference case + + if Nkind (N) in N_Identifier | N_Expanded_Name then + if Is_Formal (Entity (N)) then + return Entity (N); + + -- Handle renamings of formal parameters and formals of tasks that + -- are rewritten as renamings. + + elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then + Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); + + if Is_Entity_Name (Renamed_Obj) + and then Is_Formal (Entity (Renamed_Obj)) + then + return Entity (Renamed_Obj); + + elsif + Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement + then + return Entity (N); + end if; + end if; + + else + if Nkind (N) = N_Explicit_Dereference then + declare + P : Node_Id := Prefix (N); + S : Node_Id; + E : Entity_Id; + Decl : Node_Id; + + begin + -- If the type of an entry parameter has a representation + -- clause, then the prefix is not a selected component, but + -- instead a reference to a temp pointing at the selected + -- component. In this case, set P to be the initial value of + -- that temp. + + if Nkind (P) = N_Identifier then + E := Entity (P); + + if Ekind (E) = E_Constant then + Decl := Parent (E); + + if Nkind (Decl) = N_Object_Declaration then + P := Expression (Decl); + end if; + end if; + end if; + + if Nkind (P) = N_Selected_Component then + S := Selector_Name (P); + + if Present (Entry_Formal (Entity (S))) then + return Entry_Formal (Entity (S)); + end if; + + elsif Nkind (Original_Node (N)) = N_Identifier then + return Param_Entity (Original_Node (N)); + end if; + end; + end if; + end if; + + return (Empty); + end Param_Entity; + ---------------------- -- Policy_In_Effect -- ---------------------- @@ -27147,6 +27219,15 @@ package body Sem_Util is return Result; end Should_Ignore_Pragma_Sem; + -------------------------------- + -- Static_Accessibility_Level -- + -------------------------------- + + function Static_Accessibility_Level (Expr : Node_Id) return Uint is + begin + return Intval (Accessibility_Level_Helper (Expr, Static => True)); + end Static_Accessibility_Level; + -------------------- -- Static_Boolean -- -------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9030279b215..fdc4797bf65 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -610,7 +610,9 @@ package Sem_Util is -- in the case of a descendant of a generic formal type (returns Int'Last -- instead of 0). - function Defining_Entity (N : Node_Id) return Entity_Id; + function Defining_Entity + (N : Node_Id; + Empty_On_Errors : Boolean := False) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the -- specification. If the declaration has a defining unit name, then the @@ -621,6 +623,16 @@ package Sem_Util is -- local entities declared during loop expansion. These entities need -- debugging information, generated through Qualify_Entity_Names, and -- the loop declaration must be placed in the table Name_Qualify_Units. + -- + -- Set flag Empty_On_Errors to change the behavior of this routine as + -- follows: + -- + -- * True - A declaration that lacks a defining entity returns Empty. + -- A node that does not allow for a defining entity returns Empty. + -- + -- * False - A declaration that lacks a defining entity is given a new + -- internally generated entity which is subsequently returned. A node + -- that does not allow for a defining entity raises Program_Error -- WARNING: There is a matching C declaration of this subprogram in fe.h @@ -672,11 +684,11 @@ package Sem_Util is -- private components of protected objects, but is generally useful when -- restriction No_Implicit_Heap_Allocation is active. - function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id; - -- N should be an expression of an access type. Builds an integer literal - -- except in cases involving anonymous access types, where accessibility - -- levels are tracked at run time (access parameters and Ada 2012 stand- - -- alone objects). + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id; + -- Expr should be an expression of an access type. Builds an integer + -- literal except in cases involving anonymous access types, where + -- accessibility levels are tracked at run time (access parameters and + -- stand-alone objects of anonymous access types). function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; -- Same as Einfo.Extra_Accessibility except thtat object renames @@ -2610,10 +2622,8 @@ package Sem_Util is -- is known at compile time. If the bounds are not known at compile time, -- the function returns the value zero. - function Object_Access_Level (Obj : Node_Id) return Uint; - -- Return the accessibility level of the view of the object Obj. For - -- convenience, qualified expressions applied to object names are also - -- allowed as actuals for this function. + function Static_Accessibility_Level (Expr : Node_Id) return Uint; + -- Return the numeric accessibility level of the expression Expr function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id; -- Retrieve the name of aspect or pragma N, taking into account a possible @@ -2649,6 +2659,12 @@ package Sem_Util is -- WARNING: this routine should be used in debugging scenarios such as -- tracking down undefined symbols as it is fairly low level. + function Param_Entity (N : Node_Id) return Entity_Id; + -- Given an expression N, determines if the expression is a reference + -- to a formal (of a subprogram or entry), and if so returns the Id + -- of the corresponding formal entity, otherwise returns Empty. Also + -- handles the case of references to renamings of formals. + function Policy_In_Effect (Policy : Name_Id) return Name_Id; -- Given a policy, return the policy identifier associated with it. If no -- such policy is in effect, the value returned is No_Name. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index af69d773950..7cbb99568ec 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -174,6 +174,7 @@ package Snames is Name_uFinalizer : constant Name_Id := N + $; Name_uIdepth : constant Name_Id := N + $; Name_uInit : constant Name_Id := N + $; + Name_uInit_Level : constant Name_Id := N + $; Name_uInvariant : constant Name_Id := N + $; Name_uMaster : constant Name_Id := N + $; Name_uObject : constant Name_Id := N + $; -- 2.30.2