[Ada] Missing accessibility check when returning discriminated types

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
index a316214f22324ba4a38aed1f267f7834c45765a4..14869180d9b67934ce35e8aa1c56b08f7c058505 100644 (file)
--- 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
index b8ed8a4bcb9297683ac6d81809f82fc7e4d69765..db4d55a35302ef70d5f7cdefa831ebf40191102f 100644 (file)
--- 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));