public inbox for gcc-cvs@sourceware.org help / color / mirror / Atom feed
From: Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-6301] [Ada] Avoid building malformed component constraints Date: Thu, 6 Jan 2022 17:13:47 +0000 (GMT) [thread overview] Message-ID: <20220106171347.AC9883858024@sourceware.org> (raw) https://gcc.gnu.org/g:c60f23e13ecbc5a5b07adb7557f1da094246cb2a commit r12-6301-gc60f23e13ecbc5a5b07adb7557f1da094246cb2a Author: Steve Baird <baird@adacore.com> 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 -- ------------------------------------
reply other threads:[~2022-01-06 17:13 UTC|newest] Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions: You may reply publicly to this message via plain-text email using any one of the following methods: * Save the following mbox file, import it into your mail client, and reply-to-all from there: mbox Avoid top-posting and favor interleaved quoting: https://en.wikipedia.org/wiki/Posting_style#Interleaved_style * Reply using the --to, --cc, and --in-reply-to switches of git-send-email(1): git send-email \ --in-reply-to=20220106171347.AC9883858024@sourceware.org \ --to=pmderodat@gcc.gnu.org \ --cc=gcc-cvs@gcc.gnu.org \ /path/to/YOUR_REPLY https://kernel.org/pub/software/scm/git/docs/git-send-email.html * If your mail client supports setting the In-Reply-To header via mailto: links, try the mailto: linkBe sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).