OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Further Ada 2020 work on accessibility checking

Browse Source 
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
This commit is contained in:
Justin Squirek 2020-09-02 14:20:55 -04:00 committed by Pierre-Marie de Rodat
parent 15e2ad005b
commit 66e97274ce
14 changed files with 939 additions and 585 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/ada/checks.adb
View File

@ -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));

10
gcc/ada/exp_ch3.adb
View File

@ -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)

67
gcc/ada/exp_ch4.adb
View File

@ -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;

5
gcc/ada/exp_ch5.adb
View File

@ -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

165
gcc/ada/exp_ch6.adb
View File

@ -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
-- 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.
-- 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;
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));
-- 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).
-- Otherwise get the level normally based on the call node
-- ???
else
Level := Accessibility_Level (Call_Node, Dynamic_Level);
while Nkind (Ancestor) = N_Qualified_Expression
loop
Ancestor := Parent (Ancestor);
end loop;
end if;
case Nkind (Ancestor) is
when N_Allocator =>
-- It may be possible that we are re-expanding an already
-- expanded call when are are dealing with dispatching ???
-- 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.
Level :=
New_Occurrence_Of
(Extra_Accessibility_Of_Result
(Return_Applies_To
(Return_Statement_Entity (Ancestor))), Loc);
end if;
when others =>
null;
end case;
if not Defer then
if not Present (Level) then
-- The "innermost master that evaluates the function call".
-- ??? - 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)?
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.

21
gcc/ada/exp_ch9.adb
View File

@ -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.

20
gcc/ada/sem_attr.adb
View File

@ -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

3
gcc/ada/sem_ch13.adb
View File

@ -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 "

42
gcc/ada/sem_ch4.adb
View File

@ -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

467
gcc/ada/sem_ch6.adb
View File

@ -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;
-- If we are looking at an aggregate instead of a function call we
-- can continue checking accessibility for the supplied
-- discriminant associations.
-- 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;
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
-- Do we cover extension aggregates correctly ???
if Nkind (Unqual) = N_Aggregate then
if Present (Expressions (Unqual)) then
Assoc := First (Expressions (Unqual));
else
Assoc := First (Component_Associations (Unqual));
end if;
-- There is an object declaration for the return object
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
else
return;
end if;
-- Otherwise the expression is not of interest ???
-- There are no supplied discriminants in the object declaration,
-- so get them from the type definition since they must be default
-- initialized.
-- Do we handle constrained subtypes correctly ???
elsif Nkind (Unqual) = N_Object_Declaration then
Assoc := First_Discriminant
(Etype (Object_Definition (Obj_Decl)));
else
return;
Assoc := First_Discriminant (Etype (Unqual));
end if;
-- 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.
else
return;
end if;
-- Move through the discriminants checking the accessibility level
-- of each co-extension's associated expression.
-- Obtain the discriminants so we know the actual type in case the
-- value of their associated expression gets implicitly converted.
Discr := First_Discriminant (R_Type);
while Present (Discr) loop
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
if No (Obj_Decl) then
pragma Assert (Nkind (Unqual) = N_Aggregate);
if Nkind (Assoc) = N_Attribute_Reference then
Expr := Assoc;
elsif Nkind (Assoc) in
N_Component_Association | N_Discriminant_Association
Disc := First_Discriminant (Etype (Unqual));
else
Disc := First_Discriminant
(Etype (Defining_Identifier (Obj_Decl)));
end if;
-- Loop through each of the discriminants and check each expression
-- associated with an anonymous access discriminant.
while Present (Assoc) and then Present (Disc) loop
-- Unwrap the associated expression
if Nkind (Assoc)
in N_Component_Association | N_Discriminant_Association
then
Assoc_Expr := Expression (Assoc);
elsif Nkind (Assoc) in N_Entity
and then Ekind (Assoc) = E_Discriminant
then
Assoc_Expr := Discriminant_Default_Value (Assoc);
else
Assoc_Expr := Assoc;
end if;
-- 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 Static_Accessibility_Level
(Expr => Assoc_Expr,
Level => Zero_On_Dynamic_Level,
In_Return_Context => True)
> Scope_Depth (Scope (Scope_Id))
then
Expr := Expression (Assoc);
else
Expr := Empty;
Error_Msg_N
("access discriminant in return object would be a dangling"
& " reference", Return_Stmt);
exit;
end if;
-- This anonymous access discriminant has an associated
-- expression which needs checking.
-- Otherwise, generate a dynamic check based on the extra
-- accessibility of the result.
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.
-- 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.
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.
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;
Obj := Original_Node (Prefix (Obj));
end loop;
if Nkind (Obj) = N_Selected_Component then
Obj := Selector_Name (Obj);
end if;
-- Check for renamings
pragma Assert (Is_Entity_Name (Obj));
if Present (Renamed_Object (Entity (Obj))) then
Obj := Renamed_Object (Entity (Obj));
else
exit;
end if;
end loop;
-- Do not check aliased formals statically
if Is_Formal (Entity (Obj))
and then (Is_Aliased (Entity (Obj))
or else Ekind (Etype (Entity (Obj))) =
E_Anonymous_Access_Type)
then
null;
-- Otherwise, handle the expression normally, avoiding the
-- special logic above, and call Object_Access_Level with
-- the original 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;
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;
Next_Discriminant (Discr);
-- Iterate over the discriminants
Disc := Next_Discriminant (Disc);
if not Is_List_Member (Assoc) then
Assoc := Empty;
exit;
else
Nlists.Next (Assoc);
end if;
-- After aggregate expressions, examine component associations if
-- present.
if No (Assoc) then
if Present (Agg)
and then Process_Exprs
and then Present (Component_Associations (Agg))
then
Assoc := First (Component_Associations (Agg));
Process_Exprs := False;
else
exit;
end if;
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.
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
(Extra_Accessibility (Form), Form);
end if;
Next_Formal (Form);
end loop;
-- Generate the minimum accessibility level object for the
-- function's Extra_Accessibility_Of_Result.
-- A31b : constant natural := natural'min (2, funcL);
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));
-- 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;

3
gcc/ada/sem_ch9.adb
View File

@ -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))

35
gcc/ada/sem_res.adb
View File

@ -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

576
gcc/ada/sem_util.adb
View File

@ -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,54 +389,89 @@ 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.
-- Accessibility_Level 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 ???
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);
-- Detect an expanded implicit conversion, typically this
-- occurs on implicitly converted actuals in calls.
-- Does this catch all implicit conversions ???
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."
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;
-- 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).
if No (Par) or else Nkind (Par) = N_Function_Call then
return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
end if;
-- The function call was used to initialize the entire object, so
-- the master is "that of the object."
-- Assignment statements are handled in a similar way in
-- accordance to the left-hand part. However, strictly speaking,
-- this is illegal according to the RM, but this change is needed
@ -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 --
--------------------

77
gcc/ada/sem_util.ads
View File

@ -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