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