From 003fe1356b3963c678a0f1be40cd764264fa60ab Mon Sep 17 00:00:00 2001
From: Eric Botcazou <ebotcazou@adacore.com>
Date: Sun, 15 Oct 2023 13:00:10 +0200
Subject: [PATCH] ada: Fix incorrect resolution of overloaded function call in
instance
The problem occurs when the function call is the operand of an equality
operator, the type used to do the comparison is declared outside of the
generic construct but visible inside it, and this generic construct also
declares two functions with the same profile except for the result type,
one result type being the aforementioned type, the other being derived
from this type but not visible inside the generic construct. When the
second operand is either a literal or also overloaded, the call may be
resolved to the second function instead of the first in instances.
gcc/ada/
* gen_il-fields.ads (Opt_Field_Enum): Add Compare_Type.
* gen_il-gen-gen_nodes.adb (N_Op_Eq): Likewise.
(N_Op_Ge): Likewise.
(N_Op_Gt): Likewise.
(N_Op_Le): Likewise.
(N_Op_Lt): Likewise.
(N_Op_Ne): Likewise.
* sinfo.ads (Compare_Type): Document new field.
* sem_ch4.adb (Analyze_Comparison_Equality_Op): If the entity is
already present, set the Compare_Type on overloaded operands if it
is present on the node.
* sem_ch12.adb (Check_Private_View): Look into the Compare_Type
instead of the Etype for comparison operators.
(Copy_Generic_Node): Remove obsolete code for comparison
operators.
(Save_Global_References.Save_References): Do not walk into the
descendants of N_Implicit_Label_Declaration nodes.
(Save_Global_References.Set_Global_Type): Look into the
Compare_Type instead of the Etype for comparison operators.
* sem_res.adb (Resolve_Comparison_Op): Set Compare_Type.
(Resolve_Equality_Op): Likewise.
---
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_nodes.adb | 18 +++++---
gcc/ada/sem_ch12.adb | 72 ++++++++++++++++++--------------
gcc/ada/sem_ch4.adb | 15 +++++--
gcc/ada/sem_res.adb | 2 +
gcc/ada/sinfo.ads | 20 +++++++++
6 files changed, 87 insertions(+), 41 deletions(-)
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 1b40cd9472ef..a0bfb398ebb3 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -99,6 +99,7 @@ package Gen_IL.Fields is
Comes_From_Check_Or_Contract,
Comes_From_Extended_Return_Statement,
Comes_From_Iterator,
+ Compare_Type,
Compile_Time_Known_Aggregate,
Component_Associations,
Component_Clauses,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index fdf928d60a37..996d8d78aeae 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -267,32 +267,38 @@ begin -- Gen_IL.Gen.Gen_Nodes
Cc (N_Op_Eq, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Ge, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Gt, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Le, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Lt, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Ne, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Or, N_Op_Boolean,
(Sm (Chars, Name_Id),
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 582940da74bc..f73e1b53b0e3 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -7685,7 +7685,9 @@ package body Sem_Ch12 is
------------------------
procedure Check_Private_View (N : Node_Id) is
- Typ : constant Entity_Id := Etype (N);
+ Comparison : constant Boolean := Nkind (N) in N_Op_Compare;
+ Typ : constant Entity_Id :=
+ (if Comparison then Compare_Type (N) else Etype (N));
procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean);
-- Check that the available view of T matches Private_View and, if not,
@@ -7749,10 +7751,16 @@ package body Sem_Ch12 is
and then (not In_Open_Scopes (Scope (Typ))
or else Nkind (Parent (N)) = N_Subtype_Declaration)
then
- -- In the generic, only the private declaration was visible
+ declare
+ Assoc : constant Node_Id := Get_Associated_Node (N);
+
+ begin
+ -- In the generic, only the private declaration was visible
- Prepend_Elmt (Typ, Exchanged_Views);
- Exchange_Declarations (Etype (Get_Associated_Node (N)));
+ Prepend_Elmt (Typ, Exchanged_Views);
+ Exchange_Declarations
+ (if Comparison then Compare_Type (Assoc) else Etype (Assoc));
+ end;
-- Check that the available views of Typ match their respective flag.
-- Note that the type of a visible discriminant is never private.
@@ -8166,30 +8174,6 @@ package body Sem_Ch12 is
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
- -- For the comparison and equality operators, the Etype
- -- of the operator does not provide any information so,
- -- if one of the operands is of a universal type, we need
- -- to manually restore the full view of private types.
-
- if Nkind (N) in N_Op_Compare then
- if Yields_Universal_Type (Left_Opnd (Assoc)) then
- if Present (Etype (Right_Opnd (Assoc)))
- and then
- Is_Private_Type (Etype (Right_Opnd (Assoc)))
- then
- Switch_View (Etype (Right_Opnd (Assoc)));
- end if;
-
- elsif Yields_Universal_Type (Right_Opnd (Assoc)) then
- if Present (Etype (Left_Opnd (Assoc)))
- and then
- Is_Private_Type (Etype (Left_Opnd (Assoc)))
- then
- Switch_View (Etype (Left_Opnd (Assoc)));
- end if;
- end if;
- end if;
-
-- The node is a reference to a global type and acts as the
-- subtype mark of a qualified expression created in order
-- to aid resolution of accidental overloading in instances.
@@ -16883,6 +16867,11 @@ package body Sem_Ch12 is
end if;
end;
+ -- Do not walk the node pointed to by Label_Construct twice
+
+ elsif Nkind (N) = N_Implicit_Label_Declaration then
+ null;
+
else
Save_References_In_Descendants (N);
end if;
@@ -16894,10 +16883,27 @@ package body Sem_Ch12 is
---------------------
procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
- Typ : constant Entity_Id := Etype (N2);
+ Comparison : constant Boolean := Nkind (N2) in N_Op_Compare;
+ Typ : constant Entity_Id :=
+ (if Comparison then Compare_Type (N2) else Etype (N2));
begin
- Set_Etype (N, Typ);
+ -- For a comparison (or equality) operator, the Etype is Boolean, so
+ -- it is always global. But the type subject to the Has_Private_View
+ -- processing is the Compare_Type, so we must specifically check it.
+
+ if Comparison then
+ Set_Etype (N, Etype (N2));
+
+ if not Is_Global (Typ) then
+ return;
+ end if;
+
+ Set_Compare_Type (N, Typ);
+
+ else
+ Set_Etype (N, Typ);
+ end if;
-- If the entity of N is not the associated node, this is a
-- nested generic and it has an associated node as well, whose
@@ -16939,7 +16945,11 @@ package body Sem_Ch12 is
Set_Has_Private_View (N);
if Present (Full_View (Typ)) then
- Set_Etype (N2, Full_View (Typ));
+ if Comparison then
+ Set_Compare_Type (N2, Full_View (Typ));
+ else
+ Set_Etype (N2, Full_View (Typ));
+ end if;
end if;
end if;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 78249258f55c..83705b9dae1b 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2057,8 +2057,9 @@ package body Sem_Ch4 is
-- For the predefined case, the result is Boolean, regardless of the
-- type of the operands. The operands may even be limited, if they are
-- generic actuals. If they are overloaded, label the operands with the
- -- common type that must be present, or with the type of the formal of
- -- the user-defined function.
+ -- compare type if it is present, typically because it is a global type
+ -- in a generic instance, or with the common type that must be present,
+ -- or with the type of the formal of the user-defined function.
if Present (Entity (N)) then
Op_Id := Entity (N);
@@ -2071,7 +2072,10 @@ package body Sem_Ch4 is
if Is_Overloaded (L) then
if Ekind (Op_Id) = E_Operator then
- Set_Etype (L, Intersect_Types (L, R));
+ Set_Etype (L,
+ (if Present (Compare_Type (N))
+ then Compare_Type (N)
+ else Intersect_Types (L, R)));
else
Set_Etype (L, Etype (First_Formal (Op_Id)));
end if;
@@ -2079,7 +2083,10 @@ package body Sem_Ch4 is
if Is_Overloaded (R) then
if Ekind (Op_Id) = E_Operator then
- Set_Etype (R, Intersect_Types (L, R));
+ Set_Etype (R,
+ (if Present (Compare_Type (N))
+ then Compare_Type (N)
+ else Intersect_Types (L, R)));
else
Set_Etype (R, Etype (Next_Formal (First_Formal (Op_Id))));
end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index fa1365c26417..42f7c10c5c59 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7611,6 +7611,7 @@ package body Sem_Res is
Resolve (L, T);
Resolve (R, T);
+ Set_Compare_Type (N, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
@@ -9119,6 +9120,7 @@ package body Sem_Res is
Resolve (L, T);
Resolve (R, T);
+ Set_Compare_Type (N, T);
-- AI12-0413: user-defined primitive equality of an untagged record
-- type hides the predefined equality operator, including within a
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index fc9bcfbd44db..8f9626019853 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -962,6 +962,20 @@ package Sinfo is
-- was constructed as part of the expansion of an iterator
-- specification.
+ -- Compare_Type
+ -- Present in N_Op_Compare nodes. Set during resolution to the type of
+ -- the operands. It is used to propagate the type of the operands from
+ -- a N_Op_Compare node in a generic construct to the nodes created from
+ -- it in the various instances, when this type is global to the generic
+ -- construct. Resolution for global types cannot be redone in instances
+ -- because the instantiation can be done out of context, e.g. for bodies,
+ -- and the visibility of global types is incorrect in this case; that is
+ -- why the result of the resolution done in the generic construct needs
+ -- to be available in the instances but, unlike for arithmetic operators,
+ -- the Etype cannot be used to that effect for comparison operators. It
+ -- is also used as the type subject to the Has_Private_View processing on
+ -- the nodes instead of the Etype.
+
-- Compile_Time_Known_Aggregate
-- Present in N_Aggregate nodes. Set for aggregates which can be fully
-- evaluated at compile time without raising constraint error. Such
@@ -4507,31 +4521,37 @@ package Sinfo is
-- N_Op_Eq
-- Sloc points to =
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Ne
-- Sloc points to /=
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Lt
-- Sloc points to <
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Le
-- Sloc points to <=
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Gt
-- Sloc points to >
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Ge
-- Sloc points to >=
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
--
GitLab