From: Ed Schonberg Date: Tue, 9 Jul 2019 07:54:35 +0000 (+0000) Subject: [Ada] Wrong resolution of equality operator with overloaded operand X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0ce858310c2bba03fc030f34f4217cb405020bcf;p=gcc.git [Ada] Wrong resolution of equality operator with overloaded operand This patch fixes a code generation error on an equality operation one of whose operands is an overloaded call, and several equality operators are visible. The resolution would succes but in some cases the wrong entity was lwfton the equality node, leading to expansion with the wrong interpretation. If the equality operation is the operand of a negation, the resolution of the negation must make direct use of the equality resolution, 2019-07-09 Ed Schonberg gcc/ada/ * sem_res.adb (Resolve_Equality_Op): If the node was overloaded, set properly the entity to which the node has been resolved. The original entity is the first one found during analysis, and is not necessarily the resolved one. (Resolve_Op_Not): If the argument of negation is an overloaded equality operation, call its resolution directly given that the context type does not participate in overload resolution. gcc/testsuite/ * gnat.dg/equal7.adb, gnat.dg/equal7_pkg.adb, gnat.dg/equal7_pkg.ads: New testcase. From-SVN: r273281 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 738be6128a6..adb86222a58 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2019-07-09 Ed Schonberg + + * sem_res.adb (Resolve_Equality_Op): If the node was overloaded, + set properly the entity to which the node has been resolved. The + original entity is the first one found during analysis, and is + not necessarily the resolved one. + (Resolve_Op_Not): If the argument of negation is an overloaded + equality operation, call its resolution directly given that the + context type does not participate in overload resolution. + 2019-07-09 Hristian Kirtchev * bindo.adb: Remove with and use clauses for Debug. Add with diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b86e7cce4b6..e32d5478c99 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8437,6 +8437,45 @@ package body Sem_Res is Explain_Redundancy (Original_Node (R)); end if; + -- If the equality is overloaded and the operands have resolved + -- properly, set the proper equality operator on the node. The + -- current setting is the first one found during analysis, which + -- is not necessarily the one to which the node has resolved. + + if Is_Overloaded (N) then + declare + I : Interp_Index; + It : Interp; + begin + Get_First_Interp (N, I, It); + + -- If the equality is user-defined, the type of the operands + -- matches that of the formals. For a predefined operqtor, + -- it is the scope that matters, given that the predefined + -- equality has Any_Type formals. In either case the result + -- type (most often Booleam) must match the context . + + while Present (It.Typ) loop + if Etype (It.Nam) = Typ + and then + (Etype (First_Entity (It.Nam)) = Etype (L) + or else Scope (It.Nam) = Scope (T)) + then + Set_Entity (N, It.Nam); + + Set_Is_Overloaded (N, False); + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Present (Alias (Entity (N))) then + Set_Entity (N, Alias (Entity (N))); + end if; + end; + end if; + Check_Unset_Reference (L); Check_Unset_Reference (R); Generate_Operator_Reference (N, T); @@ -10034,9 +10073,36 @@ package body Sem_Res is end if; -- Complete resolution and evaluation of NOT + -- If argument is an equality and expected type is boolean, that + -- expected type has no effect on resolution, and there are + -- special rules for resolution of Eq, Neq in the presence of + -- overloaded operands, so we directly call its resolution routines. + + declare + Opnd : constant Node_Id := Right_Opnd (N); + begin + if B_Typ = Standard_Boolean + and then Nkind_In (Opnd, N_Op_Eq, N_Op_Ne) + and then Is_Overloaded (Opnd) + then + Resolve_Equality_Op (Opnd, B_Typ); + if Ekind (Entity (Opnd)) = E_Function then + Rewrite_Operator_As_Call (Opnd, Entity (Opnd)); + end if; + + if not Inside_A_Generic or else Is_Entity_Name (Opnd) then + Freeze_Expression (Opnd); + end if; + + Expand (Opnd); + + else + Resolve (Opnd, B_Typ); + end if; + + Check_Unset_Reference (Opnd); + end; - Resolve (Right_Opnd (N), B_Typ); - Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Op_Not (N); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e1f16789a78..d50b7b2097f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-07-09 Ed Schonberg + + * gnat.dg/equal7.adb, gnat.dg/equal7_pkg.adb, + gnat.dg/equal7_pkg.ads: New testcase. + 2019-07-09 Javier Miranda * gnat.dg/range_check3.adb, gnat.dg/range_check3_pkg.adb, diff --git a/gcc/testsuite/gnat.dg/equal7.adb b/gcc/testsuite/gnat.dg/equal7.adb new file mode 100644 index 00000000000..2b278424622 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal7.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +with Equal7_Pkg; use Equal7_Pkg; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +procedure Equal7 is + X : constant Integer := 42; + +begin + if F (X) /= "" & ASCII.LF then + null; + end if; + if not (F (X) = "" & ASCII.LF) then + null; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/equal7_pkg.adb b/gcc/testsuite/gnat.dg/equal7_pkg.adb new file mode 100644 index 00000000000..171343f4577 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal7_pkg.adb @@ -0,0 +1,14 @@ +package body Equal7_Pkg is + + function F (X : Integer) return String is + begin + return To_String (F (X)); + end F; + + function F (X : Integer) return Unbounded_String is + Result : Unbounded_String; + begin + Append (Result, "hello" & X'Img); + return Result; + end; +end; diff --git a/gcc/testsuite/gnat.dg/equal7_pkg.ads b/gcc/testsuite/gnat.dg/equal7_pkg.ads new file mode 100644 index 00000000000..8fd601c99b3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal7_pkg.ads @@ -0,0 +1,16 @@ +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Finalization; use Ada.Finalization; +package Equal7_Pkg is + + type Editor_Location is abstract new Controlled with null record; + Nil_Editor_Location : constant Editor_Location'Class; + + function F (X : Integer) return Unbounded_String; + function F (X : Integer) return String; + +private + type Dummy_Editor_Location is new Editor_Location with null record; + + Nil_Editor_Location : constant Editor_Location'Class := + Dummy_Editor_Location'(Controlled with null record); +end;