This patch fixes a spurious error on a prefixed call in an instance, when the
generic parameters include an interface type and an abstract operation of that
type, and the actuals in the instance include an interface type and a
corresponding abstract operation of it, with a different name than the
corresponding generic subprogram parameter. The patch also fixes a similar
error involving class-wide operations and generic private types.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Ed Schonberg <schonb...@adacore.com>
gcc/ada/
* sem_ch4.adb (Try_Object_Operation): Handle properly a prefixed call
in an instance, when the generic parameters include an interface type
and a abstract operation of that type, and the actuals in the instance
include an interface type and a corresponding abstract operation of it,
with a different name than the corresponding generic subprogram
parameter.
gcc/testsuite/
* gnat.dg/generic_call_cw.adb, gnat.dg/generic_call_iface.adb: New
testcase.--- gcc/ada/sem_ch4.adb
+++ gcc/ada/sem_ch4.adb
@@ -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;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/generic_call_cw.adb
@@ -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;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/generic_call_iface.adb
@@ -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;
