From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id 7F527383D81B; Thu, 19 May 2022 14:07:40 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 7F527383D81B 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-650] [Ada] Wrong interface dynamic dispatch via access parameter X-Act-Checkin: gcc X-Git-Author: Javier Miranda X-Git-Refname: refs/heads/master X-Git-Oldrev: eff70bcc1f1e808e3cc253a8452b7849329d549a X-Git-Newrev: 8a03acaace9544249583e630153e73d53ccfaec7 Message-Id: <20220519140740.7F527383D81B@sourceware.org> Date: Thu, 19 May 2022 14:07:40 +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, 19 May 2022 14:07:40 -0000 https://gcc.gnu.org/g:8a03acaace9544249583e630153e73d53ccfaec7 commit r13-650-g8a03acaace9544249583e630153e73d53ccfaec7 Author: Javier Miranda Date: Wed Apr 13 16:27:59 2022 +0000 [Ada] Wrong interface dynamic dispatch via access parameter When the prefix of an Access attribute is an explicit dereference of an access parameter (or a renaming of such a dereference, or a subcomponent of such a dereference), the context is a general access type to a class-wide interface type, and an accessibility check must be generated, the frontend silently skips generating an implicit type conversion to force the displacement of the pointer to reference the secondary dispatch table. gcc/ada/ * exp_attr.adb (Add_Implicit_Interface_Type_Conversion): New subprogram which factorizes code. (Expand_N_Attribute_Reference): Call the new subprogram to add the missing implicit interface type conversion. Diff: --- gcc/ada/exp_attr.adb | 136 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 84 insertions(+), 52 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 19aea23771a..ad7545353e3 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2108,12 +2108,86 @@ package body Exp_Attr is Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); Btyp_DDT : Entity_Id; + procedure Add_Implicit_Interface_Type_Conversion; + -- Ada 2005 (AI-251): The designated type is an interface type; + -- add an implicit type conversion to force the displacement of + -- the pointer to reference the secondary dispatch table. + function Enclosing_Object (N : Node_Id) return Node_Id; -- If N denotes a compound name (selected component, indexed -- component, or slice), returns the name of the outermost such -- enclosing object. Otherwise returns N. If the object is a -- renaming, then the renamed object is returned. + -------------------------------------------- + -- Add_Implicit_Interface_Type_Conversion -- + -------------------------------------------- + + procedure Add_Implicit_Interface_Type_Conversion is + begin + pragma Assert (Is_Interface (Btyp_DDT)); + + -- Handle cases were no action is required. + + if not Comes_From_Source (N) + and then not Comes_From_Source (Ref_Object) + and then (Nkind (Ref_Object) not in N_Has_Chars + or else Chars (Ref_Object) /= Name_uInit) + then + return; + end if; + + -- Common case + + if Nkind (Ref_Object) /= N_Explicit_Dereference then + + -- No implicit conversion required if types match, or if + -- the prefix is the class_wide_type of the interface. In + -- either case passing an object of the interface type has + -- already set the pointer correctly. + + if Btyp_DDT = Etype (Ref_Object) + or else + (Is_Class_Wide_Type (Etype (Ref_Object)) + and then + Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object)) + then + null; + + else + Rewrite (Prefix (N), + Convert_To (Btyp_DDT, + New_Copy_Tree (Prefix (N)))); + + Analyze_And_Resolve (Prefix (N), Btyp_DDT); + end if; + + -- When the object is an explicit dereference, convert the + -- dereference's prefix. + + else + declare + Obj_DDT : constant Entity_Id := + Base_Type + (Directly_Designated_Type + (Etype (Prefix (Ref_Object)))); + begin + -- No implicit conversion required if designated types + -- match. + + if Obj_DDT /= Btyp_DDT + and then not (Is_Class_Wide_Type (Obj_DDT) + and then Etype (Obj_DDT) = Btyp_DDT) + then + Rewrite (N, + Convert_To (Typ, + New_Copy_Tree (Prefix (Ref_Object)))); + Analyze_And_Resolve (N, Typ); + end if; + end; + end if; + end Add_Implicit_Interface_Type_Conversion; + ---------------------- -- Enclosing_Object -- ---------------------- @@ -2398,62 +2472,20 @@ package body Exp_Attr is then Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N); + -- Ada 2005 (AI-251): If the designated type is an interface we + -- add an implicit conversion to force the displacement of the + -- pointer to reference the secondary dispatch table. + + if Is_Interface (Btyp_DDT) then + Add_Implicit_Interface_Type_Conversion; + end if; + -- Ada 2005 (AI-251): If the designated type is an interface we -- add an implicit conversion to force the displacement of the -- pointer to reference the secondary dispatch table. - elsif Is_Interface (Btyp_DDT) - and then (Comes_From_Source (N) - or else Comes_From_Source (Ref_Object) - or else (Nkind (Ref_Object) in N_Has_Chars - and then Chars (Ref_Object) = Name_uInit)) - then - if Nkind (Ref_Object) /= N_Explicit_Dereference then - - -- No implicit conversion required if types match, or if - -- the prefix is the class_wide_type of the interface. In - -- either case passing an object of the interface type has - -- already set the pointer correctly. - - if Btyp_DDT = Etype (Ref_Object) - or else (Is_Class_Wide_Type (Etype (Ref_Object)) - and then - Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object)) - then - null; - - else - Rewrite (Prefix (N), - Convert_To (Btyp_DDT, - New_Copy_Tree (Prefix (N)))); - - Analyze_And_Resolve (Prefix (N), Btyp_DDT); - end if; - - -- When the object is an explicit dereference, convert the - -- dereference's prefix. - - else - declare - Obj_DDT : constant Entity_Id := - Base_Type - (Directly_Designated_Type - (Etype (Prefix (Ref_Object)))); - begin - -- No implicit conversion required if designated types - -- match. - - if Obj_DDT /= Btyp_DDT - and then not (Is_Class_Wide_Type (Obj_DDT) - and then Etype (Obj_DDT) = Btyp_DDT) - then - Rewrite (N, - Convert_To (Typ, - New_Copy_Tree (Prefix (Ref_Object)))); - Analyze_And_Resolve (N, Typ); - end if; - end; - end if; + elsif Is_Interface (Btyp_DDT) then + Add_Implicit_Interface_Type_Conversion; end if; end Access_Cases;