[COMMITTED] ada: Fix internal error on aggregates of self-referencing types
Checks
Commit Message
From: Eric Botcazou <ebotcazou@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 13 ++++++++-----
gcc/ada/sem_aggr.adb | 11 +++++++----
gcc/ada/sem_type.ads | 7 +++----
3 files changed, 18 insertions(+), 13 deletions(-)
@@ -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));
@@ -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;
@@ -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