From patchwork Mon Jun 14 09:09:13 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55494 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 3DC36B7D85 for ; Mon, 14 Jun 2010 19:09:14 +1000 (EST) Received: (qmail 27437 invoked by alias); 14 Jun 2010 09:09:11 -0000 Received: (qmail 27418 invoked by uid 22791); 14 Jun 2010 09:09:09 -0000 X-SWARE-Spam-Status: No, hits=-1.1 required=5.0 tests=AWL, BAYES_05, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 14 Jun 2010 09:09:04 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id D71F8CB02BD; Mon, 14 Jun 2010 11:09:06 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id Q1+sw-3L16mi; Mon, 14 Jun 2010 11:09:06 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id C2B00CB021C; Mon, 14 Jun 2010 11:09:06 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id E24B9D9B31; Mon, 14 Jun 2010 11:09:13 +0200 (CEST) Date: Mon, 14 Jun 2010 11:09:13 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Reporting complex ambiguities Message-ID: <20100614090913.GA7934@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes 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 This patch diagnoses properly ambiguous procedure calls written in prefixed notation, when the prefix is itself an overloaded function call. Compiling test1.adb must yield: test1.adb:11:26: ambiguous call to "Get" test1.adb:11:26: interpretation (inherited) at objs.ads:23 test1.adb:11:26: interpretation at objs.ads:27 test1.adb:11:30: ambiguous expression (cannot resolve "Op") test1.adb:11:30: possible interpretation at objs.ads:6 test1.adb:11:30: possible interpretation at objs.ads:21 --- with Objs; procedure Test1 is My_Base_Ptr_Wrapper : Objs.p1.Base_Ptr_Wrapper; My_Derived_Ptr_Wrapper : Objs.p2.Derived_Ptr_Wrapper; begin My_Base_Ptr_Wrapper.Base_Obj_Ptr := new Objs.p2.Derived_Obj; My_Derived_Ptr_Wrapper.Base_Obj_Ptr := new Objs.p2.Derived_Obj; My_Derived_Ptr_Wrapper.Derived_Obj_Ptr := new Objs.p2.Derived_Obj; My_Derived_Ptr_Wrapper.Get.Op; -- (2) -- Ambiguous end; --- package Objs is package p1 is type Base_Obj is tagged null record; type Base_Obj_Class_Access is access all Base_Obj'Class; procedure Op (Self : in Base_Obj); type Base_Ptr_Wrapper is tagged record Base_Obj_Ptr : Base_Obj_Class_Access; end record; function Get (Self : in Base_Ptr_Wrapper) return access Base_Obj'Class; end p1; package p2 is type Derived_Obj is new p1.Base_Obj with null record; type Derived_Obj_Class_Access is access all Derived_Obj'Class; overriding procedure Op (Self : in Derived_Obj); type Derived_Ptr_Wrapper is new p1.Base_Ptr_Wrapper with record Derived_Obj_Ptr : Derived_Obj_Class_Access; end record; function Get (Self : in Derived_Ptr_Wrapper) return access Derived_Obj'Class; end p2; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-14 Ed Schonberg * sem_ch4.adb (Analyze_One_Call): If the call has been rewritten from a prefixed form, do not re-analyze first actual, which may need an implicit dereference. * sem_ch6.adb (Analyze_Procedure_Call): If the call is given in prefixed notation, the analysis will rewrite the node, and possible errors appear in the rewritten name of the node. * sem_res.adb: If a call is ambiguous because its first parameter is an overloaded call, report list of candidates, to clarify ambiguity of enclosing call. Index: sem_res.adb =================================================================== --- sem_res.adb (revision 160705) +++ sem_res.adb (working copy) @@ -1669,6 +1669,10 @@ package body Sem_Res is -- Try and fix up a literal so that it matches its expected type. New -- literals are manufactured if necessary to avoid cascaded errors. + procedure Report_Ambiguous_Argument; + -- Additional diagnostics when an ambiguous call has an ambiguous + -- argument (typically a controlling actual). + procedure Resolution_Failed; -- Called when attempt at resolving current expression fails @@ -1733,6 +1737,38 @@ package body Sem_Res is end if; end Patch_Up_Value; + ------------------------------- + -- Report_Ambiguous_Argument -- + ------------------------------- + + procedure Report_Ambiguous_Argument is + Arg : constant Node_Id := First (Parameter_Associations (N)); + I : Interp_Index; + It : Interp; + + begin + if Nkind (Arg) = N_Function_Call + and then Is_Entity_Name (Name (Arg)) + and then Is_Overloaded (Name (Arg)) + then + Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); + + Get_First_Interp (Name (Arg), I, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + + if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then + Error_Msg_N ("interpretation (inherited) #!", Arg); + + else + Error_Msg_N ("interpretation #!", Arg); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end Report_Ambiguous_Argument; + ----------------------- -- Resolution_Failed -- ----------------------- @@ -2037,6 +2073,13 @@ package body Sem_Res is Error_Msg_N -- CODEFIX ("\\possible interpretation#!", N); end if; + + if Nkind_In + (N, N_Procedure_Call_Statement, N_Function_Call) + and then Present (Parameter_Associations (N)) + then + Report_Ambiguous_Argument; + end if; end if; Error_Msg_Sloc := Sloc (It.Nam); Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 160709) +++ sem_ch4.adb (working copy) @@ -923,7 +923,21 @@ package body Sem_Ch4 is end if; end if; - Analyze_One_Call (N, Nam_Ent, False, Success); + -- If the call has been rewritten from a prefixed call, the first + -- parameter has been analyzed, but may need a subsequent + -- dereference, so skip its analysis now. + + if N /= Original_Node (N) + and then Nkind (Original_Node (N)) = Nkind (N) + and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N))) + and then Present (Parameter_Associations (N)) + and then Present (Etype (First (Parameter_Associations (N)))) + then + Analyze_One_Call + (N, Nam_Ent, False, Success, Skip_First => True); + else + Analyze_One_Call (N, Nam_Ent, False, Success); + end if; -- If the interpretation succeeds, mark the proper type of the -- prefix (any valid candidate will do). If not, remove the @@ -6080,7 +6094,7 @@ package body Sem_Ch4 is First_Actual : Node_Id; begin - -- Place the name of the operation, with its interpretations, + -- Place the name of the operation, with its innterpretations, -- on the rewritten call. Set_Name (Call_Node, Subprog); @@ -6180,6 +6194,7 @@ package body Sem_Ch4 is if Is_Overloaded (Subprog) then Save_Interps (Subprog, Node_To_Replace); + else Analyze (Node_To_Replace); @@ -6788,7 +6803,7 @@ package body Sem_Ch4 is and then Present (First_Formal (Prim_Op)) and then Valid_First_Argument_Of (Prim_Op) and then - (Nkind (Call_Node) = N_Function_Call) + (Nkind (Call_Node) = N_Function_Call) = (Ekind (Prim_Op) = E_Function) then -- Ada 2005 (AI-251): If this primitive operation corresponds Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 160705) +++ sem_ch6.adb (working copy) @@ -1074,9 +1074,13 @@ package body Sem_Ch6 is return; end if; - -- If error analyzing prefix, then set Any_Type as result and return + -- If there is an error analyzing the name (which may have been + -- rewritten if the original call was in prefix notation) then error + -- has been emitted already, mark node and return. - if Etype (P) = Any_Type then + if Error_Posted (N) + or else Etype (Name (N)) = Any_Type + then Set_Etype (N, Any_Type); return; end if;