procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Fix internal error on declaration of derived discriminated record type

Browse source 
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.

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.
This commit is contained in:
Eric Botcazou 2022-01-08 00:48:58 +01:00 • committed by Pierre-Marie de Rodat
parent 5081e9205a
commit 692a4bf88c
2 changed files with 47 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
gcc/ada/exp_ch4.adb
View file

@ -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
begin
Disc_T := First_Discriminant (Target_Type);
Disc_O := First_Discriminant (Operand_Type);
Disc_S := First_Stored_Discriminant (Operand_Type);
Elmt : Elmt_Id;
if Present (Stored) then
Elmt := First_Elmt (Stored);
else
Elmt := No_Elmt; -- init to avoid warning
end if;
begin
Disc_O := First_Discriminant (Operand_Type);
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;

56
gcc/ada/exp_ch5.adb
View file

@ -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)),
Constrained_Typ,
Discriminant_Constraint (Constrained_Typ)));
Etype (Rhs),
Discriminant_Constraint (Etype (Rhs))));
elsif Is_Constrained (Etype (Expression (N))) then
Expr :=
New_Copy (Get_Discriminant_Value (
Entity (Name (VP)),
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),