When determining the legality of a generic parameter association
for a formal type derived from a type that imposes a discriminant
constraint, the compiler was incorrectly concluding that an actual
type that inherits the constraint of the formal's parent type was
not compatible with the formal type (due to not recognizing the
constraints as statically matching). The comparison of constraints
was not taking into account the possibility of inherited constraints
and the fact that the compiler makes a copy of the parent type's
constraint. The fix is to traverse the chain of ancestors to locate
the nearest explicit constraint from which a constraint may be
inherited.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_eval.adb (Subtypes_Statically_Match): Retrieve
discriminant constraints from the two types via new function
Original_Discriminant_Constraint rather than
Discriminant_Constraint.
(Original_Discriminant_Constraint): New function to locate the
nearest explicit discriminant constraint associated with a type
that may possibly have inherited a constraint from an ancestor
type.diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -6554,8 +6554,65 @@ package body Sem_Eval is
end if;
declare
- DL1 : constant Elist_Id := Discriminant_Constraint (T1);
- DL2 : constant Elist_Id := Discriminant_Constraint (T2);
+
+ function Original_Discriminant_Constraint
+ (Typ : Entity_Id) return Elist_Id;
+ -- Returns Typ's discriminant constraint, or if the constraint
+ -- is inherited from an ancestor type, then climbs the parent
+ -- types to locate and return the constraint farthest up the
+ -- parent chain that Typ's constraint is ultimately inherited
+ -- from (stopping before a parent that doesn't impose a constraint
+ -- or a parent that has new discriminants). This ensures a proper
+ -- result from the equality comparison of Elist_Ids below (as
+ -- otherwise, derived types that inherit constraints may appear
+ -- to be unequal, because each level of derivation can have its
+ -- own copy of the constraint).
+
+ function Original_Discriminant_Constraint
+ (Typ : Entity_Id) return Elist_Id
+ is
+ begin
+ if not Has_Discriminants (Typ) then
+ return No_Elist;
+
+ -- If Typ is not a derived type, then directly return the
+ -- its constraint.
+
+ elsif not Is_Derived_Type (Typ) then
+ return Discriminant_Constraint (Typ);
+
+ -- If the parent type doesn't have discriminants, doesn't
+ -- have a constraint, or has new discriminants, then stop
+ -- and return Typ's constraint.
+
+ elsif not Has_Discriminants (Etype (Typ))
+
+ -- No constraint on the parent type
+
+ or else not Present (Discriminant_Constraint (Etype (Typ)))
+ or else Is_Empty_Elmt_List
+ (Discriminant_Constraint (Etype (Typ)))
+
+ -- The parent type defines new discriminants
+
+ or else
+ (Is_Base_Type (Etype (Typ))
+ and then Present (Discriminant_Specifications
+ (Parent (Etype (Typ)))))
+ then
+ return Discriminant_Constraint (Typ);
+
+ -- Otherwise, make a recursive call on the parent type
+
+ else
+ return Original_Discriminant_Constraint (Etype (Typ));
+ end if;
+ end Original_Discriminant_Constraint;
+
+ -- Local variables
+
+ DL1 : constant Elist_Id := Original_Discriminant_Constraint (T1);
+ DL2 : constant Elist_Id := Original_Discriminant_Constraint (T2);
DA1 : Elmt_Id;
DA2 : Elmt_Id;
