From patchwork Thu May 6 07:58:12 2021 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: 1474858 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4FbQwL4rKxz9sV5 for ; Thu, 6 May 2021 17:59:46 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 8DD373A76417; Thu, 6 May 2021 07:58:24 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [IPv6:2620:20:4000:0:a9e:1ff:fe9b:1d1]) by sourceware.org (Postfix) with ESMTP id 14D743A53023 for ; Thu, 6 May 2021 07:58:16 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 14D743A53023 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id EAE1D562BB; Thu, 6 May 2021 03:58:12 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 76GibZ2dES1a; Thu, 6 May 2021 03:58:12 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id C8304562B4; Thu, 6 May 2021 03:58:12 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id C76B71A1; Thu, 6 May 2021 03:58:12 -0400 (EDT) Date: Thu, 6 May 2021 03:58:12 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] ACATS 4.1R-c611a04: Class-wide preconditions in dispatching calls Message-ID: <20210506075812.GA125744@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-12.1 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) 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: , Cc: Javier Miranda Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" This patch is a partial implementation of the semantics mandated in AI12-0195 concerning class-wide preconditions on dispatching calls: the precondition that applies is that of the denoted subprogram entity, not that of the body that is actually executed. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_disp.adb (Build_Class_Wide_Check): Extending the functionality of this routine to climb to the ancestors searching for the enclosing overridden dispatching primitive that has a class-wide precondition to generate the check. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -709,10 +709,13 @@ package body Exp_Disp is Eq_Prim_Op : Entity_Id := Empty; Controlling_Tag : Node_Id; - procedure Build_Class_Wide_Check; + procedure Build_Class_Wide_Check (E : Entity_Id); -- If the denoted subprogram has a class-wide precondition, generate a -- check using that precondition before the dispatching call, because - -- this is the only class-wide precondition that applies to the call. + -- this is the only class-wide precondition that applies to the call; + -- otherwise climb to the ancestors searching for the enclosing + -- overridden primitive of E that has a class-wide precondition (and + -- use it to generate the check). function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call @@ -723,7 +726,14 @@ package body Exp_Disp is -- Build_Class_Wide_Check -- ---------------------------- - procedure Build_Class_Wide_Check is + procedure Build_Class_Wide_Check (E : Entity_Id) is + Subp : Entity_Id := E; + + function Has_Class_Wide_Precondition + (Subp : Entity_Id) return Boolean; + -- Evaluates if the dispatching subprogram Subp has a class-wide + -- precondition. + function Replace_Formals (N : Node_Id) return Traverse_Result; -- Replace occurrences of the formals of the subprogram by the -- corresponding actuals in the call, given that this check is @@ -735,6 +745,32 @@ package body Exp_Disp is -- has not been analyzed yet, in which case we use the Chars -- field to recognize intended occurrences of the formals. + --------------------------------- + -- Has_Class_Wide_Precondition -- + --------------------------------- + + function Has_Class_Wide_Precondition + (Subp : Entity_Id) return Boolean + is + Prec : Node_Id := Empty; + + begin + if Present (Contract (Subp)) + and then Present (Pre_Post_Conditions (Contract (Subp))) + then + Prec := Pre_Post_Conditions (Contract (Subp)); + + while Present (Prec) loop + exit when Pragma_Name (Prec) = Name_Precondition + and then Class_Present (Prec); + Prec := Next_Pragma (Prec); + end loop; + end if; + + return Present (Prec) + and then not Is_Ignored (Prec); + end Has_Class_Wide_Precondition; + --------------------- -- Replace_Formals -- --------------------- @@ -750,27 +786,46 @@ package body Exp_Disp is if Present (Entity (N)) and then Is_Formal (Entity (N)) then while Present (F) loop if F = Entity (N) then - Rewrite (N, New_Copy_Tree (A)); - - -- If the formal is class-wide, and thus not a - -- controlling argument, preserve its type because - -- it may appear in a nested call with a class-wide - -- parameter. + if not Is_Controlling_Actual (N) then + Rewrite (N, New_Copy_Tree (A)); + + -- If the formal is class-wide, and thus not a + -- controlling argument, preserve its type because + -- it may appear in a nested call with a class-wide + -- parameter. + + if Is_Class_Wide_Type (Etype (F)) then + Set_Etype (N, Etype (F)); + + -- Conversely, if this is a controlling argument + -- (in a dispatching call in the condition) that + -- is a dereference, the source is an access-to- + -- -class-wide type, so preserve the dispatching + -- nature of the call in the rewritten condition. + + elsif Nkind (Parent (N)) = N_Explicit_Dereference + and then Is_Controlling_Actual (Parent (N)) + then + Set_Controlling_Argument (Parent (Parent (N)), + Parent (N)); + end if; - if Is_Class_Wide_Type (Etype (F)) then - Set_Etype (N, Etype (F)); + -- Ensure that the type of the controlling actual + -- matches the type of the controlling formal of the + -- parent primitive Subp defining the class-wide + -- precondition. - -- Conversely, if this is a controlling argument - -- (in a dispatching call in the condition) that is a - -- dereference, the source is an access-to-class-wide - -- type, so preserve the dispatching nature of the - -- call in the rewritten condition. + elsif Is_Class_Wide_Type (Etype (A)) then + Rewrite (N, + Convert_To + (Class_Wide_Type (Etype (F)), + New_Copy_Tree (A))); - elsif Nkind (Parent (N)) = N_Explicit_Dereference - and then Is_Controlling_Actual (Parent (N)) - then - Set_Controlling_Argument (Parent (Parent (N)), - Parent (N)); + else + Rewrite (N, + Convert_To + (Etype (F), + New_Copy_Tree (A))); end if; exit; @@ -816,6 +871,13 @@ package body Exp_Disp is -- Start of processing for Build_Class_Wide_Check begin + -- Climb searching for the enclosing class-wide precondition + + while not Has_Class_Wide_Precondition (Subp) + and then Present (Overridden_Operation (Subp)) + loop + Subp := Overridden_Operation (Subp); + end loop; -- Locate class-wide precondition, if any @@ -924,7 +986,7 @@ package body Exp_Disp is Subp := Alias (Subp); end if; - Build_Class_Wide_Check; + Build_Class_Wide_Check (Subp); -- Definition of the class-wide type and the tagged type