[Ada] Ada 2020 AI12-0401: Renaming of qualified expression of variable

gcc/ada/

	* sem_ch8.adb (Analyze_Object_Renaming): Update check for
	AI12-0401.

1 files changed, 48 insertions, 9 deletions

diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index cf5b790..817cba9 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -759,6 +759,7 @@ package body Sem_Ch8 is
       Dec           : Node_Id;
       T             : Entity_Id;
       T2            : Entity_Id;
+      Q             : Node_Id;
 
       procedure Check_Constrained_Object;
       --  If the nominal type is unconstrained but the renamed object is
@@ -1074,17 +1075,55 @@ package body Sem_Ch8 is
          --  Check against AI12-0401 here before Resolve may rewrite Nam and
          --  potentially generate spurious warnings.
 
+         --   In the case where the object_name is a qualified_expression with
+         --   a nominal subtype T and whose expression is a name that denotes
+         --   an object Q:
+         --    * if T is an elementary subtype, then:
+         --      * Q shall be a constant other than a dereference of an access
+         --        type; or
+         --      * the nominal subtype of Q shall be statically compatible with
+         --        T; or
+         --      * T shall statically match the base subtype of its type if
+         --        scalar, or the first subtype of its type if an access type.
+         --    * if T is a composite subtype, then Q shall be known to be
+         --      constrained or T shall statically match the first subtype of
+         --      its type.
+
          if Nkind (Nam) = N_Qualified_Expression
-           and then Is_Variable (Expression (Nam))
-           and then not
-             (Subtypes_Statically_Match (T, Etype (Expression (Nam)))
-                or else
-              Subtypes_Statically_Match (Base_Type (T), Etype (Nam)))
+           and then Is_Object_Reference (Expression (Nam))
          then
-            Error_Msg_N
-              ("subtype of renamed qualified expression does not " &
-               "statically match", N);
-            return;
+            Q := Expression (Nam);
+
+            if (Is_Elementary_Type (T)
+                  and then
+                not ((not Is_Variable (Q)
+                       and then Nkind (Q) /= N_Explicit_Dereference)
+                      or else Subtypes_Statically_Compatible (Etype (Q), T)
+                      or else (Is_Scalar_Type (T)
+                                and then Subtypes_Statically_Match
+                                           (T, Base_Type (T)))
+                      or else (Is_Access_Type (T)
+                                and then Subtypes_Statically_Match
+                                           (T, First_Subtype (T)))))
+              or else (Is_Composite_Type (T)
+                         and then
+
+                       --  If Q is an aggregate, Is_Constrained may not be set
+                       --  yet and its type may not be resolved yet.
+                       --  This doesn't quite correspond to the complex notion
+                       --  of "known to be constrained" but this is good enough
+                       --  for a rule which is in any case too complex.
+
+                       not (Is_Constrained (Etype (Q))
+                             or else Nkind (Q) = N_Aggregate
+                             or else Subtypes_Statically_Match
+                                       (T, First_Subtype (T))))
+            then
+               Error_Msg_N
+                 ("subtype of renamed qualified expression does not " &
+                  "statically match", N);
+               return;
+            end if;
          end if;
 
          Resolve (Nam, T);