From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x42b.google.com (mail-wr1-x42b.google.com [IPv6:2a00:1450:4864:20::42b]) by sourceware.org (Postfix) with ESMTPS id 809843858017 for ; Thu, 6 Jan 2022 17:13:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 809843858017 Received: by mail-wr1-x42b.google.com with SMTP id v6so6094213wra.8 for ; Thu, 06 Jan 2022 09:13:03 -0800 (PST) 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=eo4XRpb0Vu5YvBI3mRMGWJDBmb3aD8KiAs8c9CikZVs=; b=OMv+k4TybwnrceZKh4SizKLAXG+soh5LBLDonsaSAH3Vep3QOmXNpmgFqZYbtpoceH /88tV5dbZnMKr8MRoDAfzSgQPbKk5QxLMM49Fivuz64qwnJxlIjPyWVLNKX7KgZzS7b/ 9Qo2Xe+U0Y7ZBANTW/olxvYX/iKLPQ0D0sJGIDkUsV12OtKXU8LPlZsUxcGmcHgiNSUO BDeDP2Mqy9ebM/TNYkUVQfn5MPNR6v9IhpixwxhIEBAtNQSq5JhMYLIRNXcNJZRyQZMh zS+xSodtoa1lkvFDiYRercXQ6Dk4vk+HGu5FhrLr7WiIyGt5SX2EWjzAd1ocngqAAwS6 H2/A== X-Gm-Message-State: AOAM532myJ8/Xp/O5IVCj75Z9WhUbguVTloEwRv1ZmR5Dj35WYu/39mU qYL2jbxgadMYjVUQcH1gJR0l0Zuy9TGKpQ== X-Google-Smtp-Source: ABdhPJwTzHv1tLsi1R8zHWejWMgoABbE9Sjvyjcv12mK6sgQbdX+MXRcV1ajEjJiD27xxG/8cYoaCA== X-Received: by 2002:adf:a35d:: with SMTP id d29mr51093292wrb.264.1641489182590; Thu, 06 Jan 2022 09:13:02 -0800 (PST) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id p18sm6226445wmq.23.2022.01.06.09.13.01 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 06 Jan 2022 09:13:01 -0800 (PST) Date: Thu, 6 Jan 2022 17:13:01 +0000 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Steve Baird Subject: [Ada] Avoid building malformed component constraints Message-ID: <20220106171301.GA2921570@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="azLHFNyN32YCQGCU" Content-Disposition: inline X-Spam-Status: No, score=-12.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP 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-List-Received-Date: Thu, 06 Jan 2022 17:13:05 -0000 --azLHFNyN32YCQGCU Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Given a discriminated type T1 with discriminant D1 having a component C1 of another discriminated type T2 with discriminant D2 and a propagated discriminant constraint (that is, "C1 : T2 (D2 => D1);" and, for example, a parameter of type T1, the compiler will sometimes build an anonymous subtype to describe the constraints of the C1 component of that parameter. In some cases, these constraints were malformed; this could result in either internal errors during compilation or the generation of incorrect constraint checks. This error is corrected. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * sem_util.adb (Build_Actual_Subtype_Of_Component): Define a new local function, Build_Discriminant_Reference, and call it in each of the three cases where Make_Selected_Component was previously being called to construct a discriminant reference (2 in Build_Actual_Array_Constraint and 1 in Build_Actual_Record_Constraint). Instead of unconditionally using the passed-in object name as the prefix for the new selected component node, this new function checks to see if perhaps a prefix of that name should be used instead. --azLHFNyN32YCQGCU Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1970,6 +1970,12 @@ package body Sem_Util is -- Similar to previous one, for discriminated components constrained -- by the discriminant of the enclosing object. + function Build_Discriminant_Reference + (Discrim_Name : Node_Id; Obj : Node_Id := P) return Node_Id; + -- Build a reference to the discriminant denoted by Discrim_Name. + -- The prefix of the result is usually Obj, but it could be + -- a prefix of Obj in some corner cases. + function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id; -- Copy the subtree rooted at N and insert an explicit dereference if it -- is of an access type. @@ -1993,11 +1999,7 @@ package body Sem_Util is Old_Hi := Type_High_Bound (Etype (Indx)); if Denotes_Discriminant (Old_Lo) then - Lo := - Make_Selected_Component (Loc, - Prefix => Copy_And_Maybe_Dereference (P), - Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); - + Lo := Build_Discriminant_Reference (Old_Lo); else Lo := New_Copy_Tree (Old_Lo); @@ -2011,11 +2013,7 @@ package body Sem_Util is end if; if Denotes_Discriminant (Old_Hi) then - Hi := - Make_Selected_Component (Loc, - Prefix => Copy_And_Maybe_Dereference (P), - Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); - + Hi := Build_Discriminant_Reference (Old_Hi); else Hi := New_Copy_Tree (Old_Hi); Set_Analyzed (Hi, False); @@ -2041,10 +2039,7 @@ package body Sem_Util is D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then - D_Val := Make_Selected_Component (Loc, - Prefix => Copy_And_Maybe_Dereference (P), - Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); - + D_Val := Build_Discriminant_Reference (Node (D)); else D_Val := New_Copy_Tree (Node (D)); end if; @@ -2056,6 +2051,89 @@ package body Sem_Util is return Constraints; end Build_Actual_Record_Constraint; + ---------------------------------- + -- Build_Discriminant_Reference -- + ---------------------------------- + + function Build_Discriminant_Reference + (Discrim_Name : Node_Id; Obj : Node_Id := P) return Node_Id + is + Discrim : constant Entity_Id := Entity (Discrim_Name); + + function Obj_Is_Good_Prefix return Boolean; + -- Returns True if Obj.Discrim makes sense; that is, if + -- Obj has Discrim as one of its discriminants (or is an + -- access value that designates such an object). + + ------------------------ + -- Obj_Is_Good_Prefix -- + ------------------------ + + function Obj_Is_Good_Prefix return Boolean is + Obj_Type : Entity_Id := + Implementation_Base_Type (Etype (Obj)); + + Discriminated_Type : constant Entity_Id := + Implementation_Base_Type + (Scope (Original_Record_Component (Discrim))); + begin + -- The order of the following two tests matters in the + -- access-to-class-wide case. + + if Is_Access_Type (Obj_Type) then + Obj_Type := Implementation_Base_Type + (Designated_Type (Obj_Type)); + end if; + + if Is_Class_Wide_Type (Obj_Type) then + Obj_Type := Implementation_Base_Type + (Find_Specific_Type (Obj_Type)); + end if; + + -- If a type T1 defines a discriminant D1, then Obj.D1 is ok (for + -- our purposes here) if T1 is an ancestor of the type of Obj. + -- So that's what we would like to test for here. + -- The bad news: Is_Ancestor is only defined in the tagged case. + -- The good news: in the untagged case, Implementation_Base_Type + -- looks through derived types so we can use a simpler test. + + if Is_Tagged_Type (Discriminated_Type) then + return Is_Ancestor (Discriminated_Type, Obj_Type); + else + return Discriminated_Type = Obj_Type; + end if; + end Obj_Is_Good_Prefix; + + -- Start of processing for Build_Discriminant_Reference + + begin + if Obj_Is_Good_Prefix then + return Make_Selected_Component (Loc, + Prefix => Copy_And_Maybe_Dereference (Obj), + Selector_Name => New_Occurrence_Of (Discrim, Loc)); + else + -- If the given discriminant is not a component of the given + -- object, then try the enclosing object. + + if Nkind (Obj) = N_Selected_Component then + return Build_Discriminant_Reference + (Discrim_Name => Discrim_Name, + Obj => Prefix (Obj)); + elsif Nkind (Obj) in N_Has_Entity + and then Nkind (Parent (Entity (Obj))) = + N_Object_Renaming_Declaration + then + -- Look through a renaming (a corner case of a corner case). + return Build_Discriminant_Reference + (Discrim_Name => Discrim_Name, + Obj => Name (Parent (Entity (Obj)))); + else + pragma Assert (False); + raise Program_Error; + end if; + end if; + end Build_Discriminant_Reference; + ------------------------------------ -- Build_Access_Record_Constraint -- ------------------------------------ --azLHFNyN32YCQGCU--