From: Eric Botcazou Date: Fri, 7 Jan 2022 23:48:58 +0000 (+0100) Subject: [Ada] Fix internal error on declaration of derived discriminated record type X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=692a4bf88c5a4743bb5dca47b59a73a83add0fae;p=platform%2Fupstream%2Fgcc.git [Ada] Fix internal error on declaration of derived discriminated record type 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. --- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 2506c67..09e734d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index b78c127..710db66 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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),