diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 57 |
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); |