ada: Fix internal error on aggregates of self-referencing types

The front-end contains a specific mechanism to deal with aggregates of
self-referencing types by means of the Has_Self_Reference flag, which is
supposed to be set during semantic analysis and used during expansion.

The problem is that the first part overlooks aggregates of derived types
which implicitly contain references to an ancestor type (the second part
uses a broader condition but it is effectively guarded by the first one).

This changes both parts to use the same condition based on the Is_Ancestor
predicate, which seems to implement the expected semantic in this case.

gcc/ada/
	* sem_type.ads (Is_Ancestor): Remove mention of tagged type.
	* exp_aggr.adb: Add with and use clauses for Sem_Type.
	(Build_Record_Aggr_Code.Replace_Type): Call Is_Ancestor to spot
	self-references to the type of the aggregate.
	* sem_aggr.adb (Resolve_Record_Aggregate.Add_Discriminant_Values):
	Likewise.

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index d922c3bf1a443a3c51af8baae04fdf2a7762ca38..4c8dcae9d83ff08ec130793a189905719735892c 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -61,6 +61,7 @@ with Sem_Ch13;       use Sem_Ch13;
 with Sem_Eval;       use Sem_Eval;
 with Sem_Mech;       use Sem_Mech;
 with Sem_Res;        use Sem_Res;
+with Sem_Type;       use Sem_Type;
 with Sem_Util;       use Sem_Util;
                      use Sem_Util.Storage_Model_Support;
 with Sinfo;          use Sinfo;
@@ -2760,19 +2761,21 @@ package body Exp_Aggr is
 
       function Replace_Type (Expr : Node_Id) return Traverse_Result is
       begin
-         --  Note regarding the Root_Type test below: Aggregate components for
+         --  Note about the Is_Ancestor test below: aggregate components for
          --  self-referential types include attribute references to the current
-         --  instance, of the form: Typ'access, etc.. These references are
+         --  instance, of the form: Typ'access, etc. These references are
          --  rewritten as references to the target of the aggregate: the
          --  left-hand side of an assignment, the entity in a declaration,
-         --  or a temporary. Without this test, we would improperly extended
-         --  this rewriting to attribute references whose prefix was not the
+         --  or a temporary. Without this test, we would improperly extend
+         --  this rewriting to attribute references whose prefix is not the
          --  type of the aggregate.
 
          if Nkind (Expr) = N_Attribute_Reference
            and then Is_Entity_Name (Prefix (Expr))
            and then Is_Type (Entity (Prefix (Expr)))
-           and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
+           and then
+             Is_Ancestor
+               (Entity (Prefix (Expr)), Etype (N), Use_Full_View => True)
          then
             if Is_Entity_Name (Lhs) then
                Rewrite (Prefix (Expr), New_Occurrence_Of (Entity (Lhs), Loc));

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 39189463871e02c50d06348f2f0f291733ce6ade..5bfbde5052b83e7e5ac3604c7d52ddd445b4e44f 100644 (file)
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -4546,14 +4546,17 @@ package body Sem_Aggr is
                Component_Associations (New_Aggr));
 
             --  If the discriminant constraint is a current instance, mark the
-            --  current aggregate so that the self-reference can be expanded
-            --  later. The constraint may refer to the subtype of aggregate, so
-            --  use base type for comparison.
+            --  current aggregate so that the self-reference can be expanded by
+            --  Build_Record_Aggr_Code.Replace_Type later.
 
             if Nkind (Discr_Val) = N_Attribute_Reference
               and then Is_Entity_Name (Prefix (Discr_Val))
               and then Is_Type (Entity (Prefix (Discr_Val)))
-              and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val))
+              and then
+                Is_Ancestor
+                  (Entity (Prefix (Discr_Val)),
+                   Etype (N),
+                   Use_Full_View => True)
             then
                Set_Has_Self_Reference (N);
             end if;

diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 6bc776a7319e24be98f2c67dd81bc511d5bf104b..e867885dac62a0e2cffa27b71dd5e32ff0a4aa87 100644 (file)
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -222,10 +222,9 @@ package Sem_Type is
      (T1            : Entity_Id;
       T2            : Entity_Id;
       Use_Full_View : Boolean := False) return Boolean;
-   --  T1 is a tagged type (not class-wide). Verify that it is one of the
-   --  ancestors of type T2 (which may or not be class-wide). If Use_Full_View
-   --  is True then the full-view of private parents is used when climbing
-   --  through the parents of T2.
+   --  T1 is a type (not class-wide). Verify that it is one of the ancestors of
+   --  type T2 (which may or not be class-wide). If Use_Full_View is True, then
+   --  the full view of private parents is used when climbing T2's parents.
    --
    --  Note: For analysis purposes the flag Use_Full_View must be set to False
    --  (otherwise we break the privacy contract since this routine returns true