From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id AC9883858024; Thu, 6 Jan 2022 17:13:47 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org AC9883858024 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 r12-6301] [Ada] Avoid building malformed component constraints X-Act-Checkin: gcc X-Git-Author: Steve Baird X-Git-Refname: refs/heads/master X-Git-Oldrev: 41a7b9484a39657deab7cac7092c2bf634a39365 X-Git-Newrev: c60f23e13ecbc5a5b07adb7557f1da094246cb2a Message-Id: <20220106171347.AC9883858024@sourceware.org> Date: Thu, 6 Jan 2022 17:13:47 +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: Thu, 06 Jan 2022 17:13:47 -0000 https://gcc.gnu.org/g:c60f23e13ecbc5a5b07adb7557f1da094246cb2a commit r12-6301-gc60f23e13ecbc5a5b07adb7557f1da094246cb2a Author: Steve Baird Date: Thu Dec 2 17:04:15 2021 -0800 [Ada] Avoid building malformed component constraints 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. Diff: --- gcc/ada/sem_util.adb | 106 ++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 92 insertions(+), 14 deletions(-) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 05fa3eda82c..2bc3c95dbeb 100644 --- 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 -- ------------------------------------