In some cases where a function result type has an access discriminant
part, Ada requires that the execution of a return statement include a
check that the access discriminant does not designate an object whose
accessibility level is too deep (Ada RM 6.5(21)). This check was being
incorrectly omitted in some cases where the discriminant value
designates a not-explicitly-aliased parameter of the function (or some
part thereof). Correct this omission.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_ch6.adb (Check_Return_Construct_Accessibility): Modify
generation of accessibility checks to be more consolidated and
get triggered properly in required cases.
* sem_util.adb (Accessibility_Level): Add extra check within
condition to handle aliased formals properly in more cases.diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -807,6 +807,7 @@ package body Sem_Ch6 is
Assoc_Expr : Node_Id;
Assoc_Present : Boolean := False;
+ Check_Cond : Node_Id;
Unseen_Disc_Count : Nat := 0;
Seen_Discs : Elist_Id;
Disc : Entity_Id;
@@ -1180,36 +1181,39 @@ package body Sem_Ch6 is
and then Present (Disc)
and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type
then
- -- Perform a static check first, if possible
+ -- Generate a dynamic check based on the extra accessibility of
+ -- the result or the scope.
+
+ Check_Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Accessibility_Level
+ (Expr => Assoc_Expr,
+ Level => Dynamic_Level,
+ In_Return_Context => True),
+ Right_Opnd => (if Present
+ (Extra_Accessibility_Of_Result
+ (Scope_Id))
+ then
+ Extra_Accessibility_Of_Result (Scope_Id)
+ else
+ Make_Integer_Literal
+ (Loc, Scope_Depth (Scope (Scope_Id)))));
+
+ Insert_Before_And_Analyze (Return_Stmt,
+ Make_Raise_Program_Error (Loc,
+ Condition => Check_Cond,
+ Reason => PE_Accessibility_Check_Failed));
+
+ -- If constant folding has happened on the condition for the
+ -- generated error, then warn about it being unconditional when
+ -- we know an error will be raised.
- if Static_Accessibility_Level
- (Expr => Assoc_Expr,
- Level => Zero_On_Dynamic_Level,
- In_Return_Context => True)
- > Scope_Depth (Scope (Scope_Id))
+ if Nkind (Check_Cond) = N_Identifier
+ and then Entity (Check_Cond) = Standard_True
then
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;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -628,9 +628,9 @@ package body Sem_Util is
-- caller.
if Is_Explicitly_Aliased (E)
- and then Level /= Dynamic_Level
- and then (In_Return_Value (Expr)
- or else In_Return_Context)
+ and then (In_Return_Context
+ or else (Level /= Dynamic_Level
+ and then In_Return_Value (Expr)))
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
