[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  <trojanek@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.

From-SVN: r260447

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f74cf3f2d7943f06245f5c3dacd37825b1f051f7..79f5759a4f682e0475aa17563ca99cc9a3685fac 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+2018-04-04  Piotr Trojanek  <trojanek@adacore.com>
+
+       * 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  <charlet@adacore.com>
 
        * exp_unst.adb (Unnest_Subprogram): Unnest all subprograms relevant for

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index fa0924f0310d232ea578f8f0e6cc05cd155426b9..4e9aa0890a9ac8a588a2674ac53a1ba627dab911 100644 (file)
--- 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 185cae90f526924a553bb0593eac8f6ade8f80b0..538fa9d60a2fd524d2f418f7407004655cefec12 100644 (file)
--- 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 6350f244309ef3bb55c55b7b20fdc6959f73938c..2f8af6662a7a5b7ce230c2bf0afb1ac9bac82e5b 100644 (file)
--- 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 41af7c949ea9387714d76a53c6b77ddd23116171..9302f1abb09cc30397931b2f353a000e94871b25 100644 (file)
--- 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 c9d902e3de76b85d1611f9e3b10df8d6e75678ad..21105635b12359dc7ae89a2c7cbd7e569cfea97e 100644 (file)
--- 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);