From patchwork Mon May 9 09:30:24 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 53633 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D94403857364 for ; Mon, 9 May 2022 09:43:50 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D94403857364 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1652089430; bh=1Zualua/2u0Hj1gLkaDbQXUvznRSjdLTKbjucMOj/R8=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=LfXfAS6Yw583ntlVIYEfcn+gKi1m9VyCjJykVMOKHLTZzrrGSclZzLanreYqh7f4y SA9qR/PpSMZQKXndxQAXhFrr62nvo265CrobzAATltWc92ZaQqcdxwkD0521m+3v0U s44u6hnAzmTwgPN+EivvlZ5VohM7L4k+uZ6gPXRw= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42d.google.com (mail-wr1-x42d.google.com [IPv6:2a00:1450:4864:20::42d]) by sourceware.org (Postfix) with ESMTPS id B98573856262 for ; Mon, 9 May 2022 09:30:26 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org B98573856262 Received: by mail-wr1-x42d.google.com with SMTP id c11so18530964wrn.8 for ; Mon, 09 May 2022 02:30:26 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=1Zualua/2u0Hj1gLkaDbQXUvznRSjdLTKbjucMOj/R8=; b=dRQ0Sat7Ij/Oy5eMzFIRB7xcRAX3KjB8fS2g8iualXnCsx8oh34MD5c6/BQUT/Us3+ wQHWcgnQvGiZSFoqLnWwhCixgI/N2ndzcjvrrX0yya0G1qd6nEHeMMa8S8Ri0RvCISnW +MZoak6WxnzCoDlnS9D5G1shOY+x/kp2BECsLGu+N3kCxlOUwcYPvqj6O8+dYl/ZOSv2 zdJz5C+N5c+m7gCad2M2FgghgVfcndtIJmWy6pcEx2j+mujSAMcdNmOsmrlhEOj0XR4A fKNo/Zh6SjFebqJMqqkyWpaGgDbaNsTt0qhbPXT/CBVJge9LvNfPSLPU+eD9JgY0Zz6X hXDw== X-Gm-Message-State: AOAM5321nsjJ/4YMQOIagf06q+rMQV+yp/ONLoK9kL9nl1gIT/QAhKp7 eLNOa/5ZhxUrxZyH0MgAquWvql8My2kQ5Q== X-Google-Smtp-Source: ABdhPJxNvcOAlCxC6qt72Ie1A03v7Zk4VQAxeUo7T6AekypzSgCnhitwy5fOK7nu5gqecyFoYcoAdg== X-Received: by 2002:adf:eb0a:0:b0:20c:5bad:11db with SMTP id s10-20020adfeb0a000000b0020c5bad11dbmr13053997wrn.435.1652088625518; Mon, 09 May 2022 02:30:25 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id d10-20020adffd8a000000b0020c5253d925sm10222373wrr.113.2022.05.09.02.30.24 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 09 May 2022 02:30:25 -0700 (PDT) Date: Mon, 9 May 2022 09:30:24 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix internal error on declaration of derived discriminated record type Message-ID: <20220509093024.GA3184334@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Eric Botcazou Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" 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. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- 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 --- 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),