This patch enforces what the comment for Has_Discriminant says:
-- Has_Discriminants (Flag5)
-- Defined in all types and subtypes.
to avoid semantically undefined calls on non-type entities. It also adapts
other routines to respect this comment.
No user-visible impact.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-21 Piotr Trojanek <troja...@adacore.com>
gcc/ada/
* einfo.adb (Has_Discriminants): Stronger assertion.
(Set_Has_Discriminants): Stronger assertion.
* sem_ch13.adb (Push_Scope_And_Install_Discriminants): Adapt to respect
the stronger assertion on Has_Discriminant.
(Uninstall_Discriminants_And_Pop_Scope): Same as above.
* sem_util.adb (New_Copy_Tree): Same as above.
* sem_ch7.adb (Generate_Parent_References): Prevent calls to
Has_Discriminant on non-type entities that might happen when the
compiled code has errors.
* sem_ch3.adb (Derived_Type_Declaration): Only call
Set_Has_Discriminant on type entities.--- gcc/ada/einfo.adb
+++ gcc/ada/einfo.adb
@@ -1567,7 +1567,7 @@ package body Einfo is
function Has_Discriminants (Id : E) return B is
begin
- pragma Assert (Nkind (Id) in N_Entity);
+ pragma Assert (Is_Type (Id));
return Flag5 (Id);
end Has_Discriminants;
@@ -4730,7 +4730,7 @@ package body Einfo is
procedure Set_Has_Discriminants (Id : E; V : B := True) is
begin
- pragma Assert (Nkind (Id) in N_Entity);
+ pragma Assert (Is_Type (Id));
Set_Flag5 (Id, V);
end Set_Has_Discriminants;
--- gcc/ada/sem_ch13.adb
+++ gcc/ada/sem_ch13.adb
@@ -12307,7 +12307,7 @@ package body Sem_Ch13 is
procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is
begin
- if Has_Discriminants (E) then
+ if Is_Type (E) and then Has_Discriminants (E) then
Push_Scope (E);
-- Make the discriminants visible for type declarations and protected
@@ -13491,7 +13491,7 @@ package body Sem_Ch13 is
procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is
begin
- if Has_Discriminants (E) then
+ if Is_Type (E) and then Has_Discriminants (E) then
Uninstall_Discriminants (E);
Pop_Scope;
end if;
--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -16664,7 +16664,13 @@ package body Sem_Ch3 is
Error_Msg_N
("elementary or array type cannot have discriminants",
Defining_Identifier (First (Discriminant_Specifications (N))));
- Set_Has_Discriminants (T, False);
+
+ -- Unset Has_Discriminants flag to prevent cascaded errors, but
+ -- only if we are not already processing a malformed syntax tree.
+
+ if Is_Type (T) then
+ Set_Has_Discriminants (T, False);
+ end if;
-- The type is allowed to have discriminants
--- gcc/ada/sem_ch7.adb
+++ gcc/ada/sem_ch7.adb
@@ -1399,10 +1399,13 @@ package body Sem_Ch7 is
-- We are looking at an incomplete or private type declaration
-- with a known_discriminant_part whose full view is an
- -- Unchecked_Union.
+ -- Unchecked_Union. The seemingly useless check with Is_Type
+ -- prevents cascaded errors when routines defined only for type
+ -- entities are called with non-type entities.
if Nkind_In (Decl, N_Incomplete_Type_Declaration,
N_Private_Type_Declaration)
+ and then Is_Type (Defining_Identifier (Decl))
and then Has_Discriminants (Defining_Identifier (Decl))
and then Present (Full_View (Defining_Identifier (Decl)))
and then
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -19392,7 +19392,9 @@ package body Sem_Util is
begin
-- Discriminant_Constraint
- if Has_Discriminants (Base_Type (Id)) then
+ if Is_Type (Id)
+ and then Has_Discriminants (Base_Type (Id))
+ then
Set_Discriminant_Constraint (Id, Elist_Id (
Copy_Field_With_Replacement
(Field => Union_Id (Discriminant_Constraint (Id)),
@@ -19849,7 +19851,9 @@ package body Sem_Util is
-- Discriminant_Constraint
- if Has_Discriminants (Base_Type (Id)) then
+ if Is_Type (Id)
+ and then Has_Discriminants (Base_Type (Id))
+ then
Visit_Field
(Field => Union_Id (Discriminant_Constraint (Id)),
Semantic => True);
