From patchwork Thu May 19 14:16:11 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: 54220 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 DBD30383980D for ; Thu, 19 May 2022 14:31:16 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org DBD30383980D DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1652970676; bh=HTZOnyH992Z/5iM+qY/N7jhOKc4oWQZZPR5QjojPWXU=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=ubddL1UWa27UrOtukJ8wldpFdvLg0rpOWhXn4/9PrSi/2aXruk/T4KmpI86L3Rka2 buK+kDovMsWdJpzYXzwDQZ7rbSxLSYpca2eCuHIIT+I0OrG1DkGXnGTdOGkJjjQO8t wvEMfdWSYUjI+dXu8Oc/l2I1I7975s0eBq8isvWs= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x330.google.com (mail-wm1-x330.google.com [IPv6:2a00:1450:4864:20::330]) by sourceware.org (Postfix) with ESMTPS id B9F5F383D82B for ; Thu, 19 May 2022 14:16:13 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org B9F5F383D82B Received: by mail-wm1-x330.google.com with SMTP id a14-20020a7bc1ce000000b00393fb52a386so5102379wmj.1 for ; Thu, 19 May 2022 07:16:13 -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=HTZOnyH992Z/5iM+qY/N7jhOKc4oWQZZPR5QjojPWXU=; b=BfNjeI1yIKVA8DOJw+iwXAgYRpSSI9olwflArzzluejqv0r/rpxBYMlkPiPuyxFB+O RkDWcI1s0JDujmlrV95Dc4TjSYWpVB6KRk0SZFNuDpARkUbDgRtqvBs9eRwlk5yM/tZT G1fyC9zeBiVD/rb/C5HZH1jSNQchcSOKyQsvjQw9Q7g8Y5cEb9XpHJu/u02GWpTN4Yee YT2K+4z8PSuyNAWKiGR5B5CeCnVqIQnkkR+iAqPaSZ2OYj4Lj5QxGf5uaCKBLvSzgGwe Qd6MSnSsLYIiSqbwYtc9kEd7ogBX4TTVCax8IG3c5Bx3oECrY4zy20aWO8tG7hW3PVpi OkMA== X-Gm-Message-State: AOAM530onh2pqQzv6q7nzi2ELSvxOjP5USTmOvMmOH4E69pp5J+dxGRw qzQPgvFkdS8N4sQtftQLlKoiEJYVi2S0Fg== X-Google-Smtp-Source: ABdhPJzpGCTKjhaND0HxfYznCepCDpJNDI/JFNqEyvKGFWPvuRdrEvfH82a5RQaL80+gAqgV+MSHug== X-Received: by 2002:a7b:cd97:0:b0:38f:f785:ff8 with SMTP id y23-20020a7bcd97000000b0038ff7850ff8mr4468570wmj.44.1652969772448; Thu, 19 May 2022 07:16:12 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id c14-20020a05600c0a4e00b003942a244ec4sm4489081wmq.9.2022.05.19.07.16.11 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 19 May 2022 07:16:11 -0700 (PDT) Date: Thu, 19 May 2022 14:16:11 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Wrong interface dynamic dispatch via access parameter Message-ID: <20220519141611.GA3723330@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.8 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, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) 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: Javier Miranda Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" 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. Tested on x86_64-pc-linux-gnu, committed on trunk 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 --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb --- 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;