From 118f2d8bc3e6804996ca2953b86454ec950054bf Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 17 Jul 2018 08:13:28 +0000 Subject: [PATCH] [Ada] Spurious error on prefixed call in an instantiation 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. 2018-07-17 Ed Schonberg 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. From-SVN: r262803 --- gcc/ada/ChangeLog | 9 ++ gcc/ada/sem_ch4.adb | 87 +++++++++++++++----- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gnat.dg/generic_call_cw.adb | 33 ++++++++ gcc/testsuite/gnat.dg/generic_call_iface.adb | 34 ++++++++ 5 files changed, 146 insertions(+), 22 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/generic_call_cw.adb create mode 100644 gcc/testsuite/gnat.dg/generic_call_iface.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 21b7bb897fc..2375e80ae41 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-07-17 Ed Schonberg + + * 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. + 2018-07-17 Arnaud Charlet * sem_eval.adb (Rewrite_In_Raise_CE): Keep the original reason in more diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index def317d916c..597ec1ed939 100644 --- a/gcc/ada/sem_ch4.adb +++ b/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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e24b35d5d19..652d164a85c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-07-17 Ed Schonberg + + * gnat.dg/generic_call_cw.adb, gnat.dg/generic_call_iface.adb: New + testcase. + 2018-07-17 Eric Botcazou * gnat.dg/sso10.adb, gnat.dg/sso10_pkg.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/generic_call_cw.adb b/gcc/testsuite/gnat.dg/generic_call_cw.adb new file mode 100644 index 00000000000..5f0a51412e4 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/generic_call_iface.adb b/gcc/testsuite/gnat.dg/generic_call_iface.adb new file mode 100644 index 00000000000..0e173ea73c8 --- /dev/null +++ b/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; -- 2.30.2