From 66e97274cef35ed40584c7a09096fffa061fddf0 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 2 Sep 2020 14:20:55 -0400 Subject: [PATCH] [Ada] Further Ada 2020 work on accessibility checking gcc/ada/ * checks.adb (Apply_Accessibility_Check): Skip checks against the extra accessibility of a function result when in Ada 2005 mode or earlier. * exp_ch3.adb (Build_Initialization_Call): Modify accessibility level calls to use Accessibility_Level. (Expand_N_Object_Declaration): Modify accessibility level calls to use Accessibility_Level. * exp_ch4.adb (Expand_Allocator_Expression): Add static check for anonymous access discriminants. Remove unneeded propagation of accessibility actual. (Expand_N_In): Modify accessibility level calls to use Accessibility_Level. (Expand_N_Type_Conversion): Modify accessibility level calls to use Accessibility_Level. * exp_ch5.adb (Expand_N_Assignment_Statement): Modify accessibility level calls to use Accessibility_Level. * exp_ch6.adb (Expand_Call_Helper): Rewrite accessibility calculation for the extra accessibility of result actual in function calls, and modify accessibility level calls to use Accessibility_Level. (Check_Against_Result_Level): Removed. * exp_ch9.adb (Expand_N_Requeue_Statement): Add dynamic accessibility check for requeues * sem_attr.adb (Resolve_Attribute): Modify accessibility level calls to use Accessibility_Level. * sem_ch13.adb (Associate_Storage_Pool): Modify accessibility level calls to use Accessibility_Level. * sem_ch4.adb (Analyze_Call): Add static check for explicitly aliased formals in function calls within return statements. * sem_ch6.adb (Check_Return_Construct_Accessibility): Rewrite routine to account for non-aggregate return objects. (Generate_Minimum_Accessibility): Created. (Analyze_Call): Modify accessibility level calls to use Accessibility_Level. (Analyze_Subprogram_Body_Helper): Add generation of minimum accessibility for the extra accessibility of the function result. * sem_ch9.adb (Analyze_Requeue): Modify accessibility level calls to use Accessibility_Level. * sem_res.adb: (Check_Aliased_Parameters): Modify accessibility level calls to use Accessibility_Level. (Valid_Conversion): Modify accessibility level calls to use Accessibility_Level. * sem_util.adb, sem_util.ads (Accessibility_Level_Helper): Renamed to Accessibility_Level, add detection for functions in prefix notation, and add cases where to return zero when specified. Modified to take new, more descriptive, parameters. (Accessibility_Level): Created. (Function_Call_Level): Removed. (Function_Call_Or_Allocator_Level): Created to centralize the calculation accessibility levels for function calls and allocators. (Static_Accessibility_Level): Removed. (Dynamic_Accessibility_Level): Removed. (Get_Dynamic_Accessibility): Renamed from Get_Accessibility. (In_Return_Value): Created to determine if a given expression contributes to the current function's return value. (Is_Master): Created. (Is_Explicitly_Aliased): Created --- gcc/ada/checks.adb | 33 ++- gcc/ada/exp_ch3.adb | 10 +- gcc/ada/exp_ch4.adb | 67 ++--- gcc/ada/exp_ch5.adb | 5 +- gcc/ada/exp_ch6.adb | 167 +++---------- gcc/ada/exp_ch9.adb | 21 ++ gcc/ada/sem_attr.adb | 20 +- gcc/ada/sem_ch13.adb | 3 +- gcc/ada/sem_ch4.adb | 42 +++- gcc/ada/sem_ch6.adb | 441 ++++++++++++++++++++------------- gcc/ada/sem_ch9.adb | 3 +- gcc/ada/sem_res.adb | 35 ++- gcc/ada/sem_util.adb | 572 +++++++++++++++++++++++++++++-------------- gcc/ada/sem_util.ads | 77 +++++- 14 files changed, 925 insertions(+), 571 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 35527950757..b389da5accb 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -589,7 +589,6 @@ package body Checks is then Param_Ent := Entity (N); while Present (Renamed_Object (Param_Ent)) loop - -- Renamed_Object must return an Entity_Name here -- because of preceding "Present (E_E_A (...))" test. @@ -605,25 +604,41 @@ package body Checks is -- are enabled. elsif Present (Param_Ent) - and then Present (Get_Accessibility (Param_Ent)) + and then Present (Get_Dynamic_Accessibility (Param_Ent)) and then not Accessibility_Checks_Suppressed (Param_Ent) and then not Accessibility_Checks_Suppressed (Typ) then + -- Obtain the parameter's accessibility level + Param_Level := - New_Occurrence_Of (Get_Accessibility (Param_Ent), Loc); + New_Occurrence_Of (Get_Dynamic_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 -- deepest type level so as to appropriatly handle the rules for -- RM 3.10.2 (10.1/3). - if Ekind (Scope (Param_Ent)) - in E_Function | E_Operator | E_Subprogram_Type - and then Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) + if Ekind (Scope (Param_Ent)) = E_Function + and then In_Return_Value (N) + and then Ekind (Typ) = E_Anonymous_Access_Type then - Type_Level := - New_Occurrence_Of - (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); + -- Associate the level of the result type to the extra result + -- accessibility parameter belonging to the current function. + + if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then + Type_Level := + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); + + -- In Ada 2005 and earlier modes, a result extra accessibility + -- parameter is not generated and no dynamic check is performed. + + else + return; + end if; + + -- Otherwise get the type's accessibility level normally + else Type_Level := Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 777e661d837..f8b6ee68d6a 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1812,7 +1812,7 @@ package body Exp_Ch3 is Selector_Name => Make_Identifier (Loc, Name_uInit_Level), Explicit_Actual_Parameter => - Dynamic_Accessibility_Level (Id_Ref))); + Accessibility_Level (Id_Ref, Dynamic_Level))); end if; Append_To (Res, @@ -7517,13 +7517,13 @@ package body Exp_Ch3 is elsif Nkind (Expr) = N_Function_Call and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type then - Level_Expr := Make_Integer_Literal (Loc, - Static_Accessibility_Level (Def_Id)); + Level_Expr := Accessibility_Level + (Def_Id, Object_Decl_Level); -- General case else - Level_Expr := Dynamic_Accessibility_Level (Expr); + Level_Expr := Accessibility_Level (Expr, Dynamic_Level); end if; Level_Decl := @@ -8203,7 +8203,7 @@ package body Exp_Ch3 is -- type is deeper than that of the pool. if Type_Access_Level (Def_Id) - > Static_Accessibility_Level (Pool) + > Static_Accessibility_Level (Pool, Object_Decl_Level) 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_ch4.adb b/gcc/ada/exp_ch4.adb index 4d5486057aa..076e0def302 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -823,6 +823,37 @@ package body Exp_Ch4 is Apply_Predicate_Check (Exp, T); + -- Check that any anonymous access discriminants are suitable + -- for use in an allocator. + + -- Note: This check is performed here instead of during analysis so that + -- we can check against the fully resolved etype of Exp. + + if Is_Entity_Name (Exp) + and then Has_Anonymous_Access_Discriminant (Etype (Exp)) + and then Static_Accessibility_Level (Exp, Object_Decl_Level) + > Static_Accessibility_Level (N, Object_Decl_Level) + then + -- A dynamic check and a warning are generated when we are within + -- an instance. + + if In_Instance then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + + Error_Msg_N ("anonymous access discriminant is too deep for use" + & " in allocator<<", N); + Error_Msg_N ("\Program_Error [<<", N); + + -- Otherwise, make the error static + + else + Error_Msg_N ("anonymous access discriminant is too deep for use" + & " in allocator", N); + end if; + end if; + if Do_Range_Check (Exp) then Generate_Range_Check (Exp, T, CE_Range_Check_Failed); end if; @@ -850,35 +881,6 @@ package body Exp_Ch4 is return; end if; - -- In the case of an Ada 2012 allocator whose initial value comes from a - -- function call, pass "the accessibility level determined by the point - -- of call" (AI05-0234) to the function. Conceptually, this belongs in - -- Expand_Call but it couldn't be done there (because the Etype of the - -- allocator wasn't set then) so we generate the parameter here. See - -- the Boolean variable Defer in (a block within) Expand_Call. - - if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then - declare - Subp : Entity_Id; - - begin - if Nkind (Name (Exp)) = N_Explicit_Dereference then - Subp := Designated_Type (Etype (Prefix (Name (Exp)))); - else - Subp := Entity (Name (Exp)); - end if; - - Subp := Ultimate_Alias (Subp); - - if Present (Extra_Accessibility_Of_Result (Subp)) then - Add_Extra_Actual_To_Call - (Subprogram_Call => Exp, - Extra_Formal => Extra_Accessibility_Of_Result (Subp), - Extra_Actual => Dynamic_Accessibility_Level (PtrT)); - end if; - end; - end if; - Aggr_In_Place := Is_Delayed_Aggregate (Exp); -- Case of tagged type or type requiring finalization @@ -6870,7 +6872,8 @@ package body Exp_Ch4 is -- objects of an anonymous access type. else - Param_Level := Dynamic_Accessibility_Level (Expr_Entity); + Param_Level := Accessibility_Level + (Expr_Entity, Dynamic_Level); Type_Level := Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); @@ -12285,8 +12288,8 @@ 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 Static_Accessibility_Level (Operand) > - Type_Access_Level (Target_Type) + and then Static_Accessibility_Level (Operand, Zero_On_Dynamic_Level) + > Type_Access_Level (Target_Type) then Raise_Accessibility_Error; goto Done; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 85b5bb8c38a..93351cf4c85 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2518,7 +2518,7 @@ package body Exp_Ch5 is Condition => Make_Op_Gt (Loc, Left_Opnd => - Dynamic_Accessibility_Level (Rhs), + Accessibility_Level (Rhs, Dynamic_Level), Right_Opnd => Make_Integer_Literal (Loc, Intval => @@ -2534,7 +2534,8 @@ package body Exp_Ch5 is (Effective_Extra_Accessibility (Entity (Lhs)), Loc), Expression => - Dynamic_Accessibility_Level (Rhs)); + Accessibility_Level + (Rhs, Dynamic_Level)); begin if not Accessibility_Checks_Suppressed (Entity (Lhs)) then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2f39946a2c8..b7620262e2f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2936,8 +2936,8 @@ package body Exp_Ch6 is New_Occurrence_Of (Lvl, Loc), Expression => - Dynamic_Accessibility_Level - (Expression (Res_Assn)))); + Accessibility_Level + (Expression (Res_Assn), Dynamic_Level))); end if; end Expand_Branch; @@ -3961,15 +3961,16 @@ package body Exp_Ch6 is Add_Extra_Actual (Expr => - New_Occurrence_Of (Get_Accessibility (Parm_Ent), Loc), + New_Occurrence_Of + (Get_Dynamic_Accessibility (Parm_Ent), Loc), EF => Extra_Accessibility (Formal)); end; -- Conditional expressions elsif Nkind (Prev) = N_Expression_With_Actions - and then Nkind (Original_Node (Prev)) in - N_If_Expression | N_Case_Expression + and then Nkind (Original_Node (Prev)) in + N_If_Expression | N_Case_Expression then Add_Cond_Expression_Extra_Actual (Formal); @@ -3977,7 +3978,7 @@ package body Exp_Ch6 is else Add_Extra_Actual - (Expr => Dynamic_Accessibility_Level (Prev), + (Expr => Accessibility_Level (Prev, Dynamic_Level), EF => Extra_Accessibility (Formal)); end if; end if; @@ -4202,110 +4203,44 @@ package body Exp_Ch6 is Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) then declare - Ancestor : Node_Id := Parent (Call_Node); - Level : Node_Id := Empty; - Defer : Boolean := False; + Extra_Form : Node_Id := Empty; + Level : Node_Id := Empty; begin - -- Unimplemented: if Subp returns an anonymous access type, then - - -- a) if the call is the operand of an explict conversion, then - -- the target type of the conversion (a named access type) - -- determines the accessibility level pass in; - - -- b) if the call defines an access discriminant of an object - -- (e.g., the discriminant of an object being created by an - -- allocator, or the discriminant of a function result), - -- then the accessibility level to pass in is that of the - -- discriminated object being initialized). - - -- ??? - - while Nkind (Ancestor) = N_Qualified_Expression - loop - Ancestor := Parent (Ancestor); - end loop; - - case Nkind (Ancestor) is - when N_Allocator => - - -- At this point, we'd like to assign - - -- Level := Dynamic_Accessibility_Level (Ancestor); - - -- but Etype of Ancestor may not have been set yet, - -- so that doesn't work. - - -- Handle this later in Expand_Allocator_Expression. - - Defer := True; - - when N_Object_Declaration - | N_Object_Renaming_Declaration - => - declare - Def_Id : constant Entity_Id := - Defining_Identifier (Ancestor); - - begin - if Is_Return_Object (Def_Id) then - if Present (Extra_Accessibility_Of_Result - (Return_Applies_To (Scope (Def_Id)))) - then - -- Pass along value that was passed in if the - -- routine we are returning from also has an - -- Accessibility_Of_Result formal. - - Level := - New_Occurrence_Of - (Extra_Accessibility_Of_Result - (Return_Applies_To (Scope (Def_Id))), Loc); - end if; - else - Level := - Make_Integer_Literal (Loc, - Intval => Static_Accessibility_Level (Def_Id)); - end if; - end; - - when N_Simple_Return_Statement => - if Present (Extra_Accessibility_Of_Result - (Return_Applies_To - (Return_Statement_Entity (Ancestor)))) - then - -- Pass along value that was passed in if the returned - -- routine also has an Accessibility_Of_Result formal. + -- Detect cases where the function call has been internally + -- generated by examining the original node and return library + -- level - taking care to avoid ignoring function calls expanded + -- in prefix notation. + + if Nkind (Original_Node (Call_Node)) not in N_Function_Call + | N_Selected_Component + | N_Indexed_Component + then + Level := Make_Integer_Literal + (Loc, Scope_Depth (Standard_Standard)); - Level := - New_Occurrence_Of - (Extra_Accessibility_Of_Result - (Return_Applies_To - (Return_Statement_Entity (Ancestor))), Loc); - end if; + -- Otherwise get the level normally based on the call node - when others => - null; - end case; - - if not Defer then - if not Present (Level) then + else + Level := Accessibility_Level (Call_Node, Dynamic_Level); - -- The "innermost master that evaluates the function call". + end if; - -- ??? - Should we use Integer'Last here instead in order - -- to deal with (some of) the problems associated with - -- calls to subps whose enclosing scope is unknown (e.g., - -- Anon_Access_To_Subp_Param.all)? + -- It may be possible that we are re-expanding an already + -- expanded call when are are dealing with dispatching ??? - Level := - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Current_Scope) + 1); - end if; + if not Present (Parameter_Associations (Call_Node)) + or else Nkind (Last (Parameter_Associations (Call_Node))) + /= N_Parameter_Association + or else not Is_Accessibility_Actual + (Last (Parameter_Associations (Call_Node))) + then + Extra_Form := Extra_Accessibility_Of_Result + (Ultimate_Alias (Subp)); Add_Extra_Actual (Expr => Level, - EF => - Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); + EF => Extra_Form); end if; end; end if; @@ -7186,27 +7121,6 @@ package body Exp_Ch6 is -- of the return object to the specific type on assignments to the -- individual components. - procedure Check_Against_Result_Level (Level : Node_Id); - -- Check the given accessibility level against the level - -- determined by the point of call. (AI05-0234). - - -------------------------------- - -- Check_Against_Result_Level -- - -------------------------------- - - procedure Check_Against_Result_Level (Level : Node_Id) is - begin - Insert_Action (N, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Level, - Right_Opnd => - New_Occurrence_Of - (Extra_Accessibility_Of_Result (Scope_Id), Loc)), - Reason => PE_Accessibility_Check_Failed)); - end Check_Against_Result_Level; - -- Start of processing for Expand_Simple_Function_Return begin @@ -7648,17 +7562,6 @@ package body Exp_Ch6 is Suppress => All_Checks); end if; - -- Determine if the special rules within RM 3.10.2 for explicitly - -- aliased formals apply to Exp - in which case we require a dynamic - -- check to be generated. - - if Is_Special_Aliased_Formal_Access (Exp, Scope_Id) then - Check_Against_Result_Level - (Make_Integer_Literal (Loc, - Static_Accessibility_Level - (Entity (Ultimate_Prefix (Prefix (Exp)))))); - end if; - -- If we are returning a nonscalar object that is possibly unaligned, -- then copy the value into a temporary first. This copy may need to -- expand to a loop of component operations. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index f56b7463575..72077236c9d 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -10073,6 +10073,7 @@ package body Exp_Ch9 is Conc_Typ : Entity_Id; Concval : Node_Id; Ename : Node_Id; + Enc_Subp : Entity_Id; Index : Node_Id; Old_Typ : Entity_Id; @@ -10589,6 +10590,26 @@ package body Exp_Ch9 is Old_Typ := Scope (Old_Typ); end loop; + -- Obtain the innermost enclosing callable construct for use in + -- generating a dynamic accessibility check. + + Enc_Subp := Current_Scope; + + if Ekind (Enc_Subp) not in Entry_Kind | Subprogram_Kind then + Enc_Subp := Enclosing_Subprogram (Enc_Subp); + end if; + + -- Generate a dynamic accessibility check on the target object + + Insert_Before_And_Analyze (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Accessibility_Level (Name (N), Dynamic_Level), + Right_Opnd => Make_Integer_Literal (Loc, + Scope_Depth (Enc_Subp))), + Reason => PE_Accessibility_Check_Failed)); + -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form -- Concval.Ename where the type of Concval is class-wide concurrent -- interface. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 104796f1f80..e361601eb9c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11286,10 +11286,9 @@ package body Sem_Attr is -- Otherwise a check will be generated later when the return -- statement gets expanded. - and then not Is_Special_Aliased_Formal_Access - (N, Current_Scope) + and then not Is_Special_Aliased_Formal_Access (N) and then - Static_Accessibility_Level (P) > + Static_Accessibility_Level (N, Zero_On_Dynamic_Level) > Deepest_Type_Access_Level (Btyp) then -- In an instance, this is a runtime check, but one we know @@ -11433,8 +11432,19 @@ package body Sem_Attr is if Attr_Id /= Attribute_Unchecked_Access and then Ekind (Btyp) = E_General_Access_Type + + -- Call Accessibility_Level directly to avoid returning zero + -- on cases where the prefix is an explicitly aliased + -- parameter in a return statement, instead of using the + -- normal Static_Accessibility_Level function. + + -- Shouldn't this be handled somehow in + -- Static_Accessibility_Level ??? + + and then Nkind (Accessibility_Level (P, Dynamic_Level)) + = N_Integer_Literal and then - Static_Accessibility_Level (P) + Intval (Accessibility_Level (P, Dynamic_Level)) > Deepest_Type_Access_Level (Btyp) then Accessibility_Message; @@ -11456,7 +11466,7 @@ package body Sem_Attr is -- anonymous_access_to_protected, there are no accessibility -- checks either. Omit check entirely for Unrestricted_Access. - elsif Static_Accessibility_Level (P) + elsif Static_Accessibility_Level (P, Zero_On_Dynamic_Level) > Deepest_Type_Access_Level (Btyp) and then Comes_From_Source (N) and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1a80b3aafec..70130945ce1 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7285,7 +7285,8 @@ package body Sem_Ch13 is -- check (B) if Type_Access_Level (Ent) - > Static_Accessibility_Level (Pool) + > Static_Accessibility_Level + (Pool, Object_Decl_Level) then Error_Msg_N ("subpool access type has deeper accessibility " diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 8d743383075..d06a4a852e9 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -976,7 +976,7 @@ package body Sem_Ch4 is Nam : Node_Id; X : Interp_Index; It : Interp; - Nam_Ent : Entity_Id; + Nam_Ent : Entity_Id := Empty; Success : Boolean := False; Deref : Boolean := False; @@ -1471,6 +1471,46 @@ package body Sem_Ch4 is End_Interp_List; end if; + -- Check the accessibility level for actuals for explicitly aliased + -- formals. + + if Nkind (N) = N_Function_Call + and then Comes_From_Source (N) + and then Present (Nam_Ent) + and then In_Return_Value (N) + then + declare + Form : Node_Id; + Act : Node_Id; + begin + Act := First_Actual (N); + Form := First_Formal (Nam_Ent); + + while Present (Form) and then Present (Act) loop + -- Check whether the formal is aliased and if the accessibility + -- level of the actual is deeper than the accessibility level + -- of the enclosing subprogam to which the current return + -- statement applies. + + -- Should we be checking Is_Entity_Name on Act? Won't this miss + -- other cases ??? + + if Is_Explicitly_Aliased (Form) + and then Is_Entity_Name (Act) + and then Static_Accessibility_Level + (Act, Zero_On_Dynamic_Level) + > Subprogram_Access_Level (Current_Subprogram) + then + Error_Msg_N ("actual for explicitly aliased formal is too" + & " short lived", Act); + end if; + + Next_Formal (Form); + Next_Actual (Act); + end loop; + end; + end if; + if Ada_Version >= Ada_2012 then -- Check if the call contains a function with writable actuals diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7d8156f45df..88bbdf76c77 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -784,20 +784,19 @@ package body Sem_Ch6 is ------------------------------------------ procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is - Assoc : Node_Id; - Agg : Node_Id := Empty; - Discr : Entity_Id; - Expr : Node_Id; - Obj : Node_Id; - Process_Exprs : Boolean := False; - Return_Con : Node_Id; + Return_Con : Node_Id; + Assoc : Node_Id := Empty; + Assoc_Expr : Node_Id; + Disc : Entity_Id; + Obj_Decl : Node_Id; + Unqual : Node_Id; begin -- Only perform checks on record types with access discriminants and -- non-internally generated functions. if not Is_Record_Type (R_Type) - or else not Has_Discriminants (R_Type) + or else not Has_Anonymous_Access_Discriminant (R_Type) or else not Comes_From_Source (Return_Stmt) then return; @@ -837,166 +836,219 @@ package body Sem_Ch6 is Return_Con := Original_Node (Return_Con); else - Return_Con := Return_Stmt; + Return_Con := Expression (Return_Stmt); end if; - -- We may need to check an aggregate or a subtype indication - -- depending on how the discriminants were specified and whether - -- we are looking at an extended return statement. + -- Obtain the accessibility levels of the expressions associated + -- with all anonymous access discriminants, then generate a + -- dynamic check or static error when relevant. - if Nkind (Return_Con) = N_Object_Declaration - and then Nkind (Object_Definition (Return_Con)) - = N_Subtype_Indication + Unqual := Unqualify (Original_Node (Return_Con)); + + -- Obtain the corresponding declaration based on the return object's + -- identifier. + + if Nkind (Unqual) = N_Identifier + and then Nkind (Parent (Entity (Unqual))) + in N_Object_Declaration + | N_Object_Renaming_Declaration then - Assoc := Original_Node - (First - (Constraints - (Constraint (Object_Definition (Return_Con))))); + Obj_Decl := Original_Node (Parent (Entity (Unqual))); + + -- We were passed the object declaration directly, so use it + + elsif Nkind (Unqual) in N_Object_Declaration + | N_Object_Renaming_Declaration + then + Obj_Decl := Unqual; + + -- Otherwise, we are looking at something else + else - -- Qualified expressions may be nested + Obj_Decl := Empty; - Agg := Original_Node (Expression (Return_Con)); - while Nkind (Agg) = N_Qualified_Expression loop - Agg := Original_Node (Expression (Agg)); - end loop; + end if; + + -- Hop up object renamings when present + + if Present (Obj_Decl) + and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration + then + while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop + + if Nkind (Name (Obj_Decl)) not in N_Entity then + -- We may be looking at the expansion of iterators or + -- some other internally generated construct, so it is safe + -- to ignore checks ??? + + if not Comes_From_Source (Obj_Decl) then + return; + end if; - -- If we are looking at an aggregate instead of a function call we - -- can continue checking accessibility for the supplied - -- discriminant associations. + Obj_Decl := Original_Node + (Declaration_Node + (Ultimate_Prefix (Name (Obj_Decl)))); + + -- Move up to the next declaration based on the object's name - if Nkind (Agg) = N_Aggregate then - if Present (Expressions (Agg)) then - Assoc := First (Expressions (Agg)); - Process_Exprs := True; else - Assoc := First (Component_Associations (Agg)); + Obj_Decl := Original_Node + (Declaration_Node (Name (Obj_Decl))); end if; + end loop; + end if; + + -- Obtain the discriminant values from the return aggregate - -- Otherwise the expression is not of interest ??? + -- Do we cover extension aggregates correctly ??? + if Nkind (Unqual) = N_Aggregate then + if Present (Expressions (Unqual)) then + Assoc := First (Expressions (Unqual)); else - return; + Assoc := First (Component_Associations (Unqual)); end if; - end if; - -- Move through the discriminants checking the accessibility level - -- of each co-extension's associated expression. + -- There is an object declaration for the return object - Discr := First_Discriminant (R_Type); - while Present (Discr) loop - if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + elsif Present (Obj_Decl) then + -- When a subtype indication is present in an object declaration + -- it must contain the object's discriminants. + + if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then + Assoc := First + (Constraints + (Constraint + (Object_Definition (Obj_Decl)))); + + -- The object declaration contains an aggregate + + elsif Present (Expression (Obj_Decl)) then + + if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then + -- Grab the first associated discriminant expresion + + if Present + (Expressions (Unqualify (Expression (Obj_Decl)))) + then + Assoc := First + (Expressions + (Unqualify (Expression (Obj_Decl)))); + else + Assoc := First + (Component_Associations + (Unqualify (Expression (Obj_Decl)))); + end if; + + -- Otherwise, this is something else - if Nkind (Assoc) = N_Attribute_Reference then - Expr := Assoc; - elsif Nkind (Assoc) in - N_Component_Association | N_Discriminant_Association - then - Expr := Expression (Assoc); else - Expr := Empty; + return; end if; - -- This anonymous access discriminant has an associated - -- expression which needs checking. - - if Present (Expr) - and then Nkind (Expr) = N_Attribute_Reference - and then Attribute_Name (Expr) /= Name_Unrestricted_Access - then - -- Obtain the object to perform static checks on by moving - -- up the prefixes in the expression taking into account - -- named access types and renamed objects within the - -- expression. + -- There are no supplied discriminants in the object declaration, + -- so get them from the type definition since they must be default + -- initialized. - -- Note, this loop duplicates some of the logic in - -- Object_Access_Level since we have to check special rules - -- based on the context we are in (a return aggregate) - -- relating to formals of the current function. + -- Do we handle constrained subtypes correctly ??? - Obj := Original_Node (Prefix (Expr)); - loop - while Nkind (Obj) in N_Explicit_Dereference - | N_Indexed_Component - | N_Selected_Component - loop - -- When we encounter a named access type then we can - -- ignore accessibility checks on the dereference. + elsif Nkind (Unqual) = N_Object_Declaration then + Assoc := First_Discriminant + (Etype (Object_Definition (Obj_Decl))); - if Ekind (Etype (Original_Node (Prefix (Obj)))) - in E_Access_Type .. - E_Access_Protected_Subprogram_Type - then - if Nkind (Obj) = N_Selected_Component then - Obj := Selector_Name (Obj); - else - Obj := Original_Node (Prefix (Obj)); - end if; - exit; - end if; + else + Assoc := First_Discriminant (Etype (Unqual)); + end if; - Obj := Original_Node (Prefix (Obj)); - end loop; + -- When we are not looking at an aggregate or an identifier, return + -- since any other construct (like a function call) is not + -- applicable since checks will be performed on the side of the + -- callee. - if Nkind (Obj) = N_Selected_Component then - Obj := Selector_Name (Obj); - end if; + else + return; + end if; - -- Check for renamings + -- Obtain the discriminants so we know the actual type in case the + -- value of their associated expression gets implicitly converted. - pragma Assert (Is_Entity_Name (Obj)); + if No (Obj_Decl) then + pragma Assert (Nkind (Unqual) = N_Aggregate); - if Present (Renamed_Object (Entity (Obj))) then - Obj := Renamed_Object (Entity (Obj)); - else - exit; - end if; - end loop; + Disc := First_Discriminant (Etype (Unqual)); - -- Do not check aliased formals statically + else + Disc := First_Discriminant + (Etype (Defining_Identifier (Obj_Decl))); + end if; - if Is_Formal (Entity (Obj)) - and then (Is_Aliased (Entity (Obj)) - or else Ekind (Etype (Entity (Obj))) = - E_Anonymous_Access_Type) - then - null; + -- Loop through each of the discriminants and check each expression + -- associated with an anonymous access discriminant. - -- Otherwise, handle the expression normally, avoiding the - -- special logic above, and call Object_Access_Level with - -- the original expression. + while Present (Assoc) and then Present (Disc) loop + -- Unwrap the associated expression - elsif Static_Accessibility_Level (Expr) > - Scope_Depth (Scope (Scope_Id)) - then - Error_Msg_N - ("access discriminant in return aggregate would " - & "be a dangling reference", Obj); - end if; - end if; - end if; + if Nkind (Assoc) + in N_Component_Association | N_Discriminant_Association + then + Assoc_Expr := Expression (Assoc); - Next_Discriminant (Discr); + elsif Nkind (Assoc) in N_Entity + and then Ekind (Assoc) = E_Discriminant + then + Assoc_Expr := Discriminant_Default_Value (Assoc); - if not Is_List_Member (Assoc) then - Assoc := Empty; else - Nlists.Next (Assoc); + Assoc_Expr := Assoc; end if; - -- After aggregate expressions, examine component associations if - -- present. + -- Check the accessibility level of the expression when the + -- discriminant is of an anonymous access type. + + if Present (Assoc_Expr) + and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type + then + -- Perform a static check first, if possible - if No (Assoc) then - if Present (Agg) - and then Process_Exprs - and then Present (Component_Associations (Agg)) + if Static_Accessibility_Level + (Expr => Assoc_Expr, + Level => Zero_On_Dynamic_Level, + In_Return_Context => True) + > Scope_Depth (Scope (Scope_Id)) then - Assoc := First (Component_Associations (Agg)); - Process_Exprs := False; - else + Error_Msg_N + ("access discriminant in return object would be a dangling" + & " reference", Return_Stmt); exit; + + end if; + + -- Otherwise, generate a dynamic check based on the extra + -- accessibility of the result. + + if Present (Extra_Accessibility_Of_Result (Scope_Id)) then + Insert_Before_And_Analyze (Return_Stmt, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Accessibility_Level + (Expr => Assoc_Expr, + Level => Dynamic_Level, + In_Return_Context => True), + Right_Opnd => Extra_Accessibility_Of_Result + (Scope_Id)), + Reason => PE_Accessibility_Check_Failed)); end if; end if; + + -- Iterate over the discriminants + + Disc := Next_Discriminant (Disc); + if not Is_List_Member (Assoc) then + exit; + else + Nlists.Next (Assoc); + end if; end loop; end Check_Return_Construct_Accessibility; @@ -1436,8 +1488,8 @@ 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 Static_Accessibility_Level (Expr) > - Subprogram_Access_Level (Scope_Id) + and then Static_Accessibility_Level (Expr, Zero_On_Dynamic_Level) + > Subprogram_Access_Level (Scope_Id) then -- Suppress the message in a generic, where the rewriting -- is irrelevant. @@ -2578,6 +2630,9 @@ package body Sem_Ch6 is Loc : constant Source_Ptr := Sloc (N); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); + Body_Nod : Node_Id := Empty; + Minimum_Acc_Objs : List_Id := No_List; + Conformant : Boolean; Desig_View : Entity_Id := Empty; Exch_Views : Elist_Id := No_Elist; @@ -2662,6 +2717,13 @@ package body Sem_Ch6 is -- limited views with the non-limited ones. Return the list of changes -- to be used to undo the transformation. + procedure Generate_Minimum_Accessibility + (Extra_Access : Entity_Id; + Related_Form : Entity_Id := Empty); + -- Generate a minimum accessibility object for a given extra + -- accessibility formal (Extra_Access) and its related formal if it + -- exists. + function Is_Private_Concurrent_Primitive (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id is a primitive of a concurrent @@ -3439,6 +3501,66 @@ package body Sem_Ch6 is return Result; end Exchange_Limited_Views; + ------------------------------------ + -- Generate_Minimum_Accessibility -- + ------------------------------------ + + procedure Generate_Minimum_Accessibility + (Extra_Access : Entity_Id; + Related_Form : Entity_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (Body_Nod); + Form : Entity_Id; + Obj_Node : Node_Id; + begin + -- When no related formal exists then we are dealing with an + -- extra accessibility formal for a function result. + + if No (Related_Form) then + Form := Extra_Access; + else + Form := Related_Form; + end if; + + -- Create the minimum accessibility object + + Obj_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Temporary + (Loc, 'A', Extra_Access), + Object_Definition => New_Occurrence_Of + (Standard_Natural, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (Standard_Natural, Loc), + Attribute_Name => Name_Min, + Expressions => New_List ( + Make_Integer_Literal (Loc, + Scope_Depth (Body_Id)), + New_Occurrence_Of + (Extra_Access, Loc)))); + + -- 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 Generate_Minimum_Accessibility; + ------------------------------------- -- Is_Private_Concurrent_Primitive -- ------------------------------------- @@ -3770,9 +3892,6 @@ 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; @@ -4650,7 +4769,7 @@ package body Sem_Ch6 is -- This method is used to supplement our "small integer model" for -- accessibility-check generation (for more information see - -- Dynamic_Accessibility_Level). + -- Accessibility_Level). -- Because we allow accessibility values greater than our expected value -- passing along the same extra accessibility formal as an actual @@ -4701,49 +4820,31 @@ package body Sem_Ch6 is -- A60b : constant natural := natural'min(1, 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)), - Constant_Present => True, - Object_Definition => New_Occurrence_Of - (Standard_Natural, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of - (Standard_Natural, Loc), - Attribute_Name => Name_Min, - Expressions => New_List ( - Make_Integer_Literal (Loc, - Scope_Depth (Current_Scope)), - 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. + Generate_Minimum_Accessibility + (Extra_Accessibility (Form), Form); + end if; - if Present (Minimum_Acc_Objs) then - Prepend (Obj_Node, Minimum_Acc_Objs); - else - Minimum_Acc_Objs := New_List (Obj_Node); - end if; + Next_Formal (Form); + end loop; - -- Register the object and analyze it + -- Generate the minimum accessibility level object for the + -- function's Extra_Accessibility_Of_Result. - Set_Minimum_Accessibility - (Form, Defining_Identifier (Obj_Node)); + -- A31b : constant natural := natural'min (2, funcL); - Analyze (Obj_Node); - end; - end if; + if Ekind (Body_Id) = E_Function + and then Present (Extra_Accessibility_Of_Result (Body_Id)) + then + Generate_Minimum_Accessibility + (Extra_Accessibility_Of_Result (Body_Id)); - Next_Formal (Form); - end loop; + -- Replace the Extra_Accessibility_Of_Result with the new + -- minimum accessibility object. + + Set_Extra_Accessibility_Of_Result + (Body_Id, Minimum_Accessibility + (Extra_Accessibility_Of_Result (Body_Id))); + end if; end if; end; end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index fd3a29cfcbd..a9d720b18a4 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2360,7 +2360,8 @@ package body Sem_Ch9 is -- entry body) unless it is a parameter of the innermost enclosing -- accept statement (or entry body). - if Static_Accessibility_Level (Target_Obj) >= Scope_Depth (Outer_Ent) + if Static_Accessibility_Level (Target_Obj, Zero_On_Dynamic_Level) + >= 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 33206eb685e..a24c9c24638 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3500,7 +3500,7 @@ 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))) - < Static_Accessibility_Level (A) + < Static_Accessibility_Level (A, Object_Decl_Level) then Error_Msg_N ("aliased actual has wrong accessibility", A); end if; @@ -3508,7 +3508,7 @@ package body Sem_Res is elsif Nkind (Parent (N)) = N_Qualified_Expression and then Nkind (Parent (Parent (N))) = N_Allocator and then Type_Access_Level (Etype (Parent (Parent (N)))) - < Static_Accessibility_Level (A) + < Static_Accessibility_Level (A, Object_Decl_Level) then Error_Msg_N ("aliased actual in allocator has wrong accessibility", A); @@ -5061,8 +5061,9 @@ 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 Static_Accessibility_Level (Prefix (Disc_Exp)) > - Deepest_Type_Access_Level (Alloc_Typ) + and then Static_Accessibility_Level + (Disc_Exp, Zero_On_Dynamic_Level) + > Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N ("prefix of attribute has deeper level than allocator type", @@ -5073,8 +5074,9 @@ package body Sem_Res is elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type and then Nkind (Disc_Exp) = N_Selected_Component - and then Static_Accessibility_Level (Prefix (Disc_Exp)) > - Deepest_Type_Access_Level (Alloc_Typ) + and then Static_Accessibility_Level + (Disc_Exp, Zero_On_Dynamic_Level) + > Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N ("access discriminant has deeper level than allocator type", @@ -13351,12 +13353,13 @@ package body Sem_Res is then -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by - -- the prefix of the selected name (Object_Access_Level handles + -- the prefix of the selected name (Accessibility_Level handles -- checking the prefix of the operand for this case). if Nkind (Operand) = N_Selected_Component - and then Static_Accessibility_Level (Operand) - > Deepest_Type_Access_Level (Target_Type) + and then Static_Accessibility_Level + (Operand, Zero_On_Dynamic_Level) + > 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 @@ -13524,6 +13527,13 @@ package body Sem_Res is N_Function_Specification or else Ekind (Target_Type) in Anonymous_Access_Kind) + + -- Check we are not in a return value ??? + + and then (not In_Return_Value (N) + or else + Nkind (Associated_Node_For_Itype (Target_Type)) + = N_Component_Declaration) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -13558,12 +13568,13 @@ package body Sem_Res is then -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by - -- the prefix of the selected name (Object_Access_Level handles + -- the prefix of the selected name (Accessibility_Level handles -- checking the prefix of the operand for this case). if Nkind (Operand) = N_Selected_Component - and then Static_Accessibility_Level (Operand) - > Deepest_Type_Access_Level (Target_Type) + and then Static_Accessibility_Level + (Operand, Zero_On_Dynamic_Level) + > 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 5557328062f..0eb49050cd9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -98,11 +98,6 @@ 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; @@ -275,16 +270,21 @@ package body Sem_Util is return Interface_List (Nod); end Abstract_Interface_List; - -------------------------------- - -- Accessibility_Level_Helper -- - -------------------------------- + ------------------------- + -- Accessibility_Level -- + ------------------------- - function Accessibility_Level_Helper - (Expr : Node_Id; - Static : Boolean := False) return Node_Id + function Accessibility_Level + (Expr : Node_Id; + Level : Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); + function Accessibility_Level (Expr : Node_Id) return Node_Id + is (Accessibility_Level (Expr, Level, In_Return_Context)); + -- Renaming of the enclosing function to facilitate recursive calls + function Make_Level_Literal (Level : Uint) return Node_Id; -- Construct an integer literal representing an accessibility level -- with its type set to Natural. @@ -295,7 +295,8 @@ package body Sem_Util is -- enclosing dynamic scope (effectively the accessibility -- level of the innermost enclosing master). - function Function_Call_Level (Call_Ent : Entity_Id) return Node_Id; + function Function_Call_Or_Allocator_Level + (N : Node_Id) return Node_Id; -- Centralized processing of subprogram calls which may appear in -- prefix notation. @@ -306,8 +307,9 @@ package body Sem_Util is function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is - Encl_Scop : Entity_Id; - Node_Par : Node_Id := Parent (N); + Encl_Scop : Entity_Id; + Node_Par : Node_Id := Parent (N); + Master_Lvl_Modifier : Int := 0; begin -- Locate the nearest enclosing node (by traversing Parents) @@ -319,6 +321,7 @@ package body Sem_Util is -- among other things. These cases are detected properly ??? while Present (Node_Par) loop + if Present (Defining_Entity (Node_Par, Empty_On_Errors => True)) then @@ -328,7 +331,7 @@ package body Sem_Util is -- Ignore transient scopes made during expansion if Comes_From_Source (Node_Par) then - return Scope_Depth (Encl_Scop); + return Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; end if; -- For a return statement within a function, return @@ -342,15 +345,21 @@ package body Sem_Util is and then Ekind (Current_Scope) = E_Function then return Scope_Depth (Current_Scope); + + -- Statements are counted as masters + + elsif Is_Master (Node_Par) then + Master_Lvl_Modifier := Master_Lvl_Modifier + 1; + end if; Node_Par := Parent (Node_Par); end loop; - pragma Assert (False); - -- Should never reach the following return + pragma Assert (False); + return Scope_Depth (Current_Scope) + 1; end Innermost_Master_Scope_Depth; @@ -366,12 +375,13 @@ package body Sem_Util is return Result; end Make_Level_Literal; - ------------------------- - -- Function_Call_Level -- - ------------------------- + -------------------------------------- + -- Function_Call_Or_Allocator_Level -- + -------------------------------------- - function Function_Call_Level (Call_Ent : Entity_Id) return Node_Id is - Par : Node_Id; + function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is + Par : Node_Id; + Prev_Par : Node_Id; begin -- Results of functions are objects, so we either get the -- accessibility of the function or, in case of a call which is @@ -379,53 +389,88 @@ package body Sem_Util is -- This code looks wrong ??? - if Ada_Version < Ada_2005 then - if Is_Entity_Name (Name (Call_Ent)) then + if Nkind (N) = N_Function_Call + and then Ada_Version < Ada_2005 + then + if Is_Entity_Name (Name (N)) then return Make_Level_Literal - (Subprogram_Access_Level (Entity (Name (Call_Ent)))); + (Subprogram_Access_Level (Entity (Name (N)))); else return Make_Level_Literal - (Type_Access_Level (Etype (Prefix (Name (Call_Ent))))); + (Type_Access_Level (Etype (Prefix (Name (N))))); end if; + + -- We ignore coextensions as they cannot be implemented under the + -- "small-integer" model. + + elsif Nkind (N) = N_Allocator + and then (Is_Static_Coextension (N) + or else Is_Dynamic_Coextension (N)) + then + return Make_Level_Literal + (Scope_Depth (Standard_Standard)); 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))); + if Is_Named_Access_Type (Etype (N)) then + return Make_Level_Literal (Type_Access_Level (Etype (N))); -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) else + if Nkind (N) = N_Function_Call then + -- Dynamic checks are generated when we are within a return + -- value or we are in a function call within an anonymous + -- access discriminant constraint of a return object (signified + -- by In_Return_Context) on the side of the callee. + + -- So, in this case, return library accessibility level to null + -- out the check on the side of the caller. + + if In_Return_Value (N) + or else In_Return_Context + then + return Make_Level_Literal + (Subprogram_Access_Level (Current_Subprogram)); + end if; + end if; + -- Find any relevant enclosing parent nodes that designate an -- object being initialized. -- Note: The above is only relevant if the result is used "in its -- entirety" as RM 3.10.2 (10.2/3) states. However, this is -- accounted for in the case statement in the main body of - -- Accessibility_Level_Helper for N_Selected_Component. - - -- How are we sure, for example, that we are not coming up from, - -- say, the left hand part of an assignment. More verification - -- needed ??? + -- Accessibility_Level for N_Selected_Component. - Par := Parent (Expr); + Par := Parent (Expr); + Prev_Par := Empty; while Present (Par) loop - exit when Nkind (Par) in N_Assignment_Statement - | N_Object_Declaration - | N_Function_Call; - Par := Parent (Par); - end loop; + -- Detect an expanded implicit conversion, typically this + -- occurs on implicitly converted actuals in calls. - -- If no object is being initialized then the level is that of the - -- innermost master of the call, according to RM 3.10.2 (10.6/3). + -- Does this catch all implicit conversions ??? - if No (Par) or else Nkind (Par) = N_Function_Call then - return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); - end if; + if Nkind (Par) = N_Type_Conversion + and then Is_Named_Access_Type (Etype (Par)) + then + return Make_Level_Literal + (Type_Access_Level (Etype (Par))); + end if; + + -- Jump out when we hit an object declaration or the right-hand + -- side of an assignment, or a construct such as an aggregate + -- subtype indication which would be the result is not used + -- "in its entirety." - -- The function call was used to initialize the entire object, so - -- the master is "that of the object." + exit when Nkind (Par) in N_Object_Declaration + or else (Nkind (Par) = N_Assignment_Statement + and then Name (Par) /= Prev_Par); + + Prev_Par := Par; + Par := Parent (Par); + end loop; -- Assignment statements are handled in a similar way in -- accordance to the left-hand part. However, strictly speaking, @@ -441,23 +486,24 @@ package body Sem_Util is when N_Assignment_Statement => -- Return the accessiblity level of the left-hand part - return Accessibility_Level_Helper (Name (Par), Static); - - -- Should never get here + return Accessibility_Level + (Expr => Name (Par), + Level => Object_Decl_Level, + In_Return_Context => In_Return_Context); when others => - raise Program_Error; + return Make_Level_Literal + (Innermost_Master_Scope_Depth (Expr)); end case; end if; - end Function_Call_Level; + end Function_Call_Or_Allocator_Level; -- Local variables E : Entity_Id := Original_Node (Expr); - Par : Node_Id; Pre : Node_Id; - -- Start of processing for Accessibility_Level_Helper + -- Start of processing for Accessibility_Level begin -- We could be looking at a reference to a formal due to the expansion @@ -493,74 +539,7 @@ package body Sem_Util is -- (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 (Par)))); - - -- 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 (Par))))); - - -- 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; + return Function_Call_Or_Allocator_Level (E); -- We could reach this point for two reasons. Either the expression -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or @@ -574,7 +553,7 @@ package body Sem_Util is -- prefix. if Attribute_Name (E) = Name_Access then - return Accessibility_Level_Helper (Prefix (E), Static); + return Accessibility_Level (Prefix (E)); -- Unchecked or unrestricted attributes have unlimited depth @@ -599,11 +578,11 @@ package body Sem_Util is -- Anonymous access types elsif Nkind (Pre) in N_Has_Entity - and then Present (Get_Accessibility (Entity (Pre))) - and then not Static + and then Present (Get_Dynamic_Accessibility (Entity (Pre))) + and then Level = Dynamic_Level then return New_Occurrence_Of - (Get_Accessibility (Entity (Pre)), Loc); + (Get_Dynamic_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 @@ -624,16 +603,43 @@ package body Sem_Util is -- means we are near the end of our recursive traversal. when N_Defining_Identifier => + -- A dynamic check is performed on the side of the callee when we + -- are within a return statement, so return a library-level + -- accessibility level to null out checks on the side of the + -- caller. + + if Is_Explicitly_Aliased (E) + and then Level /= Dynamic_Level + and then (In_Return_Value (Expr) + or else In_Return_Context) + then + return Make_Level_Literal (Scope_Depth (Standard_Standard)); + + -- Something went wrong and an extra accessibility formal has not + -- been generated when one should have ??? + + elsif Is_Formal (E) + and then not Present (Get_Dynamic_Accessibility (E)) + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + then + return Make_Level_Literal (Scope_Depth (Standard_Standard)); + -- 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 + elsif (Is_Formal (E) + or else Ekind (E) in E_Variable + | E_Constant) + and then Present (Get_Dynamic_Accessibility (E)) + and then (Level = Dynamic_Level + or else Level = Zero_On_Dynamic_Level) then + if Level = Zero_On_Dynamic_Level then + return Make_Level_Literal + (Scope_Depth (Standard_Standard)); + end if; + return - New_Occurrence_Of (Get_Accessibility (E), Loc); + New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc); -- Initialization procedures have a special extra accessitility -- parameter associated with the level at which the object @@ -647,14 +653,6 @@ package body Sem_Util is 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). @@ -669,8 +667,7 @@ package body Sem_Util is elsif Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then - return Accessibility_Level_Helper - (Renamed_Object (E), Static); + return Accessibility_Level (Renamed_Object (E)); -- Named access types get their level from their associated type @@ -705,11 +702,18 @@ package body Sem_Util is when N_Indexed_Component | N_Selected_Component => Pre := Original_Node (Prefix (E)); + -- When E is an indexed component or selected component and + -- the current Expr is a function call, we know that we are + -- looking at an expanded call in prefix notation. + + if Nkind (Expr) = N_Function_Call then + return Function_Call_Or_Allocator_Level (Expr); + -- 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 + elsif Is_Named_Access_Type (Etype (Pre)) then return Make_Level_Literal (Type_Access_Level (Etype (Pre))); @@ -764,13 +768,29 @@ package body Sem_Util is elsif Nkind (Pre) = N_Function_Call and then not Is_Named_Access_Type (Etype (Pre)) then + -- Dynamic checks are generated when we are within a return + -- value or we are in a function call within an anonymous + -- access discriminant constraint of a return object (signified + -- by In_Return_Context) on the side of the callee. + + -- So, in this case, return a library accessibility level to + -- null out the check on the side of the caller. + + if (In_Return_Value (E) + or else In_Return_Context) + and then Level /= Dynamic_Level + then + return Make_Level_Literal + (Scope_Depth (Standard_Standard)); + end if; + return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); -- Otherwise, continue recursing over the expression prefixes else - return Accessibility_Level_Helper (Prefix (E), Static); + return Accessibility_Level (Prefix (E)); end if; -- Qualified expressions @@ -780,13 +800,13 @@ package body Sem_Util is return Make_Level_Literal (Type_Access_Level (Etype (E))); else - return Accessibility_Level_Helper (Expression (E), Static); + return Accessibility_Level (Expression (E)); end if; -- Handle function calls when N_Function_Call => - return Function_Call_Level (E); + return Function_Call_Or_Allocator_Level (E); -- Explicit dereference accessibility level calculation @@ -802,7 +822,7 @@ package body Sem_Util is -- Otherwise, recurse deeper else - return Accessibility_Level_Helper (Prefix (E), Static); + return Accessibility_Level (Prefix (E)); end if; -- Type conversions @@ -817,7 +837,7 @@ package body Sem_Util is if Is_View_Conversion (E) or else Ekind (Etype (E)) = E_Anonymous_Access_Type then - return Accessibility_Level_Helper (Expression (E), Static); + return Accessibility_Level (Expression (E)); -- We don't care about the master if we are looking at a named -- access type. @@ -833,7 +853,7 @@ package body Sem_Util is -- Should use Innermost_Master_Scope_Depth ??? else - return Accessibility_Level_Helper (Current_Scope, Static); + return Accessibility_Level (Current_Scope); end if; -- Default to the type accessibility level for the type of the @@ -842,7 +862,21 @@ package body Sem_Util is when others => return Make_Level_Literal (Type_Access_Level (Etype (E))); end case; - end Accessibility_Level_Helper; + end Accessibility_Level; + + -------------------------------- + -- Static_Accessibility_Level -- + -------------------------------- + + function Static_Accessibility_Level + (Expr : Node_Id; + Level : Static_Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Uint + is + begin + return Intval + (Accessibility_Level (Expr, Level, In_Return_Context)); + end Static_Accessibility_Level; ---------------------------------- -- Acquire_Warning_Match_String -- @@ -902,7 +936,6 @@ package body Sem_Util is procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - begin pragma Assert (Nkind (N) = N_Block_Statement); @@ -5473,8 +5506,9 @@ package body Sem_Util is if Present (Pref_Encl_Typ) and then No (Cont_Encl_Typ) and then Is_Public_Operation - and then Scope_Depth (Pref_Encl_Typ) >= - Static_Accessibility_Level (Context) + and then Scope_Depth (Pref_Encl_Typ) + >= Static_Accessibility_Level + (Context, Object_Decl_Level) then Error_Msg_N ("??possible unprotected access to protected data", Expr); @@ -7669,15 +7703,6 @@ package body Sem_Util is Analyze (N); end Diagnose_Iterated_Component_Association; - --------------------------------- - -- Dynamic_Accessibility_Level -- - --------------------------------- - - function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is - begin - return Accessibility_Level_Helper (Expr); - end Dynamic_Accessibility_Level; - ------------------------ -- Discriminated_Size -- ------------------------ @@ -10174,11 +10199,11 @@ package body Sem_Util is end if; end Gather_Components; - ----------------------- - -- Get_Accessibility -- - ----------------------- + ------------------------------- + -- Get_Dynamic_Accessibility -- + ------------------------------- - function Get_Accessibility (E : Entity_Id) return Entity_Id is + function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_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 @@ -10196,7 +10221,7 @@ package body Sem_Util is end if; return Extra_Accessibility (E); - end Get_Accessibility; + end Get_Dynamic_Accessibility; ------------------------ -- Get_Actual_Subtype -- @@ -11394,6 +11419,31 @@ package body Sem_Util is end if; end Has_Access_Values; + --------------------------------------- + -- Has_Anonymous_Access_Discriminant -- + --------------------------------------- + + function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean + is + Disc : Node_Id; + + begin + if not Has_Discriminants (Typ) then + return False; + end if; + + Disc := First_Discriminant (Typ); + while Present (Disc) loop + if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Disc); + end loop; + + return False; + end Has_Anonymous_Access_Discriminant; + ------------------------------ -- Has_Compatible_Alignment -- ------------------------------ @@ -12554,6 +12604,18 @@ package body Sem_Util is (Directly_Designated_Type (Etype (Formal))) = E; end Is_Access_Subprogram_Wrapper; + --------------------------- + -- Is_Explicitly_Aliased -- + --------------------------- + + function Is_Explicitly_Aliased (N : Node_Id) return Boolean is + begin + return Is_Formal (N) + and then Present (Parent (N)) + and then Nkind (Parent (N)) = N_Parameter_Specification + and then Aliased_Present (Parent (N)); + end Is_Explicitly_Aliased; + ---------------------------- -- Is_Container_Aggregate -- ---------------------------- @@ -14155,6 +14217,96 @@ package body Sem_Util is return False; end In_Subtree; + --------------------- + -- In_Return_Value -- + --------------------- + + function In_Return_Value (Expr : Node_Id) return Boolean is + Par : Node_Id; + Prev_Par : Node_Id; + Pre : Node_Id; + In_Function_Call : Boolean := False; + + begin + -- Move through parent nodes to determine if Expr contributes to the + -- return value of the current subprogram. + + Par := Expr; + Prev_Par := Empty; + while Present (Par) loop + + case Nkind (Par) is + -- Ignore ranges and they don't contribute to the result + + when N_Range => + return False; + + -- An object declaration whose parent is an extended return + -- statement is a return object. + + when N_Object_Declaration => + if Present (Parent (Par)) + and then Nkind (Parent (Par)) = N_Extended_Return_Statement + then + return True; + end if; + + -- We hit a simple return statement, so we know we are in one + + when N_Simple_Return_Statement => + return True; + + -- Only include one nexting level of function calls + + when N_Function_Call => + if not In_Function_Call then + In_Function_Call := True; + else + return False; + end if; + + -- Check if we are on the right-hand side of an assignment + -- statement to a return object. + + -- This is not specified in the RM ??? + + when N_Assignment_Statement => + if Prev_Par = Name (Par) then + return False; + end if; + + Pre := Name (Par); + while Present (Pre) loop + if Is_Entity_Name (Pre) + and then Is_Return_Object (Entity (Pre)) + then + return True; + end if; + + exit when Nkind (Pre) not in N_Selected_Component + | N_Indexed_Component + | N_Slice; + + Pre := Prefix (Pre); + end loop; + + -- Otherwise, we hit a master which was not relevant + + when others => + if Is_Master (Par) then + return False; + end if; + end case; + + -- Iterate up to the next parent, keeping track of the previous one + + Prev_Par := Par; + Par := Parent (Par); + end loop; + + return False; + end In_Return_Value; + --------------------- -- In_Visible_Part -- --------------------- @@ -17438,6 +17590,62 @@ package body Sem_Util is end if; end Is_Local_Variable_Reference; + --------------- + -- Is_Master -- + --------------- + + function Is_Master (N : Node_Id) return Boolean is + Disable_Subexpression_Masters : constant Boolean := True; + + begin + if Nkind (N) in N_Subprogram_Body | N_Task_Body | N_Entry_Body + or else Is_Statement (N) + then + return True; + end if; + + -- We avoid returning True when the master is a subexpression described + -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation + -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ??? + + if not Disable_Subexpression_Masters + and then Nkind (N) in N_Subexpr + then + declare + Par : Node_Id := N; + + subtype N_Simple_Statement_Other_Than_Simple_Return + is Node_Kind with Static_Predicate => + N_Simple_Statement_Other_Than_Simple_Return + in N_Abort_Statement + | N_Assignment_Statement + | N_Code_Statement + | N_Delay_Statement + | N_Entry_Call_Statement + | N_Free_Statement + | N_Goto_Statement + | N_Null_Statement + | N_Raise_Statement + | N_Requeue_Statement + | N_Exit_Statement + | N_Procedure_Call_Statement; + begin + while Present (Par) loop + Par := Parent (Par); + if Nkind (Par) in N_Subexpr | + N_Simple_Statement_Other_Than_Simple_Return + then + return False; + end if; + end loop; + + return True; + end; + end if; + + return False; + end Is_Master; + ----------------------- -- Is_Name_Reference -- ----------------------- @@ -19609,8 +19817,10 @@ package body Sem_Util is -------------------------------------- function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - Scop : Entity_Id) return Boolean is + (Exp : Node_Id; + In_Return_Context : Boolean := False) return Boolean + is + Scop : constant Entity_Id := Current_Subprogram; begin -- Verify the expression is an access reference to 'Access within a -- return statement as this is the only time an explicitly aliased @@ -19618,7 +19828,9 @@ package body Sem_Util is if Nkind (Exp) /= N_Attribute_Reference or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access - or else Nkind (Parent (Exp)) /= N_Simple_Return_Statement + or else not (In_Return_Value (Exp) + or else In_Return_Context) + or else not Needs_Result_Accessibility_Level (Scop) then return False; end if; @@ -19628,17 +19840,8 @@ package body Sem_Util is -- that Scop returns an anonymous access type, otherwise the special -- rules dictating a need for a dynamic check are not in effect. - declare - P_Ult : constant Node_Id := Ultimate_Prefix (Prefix (Exp)); - begin - return Is_Entity_Name (P_Ult) - and then Is_Aliased (Entity (P_Ult)) - and then Is_Formal (Entity (P_Ult)) - and then Scope (Entity (P_Ult)) = Scop - and then Ekind (Scop) in - E_Function | E_Operator | E_Subprogram_Type - and then Needs_Result_Accessibility_Level (Scop); - end; + return Is_Entity_Name (Prefix (Exp)) + and then Is_Explicitly_Aliased (Entity (Prefix (Exp))); end Is_Special_Aliased_Formal_Access; ----------------------------- @@ -27637,15 +27840,6 @@ 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 f38d0f5ad1c..1b993f9cc9e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -43,6 +43,36 @@ package Sem_Util is -- including the cases where there can't be any because e.g. the type is -- not tagged. + type Accessibility_Level_Kind is + (Dynamic_Level, + Object_Decl_Level, + Zero_On_Dynamic_Level); + -- Accessibility_Level_Kind is an enumerated type which captures the + -- different modes in which an accessibility level could be obtained for + -- a given expression. + + -- When in the context of the function Accessibility_Level, + -- Accessibility_Level_Kind signals what type of accessibility level to + -- obtain. For example, when Level is Dynamic_Level, a defining identifier + -- associated with a SAOOAAT may be returned or an N_Integer_Literal node. + -- When the level is Object_Decl_Level, an N_Integer_Literal node is + -- returned containing the level of the declaration of the object if + -- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level + -- returns library level for all cases where the accessibility level is + -- dynamic (used to bypass static accessibility checks in dynamic cases). + + function Accessibility_Level + (Expr : Node_Id; + Level : Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Node_Id; + -- Centralized accessibility level calculation routine for finding the + -- accessibility level of a given expression Expr. + + -- In_Return_Context forcing the Accessibility_Level calculations to be + -- carried out "as if" Expr existed in a return value. This is useful for + -- calculating the accessibility levels for discriminant associations + -- and return aggregates. + function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String; -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get -- the given string argument, adding leading and trailing asterisks if they @@ -704,12 +734,6 @@ 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 (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 -- are looked through. @@ -1054,7 +1078,7 @@ 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 Entity_Id; + function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id; -- Obtain the accessibility level for a given entity formal taking into -- account both extra and minimum accessibility. @@ -1282,6 +1306,9 @@ package Sem_Util is -- as an access type internally, this function tests only for access types -- known to the programmer. See also Has_Tagged_Component. + function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean; + -- Returns True if Typ has one or more anonymous access discriminants + type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. @@ -1410,6 +1437,20 @@ package Sem_Util is -- Return True if the loop has no side effect and can therefore be -- marked for removal. Return False if N is not a N_Loop_Statement. + subtype Static_Accessibility_Level_Kind + is Accessibility_Level_Kind range Object_Decl_Level + .. Zero_On_Dynamic_Level; + -- Restrict the reange of Accessibility_Level_Kind to be non-dynamic for + -- use in the static version of Accessibility_Level below. + + function Static_Accessibility_Level + (Expr : Node_Id; + Level : Static_Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Uint; + -- Overloaded version of Accessibility_Level which returns a universal + -- integer for use in compile-time checking. Note: Level is restricted to + -- be non-dynamic. + function Has_Overriding_Initialize (T : Entity_Id) return Boolean; -- Predicate to determine whether a controlled type has a user-defined -- Initialize primitive (and, in Ada 2012, whether that primitive is @@ -1531,6 +1572,11 @@ package Sem_Util is function In_Quantified_Expression (N : Node_Id) return Boolean; -- Returns true if the expression N occurs within a quantified expression + function In_Return_Value (Expr : Node_Id) return Boolean; + -- Returns true if the expression Expr occurs within a simple return + -- statement or is part of an assignment to the return object in an + -- extended return statement. + function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean; -- Returns True if N denotes a component or subcomponent in a record or -- array that has Reverse_Storage_Order. @@ -1872,6 +1918,9 @@ package Sem_Util is function Is_Entry_Declaration (Id : Entity_Id) return Boolean; -- Determine whether entity Id is the spec entity of an entry [family] + function Is_Explicitly_Aliased (N : Node_Id) return Boolean; + -- Determine if a given node N is an explicitly aliased formal parameter. + function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean; -- Check whether a function in a call is an expanded priority attribute, -- which is transformed into an Rtsfind call to Get_Ceiling. This expansion @@ -1984,6 +2033,9 @@ package Sem_Util is -- parameter of the current enclosing subprogram. -- Why are OUT parameters not considered here ??? + function Is_Master (N : Node_Id) return Boolean; + -- Determine if the given node N constitutes a finalization master + function Is_Name_Reference (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is a reference to a name. This is -- similar to Is_Object_Reference but returns True only if N can be renamed @@ -2144,11 +2196,15 @@ package Sem_Util is -- created for a single task type. function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - Scop : Entity_Id) return Boolean; + (Exp : Node_Id; + In_Return_Context : Boolean := False) return Boolean; -- Determines whether a dynamic check must be generated for explicitly -- aliased formals within a function Scop for the expression Exp. + -- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume + -- that Exp is within a return value which is useful for checking + -- expressions within discriminant associations of return objects. + -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a -- 'Access attribute reference within a return statement where the ultimate -- prefix is an aliased formal of Scop and that Scop returns an anonymous @@ -2648,9 +2704,6 @@ 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 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 -- rewrite and whether the pragma is generated from an aspect as the names -- 2.30.2