Patchwork [Ada] Reporting complex ambiguities

login
register
mail settings
Submitter Arnaud Charlet
Date June 14, 2010, 9:09 a.m.
Message ID <20100614090913.GA7934@adacore.com>
Download mbox | patch
Permalink /patch/55494/
State New
Headers show

Comments

Arnaud Charlet - June 14, 2010, 9:09 a.m.
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  <schonberg@adacore.com>

	* 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.
Duncan Sands - June 14, 2010, 9:17 a.m.
Hi Arnaud, the following changes look bogus:

@@ -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);

Patch

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;