When the frontend resolves a dispatching call through the object
operation notation it must also check if there is a class-wide
subprogram covering the target primitive. This check was missing
in the frontend. After this patch the following test must
compile with errors:
package Pkg1 is
type Iface is interface;
procedure Yet_Another_Op (Obj : in out Iface'Class);
end;
with Pkg1;
package Pkg2 is
type Typ is new Pkg1.Iface with null record;
procedure Yet_Another_Op (Obj : in out Typ);
end;
with Pkg1; use Pkg1;
with Pkg2; use Pkg2;
procedure Main is
T : Pkg2.Typ;
begin
T.Yet_Another_Op; -- Ambiguous? (Yes)
end;
Command: gcc -c -gnat05 main.adb
Output:
main.adb:7:05: ambiguous expression (cannot resolve "Yet_Another_Op")
main.adb:7:05: possible interpretation at pkg2.ads:6
main.adb:7:05: possible interpretation at pkg1.ads:3
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-31 Javier Miranda <mira...@adacore.com>
* sem_ch4.adb (Try_Object_Operation): When a dispatching primitive is
found check if there is a class-wide subprogram covering the primitive.
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 178360)
+++ sem_ch4.adb (working copy)
@@ -6638,7 +6638,7 @@
Call : Node_Id;
Subp : Entity_Id) return Entity_Id;
-- If the subprogram is a valid interpretation, record it, and add
- -- to the list of interpretations of Subprog.
+ -- to the list of interpretations of Subprog. Otherwise return Empty.
procedure Complete_Object_Operation
(Call_Node : Node_Id;
@@ -7104,6 +7104,14 @@
and then N = Name (Parent (N))
then
goto Next_Hom;
+
+ -- If the context is a function call, ignore procedures
+ -- in the name of the call.
+
+ elsif Ekind (Hom) = E_Procedure
+ and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
+ then
+ goto Next_Hom;
end if;
Set_Etype (Call_Node, Any_Type);
@@ -7271,16 +7279,39 @@
return;
end if;
- if Try_Primitive_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- or else
- Try_Class_Wide_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- then
- null;
- end if;
+ declare
+ Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node);
+ CW_Result : Boolean;
+ Prim_Result : Boolean;
+ pragma Unreferenced (CW_Result);
+
+ begin
+ Prim_Result :=
+ Try_Primitive_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+
+ -- Check if there is a class-wide subprogram covering the
+ -- primitive. This check must be done even if a candidate
+ -- was found in order to report ambiguous calls.
+
+ if not (Prim_Result) then
+ CW_Result :=
+ Try_Class_Wide_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+
+ -- If we found a primitive we search for class-wide subprograms
+ -- using a duplicate of the call node (done to avoid missing its
+ -- decoration if there is no ambiguity).
+
+ else
+ CW_Result :=
+ Try_Class_Wide_Operation
+ (Call_Node => Dup_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ end if;
+ end;
end Try_One_Prefix_Interpretation;
-----------------------------
