From patchwork Tue Jul 17 08:25:42 2018 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: 944810 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-481705-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="k3cUYUAI"; 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 41VD4p5hFvz9s0n for ; Tue, 17 Jul 2018 18:30:50 +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=f+uMYb+KSB/wEy1ZJFrSTIX0tXmSAU4N+zg3XhSqE27Lo2nBWC t8ZGKeQXIDHEJWYYsFRcPxi9U44o8l57DgMKvpaXjWoFi0eMLmddrIm00GgdspQW 0ULkxL1e13qkDrTunS0ziAl39BOYV1ExPV/+6BEWGJayaXdECVipZiaKg= 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=7keYCetcNOMQ4hi27/qw+RUFW5w=; b=k3cUYUAIGM9U1ZP9iE7s /6FZ07jGLYwy0UnNx4MP5DEid9oUfbCcfIc2PGbT3h7bs2I1z+IIUNHGn7hCI8l0 xTirHxxddwjh6QjEpdrJsc5qatDamceEJiaqyNe3qTzhkvoFNw9qtUu8C6w7WZnO FjAoA37BfBnxJSflGEsA0uE= Received: (qmail 118962 invoked by alias); 17 Jul 2018 08:27:24 -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 117680 invoked by uid 89); 17 Jul 2018 08:25:48 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy= 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, 17 Jul 2018 08:25:43 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 7B5F65615F; Tue, 17 Jul 2018 04:25:42 -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 fbpEdQAjtDDu; Tue, 17 Jul 2018 04:25:42 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 6979E56132; Tue, 17 Jul 2018 04:25:42 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 685CA4F2; Tue, 17 Jul 2018 04:25:42 -0400 (EDT) Date: Tue, 17 Jul 2018 04:25:42 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Spurious error on prefixed call in an instantiation Message-ID: <20180717082542.GA4960@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 error on a prefixed call in an instance, when the generic parameters include an interface type and an abstract operation of that type, and the actuals in the instance include an interface type and a corresponding abstract operation of it, with a different name than the corresponding generic subprogram parameter. The patch also fixes a similar error involving class-wide operations and generic private types. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-07-17 Ed Schonberg gcc/ada/ * sem_ch4.adb (Try_Object_Operation): Handle properly a prefixed call in an instance, when the generic parameters include an interface type and a abstract operation of that type, and the actuals in the instance include an interface type and a corresponding abstract operation of it, with a different name than the corresponding generic subprogram parameter. gcc/testsuite/ * gnat.dg/generic_call_cw.adb, gnat.dg/generic_call_iface.adb: New testcase. --- gcc/ada/sem_ch4.adb +++ gcc/ada/sem_ch4.adb @@ -8928,11 +8928,38 @@ package body Sem_Ch4 is (Anc_Type : Entity_Id; Error : out Boolean) is + Candidate : Entity_Id; + -- If homonym is a renaming, examine the renamed program + Cls_Type : Entity_Id; Hom : Entity_Id; Hom_Ref : Node_Id; Success : Boolean; + function First_Formal_Match + (Typ : Entity_Id) return Boolean; + -- Predicate to verify that the first formal of a class-wide + -- candidate matches the type of the prefix. + + ------------------------ + -- First_Formal_Match -- + ------------------------ + + function First_Formal_Match + (Typ : Entity_Id) return Boolean + is + Ctrl : constant Entity_Id := First_Formal (Candidate); + begin + return Present (Ctrl) + and then + (Base_Type (Etype (Ctrl)) = Typ + or else + (Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type + and then + Base_Type + (Designated_Type (Etype (Ctrl))) = Typ)); + end First_Formal_Match; + begin Error := False; @@ -8948,25 +8975,23 @@ package body Sem_Ch4 is while Present (Hom) loop if Ekind_In (Hom, E_Procedure, E_Function) - and then (not Is_Hidden (Hom) or else In_Instance) - and then Scope (Hom) = Scope (Base_Type (Anc_Type)) - and then Present (First_Formal (Hom)) - and then - (Base_Type (Etype (First_Formal (Hom))) = Cls_Type - or else - (Is_Access_Type (Etype (First_Formal (Hom))) - and then - Ekind (Etype (First_Formal (Hom))) = - E_Anonymous_Access_Type - and then - Base_Type - (Designated_Type (Etype (First_Formal (Hom)))) = - Cls_Type)) + and then Present (Renamed_Entity (Hom)) + and then Is_Generic_Actual_Subprogram (Hom) + then + Candidate := Renamed_Entity (Hom); + else + Candidate := Hom; + end if; + + if Ekind_In (Candidate, E_Procedure, E_Function) + and then (not Is_Hidden (Candidate) or else In_Instance) + and then Scope (Candidate) = Scope (Base_Type (Anc_Type)) + and then First_Formal_Match (Cls_Type) then -- If the context is a procedure call, ignore functions -- in the name of the call. - if Ekind (Hom) = E_Function + if Ekind (Candidate) = E_Function and then Nkind (Parent (N)) = N_Procedure_Call_Statement and then N = Name (Parent (N)) then @@ -8975,7 +9000,7 @@ package body Sem_Ch4 is -- If the context is a function call, ignore procedures -- in the name of the call. - elsif Ekind (Hom) = E_Procedure + elsif Ekind (Candidate) = E_Procedure and then Nkind (Parent (N)) /= N_Procedure_Call_Statement then goto Next_Hom; @@ -8986,7 +9011,7 @@ package body Sem_Ch4 is Success := False; if No (Matching_Op) then - Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog)); + Hom_Ref := New_Occurrence_Of (Candidate, Sloc (Subprog)); Set_Etype (Call_Node, Any_Type); Set_Parent (Call_Node, Parent (Node_To_Replace)); @@ -8994,18 +9019,18 @@ package body Sem_Ch4 is Analyze_One_Call (N => Call_Node, - Nam => Hom, + Nam => Candidate, Report => Report_Error, Success => Success, Skip_First => True); Matching_Op := - Valid_Candidate (Success, Call_Node, Hom); + Valid_Candidate (Success, Call_Node, Candidate); else Analyze_One_Call (N => Call_Node, - Nam => Hom, + Nam => Candidate, Report => Report_Error, Success => Success, Skip_First => True); @@ -9014,9 +9039,10 @@ package body Sem_Ch4 is -- traversals, before and after looking at interfaces. -- Check for this case before reporting a real ambiguity. - if Present (Valid_Candidate (Success, Call_Node, Hom)) + if Present + (Valid_Candidate (Success, Call_Node, Candidate)) and then Nkind (Call_Node) /= N_Function_Call - and then Hom /= Matching_Op + and then Candidate /= Matching_Op then Error_Msg_NE ("ambiguous call to&", N, Hom); Report_Ambiguity (Matching_Op); @@ -9478,6 +9504,23 @@ package body Sem_Ch4 is Present (Original_Protected_Subprogram (Prim_Op)) and then Chars (Original_Protected_Subprogram (Prim_Op)) = Chars (Subprog); + + -- In an instance, the selector name may be a generic actual that + -- renames a primitive operation of the type of the prefix. + + elsif In_Instance and then Present (Current_Entity (Subprog)) then + declare + Subp : constant Entity_Id := Current_Entity (Subprog); + begin + if Present (Subp) + and then Is_Subprogram (Subp) + and then Present (Renamed_Entity (Subp)) + and then Is_Generic_Actual_Subprogram (Subp) + and then Chars (Renamed_Entity (Subp)) = Chars (Prim_Op) + then + return True; + end if; + end; end if; return False; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/generic_call_cw.adb @@ -0,0 +1,33 @@ +-- { dg-do compile } + +procedure Generic_Call_CW is + + generic + type Subscriber_Type is tagged private; + with procedure On_Changed (Subscriber : in out Subscriber_Type'Class); + package My_Generic is + type Subscriber_Ptr is access all Subscriber_Type'Class; + procedure Update; + Subscriber : Subscriber_Ptr := null; + end; + + package body My_Generic is + procedure Update is + begin + if Subscriber /= null then + Subscriber.On_Changed; + end if; + end; + end; + + package User is + type Integer_Subscriber is tagged null record; + procedure On_Changed_Int (I : in out Integer_Subscriber'Class) is null; + + package P is new My_Generic + (Subscriber_Type => Integer_Subscriber, + On_Changed => On_Changed_Int); + end; +begin + null; +end; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/generic_call_iface.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } + +procedure Generic_Call_Iface is + + generic + type Subscriber_Type is interface; + with procedure On_Changed (Subscriber : in out Subscriber_Type) + is abstract; + package My_Generic is + type Subscriber_Ptr is access all Subscriber_Type'Class; + procedure Update; + Subscriber : Subscriber_Ptr := null; + end; + + package body My_Generic is + procedure Update is + begin + if Subscriber /= null then + Subscriber.On_Changed; + end if; + end; + end; + + package User is + type Integer_Subscriber is interface; + procedure On_Changed_Int (I : in out Integer_Subscriber) is abstract; + + package P is new My_Generic + (Subscriber_Type => Integer_Subscriber, + On_Changed => On_Changed_Int); + end; +begin + null; +end;