From patchwork Tue Aug 20 09:51:27 2019 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: 1149991 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-507348-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="jdVYNWjz"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 46CR1P16Ldz9s4Y for ; Tue, 20 Aug 2019 19:52:56 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=KqBDRJCbc8Ue4V0V1aMY4zEKUOEwa00PUhc0mw0MKUP3wi7LyF PpI/9BvSMeKtMNH4PA2emt5ubJ/4vDlB1EonpZekhH/5LbXH8Xl05qtT6nrLBlEV r/PzdNdTJAgQK3nawu9rdgTVACrQkp9V/B6m5gy0VNgxqoSDqb7Z2geOk= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=ZDwORd60YkE2H1ezDIQ8D4RqHmw=; b=jdVYNWjzyupCFrj8/qVO 838q5MP4Vz/MpPVLzY+lK+GzR9ODhQYW37KZgQJB4Otkd49o6at5N9exSSwRdnLd bZNKZEWmYHU7+YRVkN32qIuN0QV55iZDSAZoD5qQPy+SFQ9pdQgWApBtZi6xDEC4 hV5WG6IBkW/WOn6EcDLcYls= Received: (qmail 121867 invoked by alias); 20 Aug 2019 09:51:30 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 121809 invoked by uid 89); 20 Aug 2019 09:51:29 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=Present, formals X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 20 Aug 2019 09:51:27 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 7B46B560BC; Tue, 20 Aug 2019 05:51:27 -0400 (EDT) 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 VdsVi2MWV5Pk; Tue, 20 Aug 2019 05:51:27 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 6A18C560BB; Tue, 20 Aug 2019 05:51:27 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 692BD63E; Tue, 20 Aug 2019 05:51:27 -0400 (EDT) Date: Tue, 20 Aug 2019 05:51:27 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Spurious error in dispatching call with class-wide precondition Message-ID: <20190820095127.GA75542@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This patch fixes a spurious visibility error on a dispatching call to a subprogram with a classwide precondition, when the call qppears in the same declarative part as the subprogram declaration itself. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-20 Ed Schonberg gcc/ada/ * exp_disp.adb (Build_Class_Wide_Check, Replace_Formals): When a dispatching call tp a subprogram with a class-wide precondition occurrs in the same declarative part as the ancestor subprogram being called, the`expression for the precondition has not been analyzed yet. Such a call may appear, e.g. in an expression function. In that case, the replacement of formals by actuals in the call cannot use the formal entities of the subprogram being called, and the occurrence of the formals in the expression must be located by name (Chars fields) as would be done at a later freeze point, when the expression is resolved in the context of the subprogram itself. gcc/testsuite/ * gnat.dg/tagged5.adb, gnat.dg/tagged5.ads: New testcase. --- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -728,23 +728,27 @@ package body Exp_Disp is -- corresponding actuals in the call, given that this check is -- performed outside of the body of the subprogram. + -- If the dispatching call appears in the same scope as the + -- declaration of the dispatching subprogram (for example in + -- the expression of a local expression function) the prec. + -- has not been analyzed yet, in which case we use the Chars + -- field to recognize intended occurrences of the formals. + --------------------- -- Replace_Formals -- --------------------- function Replace_Formals (N : Node_Id) return Traverse_Result is + A : Node_Id; + F : Entity_Id; begin - if Is_Entity_Name (N) - and then Present (Entity (N)) - and then Is_Formal (Entity (N)) - then - declare - A : Node_Id; - F : Entity_Id; + if Is_Entity_Name (N) then + F := First_Formal (Subp); + A := First_Actual (Call_Node); - begin - F := First_Formal (Subp); - A := First_Actual (Call_Node); + 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)); @@ -776,7 +780,25 @@ package body Exp_Disp is Next_Formal (F); Next_Actual (A); end loop; - end; + + -- If node is not analyzed, recognize occurrences of + -- a formal by name, as would be done when resolving + -- the aspect expression in the context of the subprogram. + + elsif not Analyzed (N) + and then Nkind (N) = N_Identifier + and then No (Entity (N)) + then + while Present (F) loop + if Chars (N) = Chars (F) then + Rewrite (N, New_Copy_Tree (A)); + return Skip; + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + end if; end if; return OK; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/tagged5.adb @@ -0,0 +1,6 @@ +-- { dg-do compile } +-- { dg-options "-gnata" } + +package body Tagged5 is + procedure Dummy is null; +end Tagged5; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/tagged5.ads @@ -0,0 +1,18 @@ +package Tagged5 is + + type T is limited interface; + + not overriding function Element + (Self : T; + Index : Positive) + return Integer is abstract + with Pre'Class => Index + Index ** 2 in 1 .. 10; + + function First + (Self : T'Class) + return Integer + is (Self.Element (1)); + + procedure Dummy; + +end Tagged5;