ada: Implement accessibility legality check for discriminated function result.

If a function result type has an access discriminant, then we already
generate a run-time accessibility check for a return statement. But if
we know statically that the check (if executed) is going to fail, then
that should be rejected at compile-time as a violation of RM 6.5(5.9).
Add this additional compile-time check.

gcc/ada/ChangeLog:

	* exp_ch6.adb (Apply_Access_Discrims_Accessibility_Check): If the
	accessibility level being checked is known statically, then
	statically check it against the level of the function being
	returned from.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index eb7422c8c7a81569b14350f7d6b215daa36c7749..0fd668413ac0183a31eb92f750ee6dbc5247c749 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -921,7 +921,8 @@ package body Exp_Ch6 is
      --  in accessibility.adb (which can cause the extra formal parameter
      --  needed for the check(s) generated here to be missing in the case
      --  of a tagged result type); this is a workaround and can
-     --  prevent generation of a required check.
+     --  prevent generation of a required check (or even a required
+     --  legality check - see "statically too deep" check below).
 
       if No (Extra_Accessibility_Of_Result (Func)) then
          return;
@@ -969,6 +970,15 @@ package body Exp_Ch6 is
                     Accessibility_Level (Discr_Exp, Level => Dynamic_Level);
                   Analyze (Discrim_Level);
 
+                  if Nkind (Discrim_Level) = N_Integer_Literal
+                    and then Intval (Discrim_Level) > Scope_Depth (Func)
+                  then
+                     Error_Msg_N
+                        ("level of type of access discriminant value of "
+                         & "return expression is statically too deep",
+                         Enclosing_Declaration_Or_Statement (Exp));
+                  end if;
+
                   Insert_Action (Exp,
                     Make_Raise_Program_Error (Loc,
                       Condition =>