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.
-- 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));
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,
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 :=
-- 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)
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;
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
-- 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));
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;
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
- Dynamic_Accessibility_Level (Rhs),
+ Accessibility_Level (Rhs, Dynamic_Level),
Right_Opnd =>
Make_Integer_Literal (Loc,
Intval =>
(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
New_Occurrence_Of
(Lvl, Loc),
Expression =>
- Dynamic_Accessibility_Level
- (Expression (Res_Assn))));
+ Accessibility_Level
+ (Expression (Res_Assn), Dynamic_Level)));
end if;
end Expand_Branch;
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);
else
Add_Extra_Actual
- (Expr => Dynamic_Accessibility_Level (Prev),
+ (Expr => Accessibility_Level (Prev, Dynamic_Level),
EF => Extra_Accessibility (Formal));
end if;
end if;
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;
-- 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
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.
Conc_Typ : Entity_Id;
Concval : Node_Id;
Ename : Node_Id;
+ Enc_Subp : Entity_Id;
Index : Node_Id;
Old_Typ : Entity_Id;
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.
-- 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
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;
-- 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
-- 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 "
Nam : Node_Id;
X : Interp_Index;
It : Interp;
- Nam_Ent : Entity_Id;
+ Nam_Ent : Entity_Id := Empty;
Success : Boolean := False;
Deref : Boolean := False;
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
------------------------------------------
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;
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;
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.
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;
-- 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
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 --
-------------------------------------
-- 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;
-- 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
-- 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;
-- 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))
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;
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);
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",
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",
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
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
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
-- 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;
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.
-- 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.
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)
-- among other things. These cases are detected properly ???
while Present (Node_Par) loop
+
if Present (Defining_Entity
(Node_Par, Empty_On_Errors => True))
then
-- 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
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;
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
-- 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,
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
-- (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
-- 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
-- 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
-- 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
return New_Occurrence_Of
(Init_Proc_Level_Formal (Current_Scope), Loc);
- -- Extra accessibility has not been added yet, but the formal
- -- needs one. So return Standard_Standard ???
-
- elsif Ekind (Etype (E)) = E_Anonymous_Access_Type
- and then Static
- then
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
-
-- Current instance of the type is deeper than that of the type
-- according to RM 3.10.2 (21).
elsif 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
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)));
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
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
-- Otherwise, recurse deeper
else
- return Accessibility_Level_Helper (Prefix (E), Static);
+ return Accessibility_Level (Prefix (E));
end if;
-- Type conversions
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.
-- 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
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 --
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);
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);
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 --
------------------------
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
end if;
return Extra_Accessibility (E);
- end Get_Accessibility;
+ end Get_Dynamic_Accessibility;
------------------------
-- Get_Actual_Subtype --
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 --
------------------------------
(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 --
----------------------------
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 --
---------------------
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 --
-----------------------
--------------------------------------
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
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;
-- 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;
-----------------------------
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 --
--------------------
-- 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
-- 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.
-- 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.
-- 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.
-- 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
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.
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
-- 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
-- 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
-- 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
projects / gcc.git / commitdiff