@@ -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;
new file mode 100644
@@ -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;
new file mode 100644
@@ -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;