-- circularity issues in Gigi. We create an incomplete type for the record
-- declaration, which is the designated type of the anonymous access.
+ procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id);
+ -- Check that, if a new discriminant is used in a constraint defining the
+ -- parent subtype of a derivation, its subtype is statically compatible
+ -- with the subtype of the corresponding parent discriminant (RM 3.7(15)).
+
procedure Check_Delta_Expression (E : Node_Id);
-- Check that the expression represented by E is suitable for use as a
-- delta expression, i.e. it is of real type and is static.
Error_Msg_NE
("new discriminant& must constrain old one", N, New_Disc);
- elsif not
- Subtypes_Statically_Compatible
- (Etype (New_Disc),
- Etype (Corresponding_Discriminant (New_Disc)))
- then
- Error_Msg_NE
- ("& not statically compatible with parent discriminant",
- N, New_Disc);
+ -- If a new discriminant is used in the constraint, then its
+ -- subtype must be statically compatible with the subtype of
+ -- the parent discriminant (RM 3.7(15)).
+
+ else
+ Check_Constraining_Discriminant
+ (New_Disc, Corresponding_Discriminant (New_Disc));
end if;
Next_Discriminant (New_Disc);
end if;
-- If a new discriminant is used in the constraint, then its
- -- subtype must be statically compatible with the parent
- -- discriminant's subtype (3.7(15)).
-
- -- However, if the record contains an array constrained by
- -- the discriminant but with some different bound, the compiler
- -- tries to create a smaller range for the discriminant type.
- -- (See exp_ch3.Adjust_Discriminants). In this case, where
- -- the discriminant type is a scalar type, the check must use
- -- the original discriminant type in the parent declaration.
-
- declare
- Corr_Disc : constant Entity_Id :=
- Corresponding_Discriminant (Discrim);
- Disc_Type : constant Entity_Id := Etype (Discrim);
- Corr_Type : Entity_Id;
+ -- subtype must be statically compatible with the subtype of
+ -- the parent discriminant (RM 3.7(15)).
- begin
- if Present (Corr_Disc) then
- if Is_Scalar_Type (Disc_Type) then
- Corr_Type :=
- Entity (Discriminant_Type (Parent (Corr_Disc)));
- else
- Corr_Type := Etype (Corr_Disc);
- end if;
-
- if not
- Subtypes_Statically_Compatible (Disc_Type, Corr_Type)
- then
- Error_Msg_N
- ("subtype must be compatible "
- & "with parent discriminant",
- Discrim);
- end if;
- end if;
- end;
+ if Present (Corresponding_Discriminant (Discrim)) then
+ Check_Constraining_Discriminant
+ (Discrim, Corresponding_Discriminant (Discrim));
+ end if;
Next_Discriminant (Discrim);
end loop;
end loop;
end Check_Completion;
+ -------------------------------------
+ -- Check_Constraining_Discriminant --
+ -------------------------------------
+
+ procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id)
+ is
+ New_Type : constant Entity_Id := Etype (New_Disc);
+ Old_Type : Entity_Id;
+
+ begin
+ -- If the record type contains an array constrained by the discriminant
+ -- but with some different bound, the compiler tries to create a smaller
+ -- range for the discriminant type (see exp_ch3.Adjust_Discriminants).
+ -- In this case, where the discriminant type is a scalar type, the check
+ -- must use the original discriminant type in the parent declaration.
+
+ if Is_Scalar_Type (New_Type) then
+ Old_Type := Entity (Discriminant_Type (Parent (Old_Disc)));
+ else
+ Old_Type := Etype (Old_Disc);
+ end if;
+
+ if not Subtypes_Statically_Compatible (New_Type, Old_Type) then
+ Error_Msg_N
+ ("subtype must be statically compatible with parent discriminant",
+ New_Disc);
+
+ if not Predicates_Compatible (New_Type, Old_Type) then
+ Error_Msg_N
+ ("\subtype predicate is not compatible with parent discriminant",
+ New_Disc);
+ end if;
+ end if;
+ end Check_Constraining_Discriminant;
+
------------------------------------
-- Check_CPP_Type_Has_No_Defaults --
------------------------------------
end if;
end Out_Of_Range;
+ ---------------------------
+ -- Predicates_Compatible --
+ ---------------------------
+
+ function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean is
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean;
+ -- Return True if the rep item for Nam is either absent on T2 or also
+ -- applies to T1.
+
+ -------------------------------
+ -- T2_Rep_Item_Applies_To_T1 --
+ -------------------------------
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean is
+ Rep_Item : constant Node_Id := Get_Rep_Item (T2, Nam);
+
+ begin
+ return No (Rep_Item) or else Get_Rep_Item (T1, Nam) = Rep_Item;
+ end T2_Rep_Item_Applies_To_T1;
+
+ -- Start of processing for Predicates_Compatible
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return True;
+
+ -- If T2 has no predicates, there is no compatibility issue
+
+ elsif not Has_Predicates (T2) then
+ return True;
+
+ -- T2 has predicates, if T1 has none then we defer to the static check
+
+ elsif not Has_Predicates (T1) then
+ null;
+
+ -- Both T2 and T1 have predicates, check that all predicates that apply
+ -- to T2 apply also to T1 (RM 4.9.1(9/3)).
+
+ elsif T2_Rep_Item_Applies_To_T1 (Name_Static_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Dynamic_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Predicate)
+ then
+ return True;
+ end if;
+
+ -- Implement the static check prescribed by RM 4.9.1(10/3)
+
+ if Is_Static_Subtype (T1) and then Is_Static_Subtype (T2) then
+ -- We just need to query Interval_Lists for discrete types
+
+ if Is_Discrete_Type (T1) and then Is_Discrete_Type (T2) then
+ declare
+ Interval_List1 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T1);
+ Interval_List2 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T2);
+ begin
+ return Interval_Lists.Is_Subset (Interval_List1, Interval_List2)
+ and then not (Has_Predicates (T1)
+ and then not Predicate_Checks_Suppressed (T2)
+ and then Predicate_Checks_Suppressed (T1));
+ end;
+
+ else
+ -- TBD: Implement Interval_Lists for real types
+
+ return False;
+ end if;
+
+ -- If either subtype is not static, the predicates are not compatible
+
+ else
+ return False;
+ end if;
+ end Predicates_Compatible;
+
----------------------
-- Predicates_Match --
----------------------
Formal_Derived_Matching : Boolean := False) return Boolean
is
begin
+ -- A type is always statically compatible with itself
+
+ if T1 = T2 then
+ return True;
+
+ -- Not compatible if predicates are not compatible
+
+ elsif not Predicates_Compatible (T1, T2) then
+ return False;
+
-- Scalar types
- if Is_Scalar_Type (T1) then
+ elsif Is_Scalar_Type (T1) then
-- Definitely compatible if we match
projects / gcc.git / commitdiff