This fixes an annoying discrepancy in the resolution of the type of
the elements of the choice list in a membership test. Consider:
Msg : String;
if Msg not in "" | "bypass" then
...
end if;
if not (Msg in "" or else Msg in "bypass") then
...
end if;
function Func return String;
function Func return Integer;
if Func not in "" | "bypass" then
...
end if;
In the former case, the type of the literals is resolved to the subtype
of Msg whereas, in the latter two cases, it is resolved to the base type.
Type resolution is a two-phase process here: first Analyze_Membership_Op
checks that the types (or the interpretations thereof) of the expression
and of all the elements of the choice list are compatible types; second,
Resolve_Membership_Op does the final resolution by picking a single type.
Resolve_Membership_Op invokes Intersect_Types to pick this single type,
which yields the base type in the case of strings, except in the former
case, where it directly uses the Etype of the left operand.
The change makes it so that Intersect_Types is invoked in all cases.
No functional changes.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-15 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* sem_res.adb (Resolve_Set_Membership): Remove local variable.
In the non-overloaded case, call Intersect_Types on the left
operand and the first alternative to get the resolution type.
But test the subtype of the left operand to give the warning.--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -9250,8 +9250,8 @@ package body Sem_Res is
T : Entity_Id;
procedure Resolve_Set_Membership;
- -- Analysis has determined a unique type for the left operand. Use it to
- -- resolve the disjuncts.
+ -- Analysis has determined a unique type for the left operand. Use it as
+ -- the basis to resolve the disjuncts.
----------------------------
-- Resolve_Set_Membership --
@@ -9259,18 +9259,17 @@ package body Sem_Res is
procedure Resolve_Set_Membership is
Alt : Node_Id;
- Ltyp : Entity_Id;
begin
-- If the left operand is overloaded, find type compatible with not
-- overloaded alternative of the right operand.
+ Alt := First (Alternatives (N));
if Is_Overloaded (L) then
- Ltyp := Empty;
- Alt := First (Alternatives (N));
+ T := Empty;
while Present (Alt) loop
if not Is_Overloaded (Alt) then
- Ltyp := Intersect_Types (L, Alt);
+ T := Intersect_Types (L, Alt);
exit;
else
Next (Alt);
@@ -9280,15 +9279,15 @@ package body Sem_Res is
-- Unclear how to resolve expression if all alternatives are also
-- overloaded.
- if No (Ltyp) then
+ if No (T) then
Error_Msg_N ("ambiguous expression", N);
end if;
else
- Ltyp := Etype (L);
+ T := Intersect_Types (L, Alt);
end if;
- Resolve (L, Ltyp);
+ Resolve (L, T);
Alt := First (Alternatives (N));
while Present (Alt) loop
@@ -9299,7 +9298,7 @@ package body Sem_Res is
if not Is_Entity_Name (Alt)
or else not Is_Type (Entity (Alt))
then
- Resolve (Alt, Ltyp);
+ Resolve (Alt, T);
end if;
Next (Alt);
@@ -9307,7 +9306,7 @@ package body Sem_Res is
-- Check for duplicates for discrete case
- if Is_Discrete_Type (Ltyp) then
+ if Is_Discrete_Type (T) then
declare
type Ent is record
Alt : Node_Id;
@@ -9350,11 +9349,11 @@ package body Sem_Res is
-- equality for the type. This may be confusing to users, and the
-- following warning appears useful for the most common case.
- if Is_Scalar_Type (Ltyp)
- and then Present (Get_User_Defined_Eq (Ltyp))
+ if Is_Scalar_Type (Etype (L))
+ and then Present (Get_User_Defined_Eq (Etype (L)))
then
Error_Msg_NE
- ("membership test on& uses predefined equality?", N, Ltyp);
+ ("membership test on& uses predefined equality?", N, Etype (L));
Error_Msg_N
("\even if user-defined equality exists (RM 4.5.2 (28.1/3)?", N);
end if;
