[Ada] Fix internal error on declaration of derived discriminated record type
Commit Message
When the parent type has a variant part and the derived type is also
discriminated but statically selects a variant, the initialization
routine of the derived type may attempt to access components of other
variants that are no longer present.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_ch4.adb (Handle_Changed_Representation): Simplify and fix
thinko in the loop building the constraints for discriminants.
* exp_ch5.adb (Make_Component_List_Assign): Try also to extract
discriminant values for a derived type.
@@ -11745,31 +11745,24 @@ package body Exp_Ch4 is
declare
Stored : constant Elist_Id :=
Stored_Constraint (Operand_Type);
-
- Elmt : Elmt_Id;
+ -- Stored constraints of the operand. If present, they
+ -- correspond to the discriminants of the parent type.
Disc_O : Entity_Id;
-- Discriminant of the operand type. Its value in the
-- object is captured in a selected component.
- Disc_S : Entity_Id;
- -- Stored discriminant of the operand. If present, it
- -- corresponds to a constrained discriminant of the
- -- parent type.
-
Disc_T : Entity_Id;
-- Discriminant of the target type
+ Elmt : Elmt_Id;
+
begin
- Disc_T := First_Discriminant (Target_Type);
Disc_O := First_Discriminant (Operand_Type);
- Disc_S := First_Stored_Discriminant (Operand_Type);
-
- if Present (Stored) then
- Elmt := First_Elmt (Stored);
- else
- Elmt := No_Elmt; -- init to avoid warning
- end if;
+ Disc_T := First_Discriminant (Target_Type);
+ Elmt := (if Present (Stored)
+ then First_Elmt (Stored)
+ else No_Elmt);
Cons := New_List;
while Present (Disc_T) loop
@@ -11784,8 +11777,11 @@ package body Exp_Ch4 is
Make_Identifier (Loc, Chars (Disc_O))));
Next_Discriminant (Disc_O);
- elsif Present (Disc_S) then
+ elsif Present (Elmt) then
Append_To (Cons, New_Copy_Tree (Node (Elmt)));
+ end if;
+
+ if Present (Elmt) then
Next_Elmt (Elmt);
end if;
@@ -1848,27 +1848,14 @@ package body Exp_Ch5 is
CI : constant List_Id := Component_Items (CL);
VP : constant Node_Id := Variant_Part (CL);
- Constrained_Typ : Entity_Id;
- Alts : List_Id;
- DC : Node_Id;
- DCH : List_Id;
- Expr : Node_Id;
- Result : List_Id;
- V : Node_Id;
+ Alts : List_Id;
+ DC : Node_Id;
+ DCH : List_Id;
+ Expr : Node_Id;
+ Result : List_Id;
+ V : Node_Id;
begin
- -- Try to find a constrained type to extract discriminant values
- -- from, so that the case statement built below gets an
- -- opportunity to be folded by Expand_N_Case_Statement.
-
- if U_U or else Is_Constrained (Etype (Rhs)) then
- Constrained_Typ := Etype (Rhs);
- elsif Is_Constrained (Etype (Expression (N))) then
- Constrained_Typ := Etype (Expression (N));
- else
- Constrained_Typ := Empty;
- end if;
-
Result := Make_Field_Assigns (CI);
if Present (VP) then
@@ -1890,13 +1877,38 @@ package body Exp_Ch5 is
Next_Non_Pragma (V);
end loop;
- if Present (Constrained_Typ) then
+ -- Try to find a constrained type or a derived type to extract
+ -- discriminant values from, so that the case statement built
+ -- below can be folded by Expand_N_Case_Statement.
+
+ if U_U or else Is_Constrained (Etype (Rhs)) then
+ Expr :=
+ New_Copy (Get_Discriminant_Value (
+ Entity (Name (VP)),
+ Etype (Rhs),
+ Discriminant_Constraint (Etype (Rhs))));
+
+ elsif Is_Constrained (Etype (Expression (N))) then
Expr :=
New_Copy (Get_Discriminant_Value (
Entity (Name (VP)),
- Constrained_Typ,
- Discriminant_Constraint (Constrained_Typ)));
+ Etype (Expression (N)),
+ Discriminant_Constraint (Etype (Expression (N)))));
+
+ elsif Is_Derived_Type (Etype (Rhs))
+ and then Present (Stored_Constraint (Etype (Rhs)))
+ then
+ Expr :=
+ New_Copy (Get_Discriminant_Value (
+ Corresponding_Record_Component (Entity (Name (VP))),
+ Etype (Etype (Rhs)),
+ Stored_Constraint (Etype (Rhs))));
+
else
+ Expr := Empty;
+ end if;
+
+ if No (Expr) or else not Compile_Time_Known_Value (Expr) then
Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),