From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id F043B385627A; Mon, 9 May 2022 09:31:19 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org F043B385627A MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-187] [Ada] Fix internal error on declaration of derived discriminated record type X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 5081e9205a6f12c41bdd5a7d630a732120fb4e92 X-Git-Newrev: 692a4bf88c5a4743bb5dca47b59a73a83add0fae Message-Id: <20220509093119.F043B385627A@sourceware.org> Date: Mon, 9 May 2022 09:31:19 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 09 May 2022 09:31:20 -0000 https://gcc.gnu.org/g:692a4bf88c5a4743bb5dca47b59a73a83add0fae commit r13-187-g692a4bf88c5a4743bb5dca47b59a73a83add0fae Author: Eric Botcazou Date: Sat Jan 8 00:48:58 2022 +0100 [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: --- gcc/ada/exp_ch4.adb | 28 ++++++++++++--------------- gcc/ada/exp_ch5.adb | 56 ++++++++++++++++++++++++++++++++--------------------- 2 files changed, 46 insertions(+), 38 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 2506c67e936..09e734defb2 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 b78c127e7f4..710db666e8d 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),