From 689751d2f7ae12bd34637801860a766d1196d960 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 21 May 2018 14:50:23 +0000 Subject: [PATCH] [Ada] Only allow Has_Discriminants on type entities 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. 2018-05-21 Piotr Trojanek 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. From-SVN: r260447 --- gcc/ada/ChangeLog | 14 ++++++++++++++ gcc/ada/einfo.adb | 4 ++-- gcc/ada/sem_ch13.adb | 4 ++-- gcc/ada/sem_ch3.adb | 8 +++++++- gcc/ada/sem_ch7.adb | 5 ++++- gcc/ada/sem_util.adb | 8 ++++++-- 6 files changed, 35 insertions(+), 8 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f74cf3f2d79..79f5759a4f6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2018-04-04 Piotr Trojanek + + * 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. + 2018-04-04 Arnaud Charlet * exp_unst.adb (Unnest_Subprogram): Unnest all subprograms relevant for diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index fa0924f0310..4e9aa0890a9 100644 --- a/gcc/ada/einfo.adb +++ b/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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 185cae90f52..538fa9d60a2 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6350f244309..2f8af6662a7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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 diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 41af7c949ea..9302f1abb09 100644 --- a/gcc/ada/sem_ch7.adb +++ b/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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c9d902e3de7..21105635b12 100644 --- a/gcc/ada/sem_util.adb +++ b/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); -- 2.30.2