Has_Compatible_Type is essentially a wrapper around Covers in Sem_Type that
handles overloading and a few other details, i.e. calling:
Has_Compatible_Type (N, Typ)
is morally equivalent to calling:
Covers (Typ, Etype (N)) or Covers (Typ, Interp (N))
Except that the implementation also performs the reversed tests when Typ is
neither a tagged nor an anonymous access type and this is questionable.
This change removes the reversed tests in the general case and add them back
only in the few cases where they are still needed for now. This reduces the
total number of calls to Covers by 50%.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_ch4.adb (Analyze_Membership_Op) <Find_Interpretation>: Handle
both overloaded and non-overloaded cases.
<Try_One_Interp>: Do a reversed call to Covers if the outcome of the
call to Has_Compatible_Type is false.
Simplify implementation after change to Find_Interpretation.
(Analyze_User_Defined_Binary_Op): Be prepared for previous errors.
(Find_Comparison_Types) <Try_One_Interp>: Do a reversed call to
Covers if the outcome of the call to Has_Compatible_Type is false.
(Find_Equality_Types) <Try_One_Interp>: Likewise.
* sem_type.adb (Has_Compatible_Type): Remove the reversed calls to
Covers. Add explicit return on all paths.diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2976,10 +2976,7 @@ package body Sem_Ch4 is
procedure Find_Interpretation;
function Find_Interpretation return Boolean;
- -- Routine and wrapper to find a matching interpretation in case
- -- of overloading. The wrapper returns True iff a matching
- -- interpretation is found. Beware, in absence of overloading,
- -- using this function will break gnat's bootstrapping.
+ -- Routine and wrapper to find a matching interpretation
procedure Try_One_Interp (T1 : Entity_Id);
-- Routine to try one proposed interpretation. Note that the context
@@ -3091,11 +3088,16 @@ package body Sem_Ch4 is
procedure Find_Interpretation is
begin
- Get_First_Interp (L, Index, It);
- while Present (It.Typ) loop
- Try_One_Interp (It.Typ);
- Get_Next_Interp (Index, It);
- end loop;
+ if not Is_Overloaded (L) then
+ Try_One_Interp (Etype (L));
+
+ else
+ Get_First_Interp (L, Index, It);
+ while Present (It.Typ) loop
+ Try_One_Interp (It.Typ);
+ Get_Next_Interp (Index, It);
+ end loop;
+ end if;
end Find_Interpretation;
function Find_Interpretation return Boolean is
@@ -3111,7 +3113,7 @@ package body Sem_Ch4 is
procedure Try_One_Interp (T1 : Entity_Id) is
begin
- if Has_Compatible_Type (R, T1) then
+ if Has_Compatible_Type (R, T1) or else Covers (Etype (R), T1) then
if Found
and then Base_Type (T1) /= Base_Type (T_F)
then
@@ -3156,12 +3158,7 @@ package body Sem_Ch4 is
then
Analyze (R);
- if not Is_Overloaded (L) then
- Try_One_Interp (Etype (L));
-
- else
- Find_Interpretation;
- end if;
+ Find_Interpretation;
-- If not a range, it can be a subtype mark, or else it is a degenerate
-- membership test with a singleton value, i.e. a test for equality,
@@ -3170,16 +3167,11 @@ package body Sem_Ch4 is
else
Analyze (R);
- if Is_Entity_Name (R)
- and then Is_Type (Entity (R))
- then
+ if Is_Entity_Name (R) and then Is_Type (Entity (R)) then
Find_Type (R);
Check_Fully_Declared (Entity (R), R);
- elsif Ada_Version >= Ada_2012 and then
- ((Is_Overloaded (L) and then Find_Interpretation) or else
- (not Is_Overloaded (L) and then Has_Compatible_Type (R, Etype (L))))
- then
+ elsif Ada_Version >= Ada_2012 and then Find_Interpretation then
if Nkind (N) = N_In then
Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
else
@@ -5918,14 +5910,16 @@ package body Sem_Ch4 is
begin
-- Verify that Op_Id is a visible binary function. Note that since
-- we know Op_Id is overloaded, potentially use visible means use
- -- visible for sure (RM 9.4(11)).
+ -- visible for sure (RM 9.4(11)). Be prepared for previous errors.
if Ekind (Op_Id) = E_Function
and then Present (F2)
and then (Is_Immediately_Visible (Op_Id)
or else Is_Potentially_Use_Visible (Op_Id))
- and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
- and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
+ and then (Has_Compatible_Type (Left_Opnd (N), Etype (F1))
+ or else Etype (F1) = Any_Type)
+ and then (Has_Compatible_Type (Right_Opnd (N), Etype (F2))
+ or else Etype (F2) = Any_Type)
then
Add_One_Interp (N, Op_Id, Etype (Op_Id));
@@ -6612,7 +6606,10 @@ package body Sem_Ch4 is
return;
end if;
- if Valid_Comparison_Arg (T1) and then Has_Compatible_Type (R, T1) then
+ if Valid_Comparison_Arg (T1)
+ and then (Has_Compatible_Type (R, T1)
+ or else Covers (Etype (R), T1))
+ then
if Found and then Base_Type (T1) /= Base_Type (T_F) then
It := Disambiguate (L, I_F, Index, Any_Type);
@@ -6710,6 +6707,7 @@ package body Sem_Ch4 is
Get_Next_Interp (Index, It);
end loop;
end if;
+
elsif Has_Compatible_Type (R, T1) or else Covers (Etype (R), T1) then
Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
end if;
@@ -7100,7 +7098,9 @@ package body Sem_Ch4 is
-- Finally, also check for RM 4.5.2 (9.6/2).
if T1 /= Standard_Void_Type
- and then (Universal_Access or else Has_Compatible_Type (R, T1))
+ and then (Universal_Access
+ or else Has_Compatible_Type (R, T1)
+ or else Covers (Etype (R), T1))
and then
((not Is_Limited_Type (T1)
@@ -7161,9 +7161,7 @@ package body Sem_Ch4 is
-- If left operand is aggregate, the right operand has to
-- provide a usable type for it.
- if Nkind (L) = N_Aggregate
- and then Nkind (R) /= N_Aggregate
- then
+ if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then
Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N);
return;
end if;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -2449,11 +2449,8 @@ package body Sem_Type is
return False;
end if;
- if Nkind (N) = N_Subtype_Indication
- or else not Is_Overloaded (N)
- then
- return
- Covers (Typ, Etype (N))
+ if Nkind (N) = N_Subtype_Indication or else not Is_Overloaded (N) then
+ if Covers (Typ, Etype (N))
-- Ada 2005 (AI-345): The context may be a synchronized interface.
-- If the type is already frozen use the corresponding_record
@@ -2471,11 +2468,6 @@ package body Sem_Type is
and then Present (Corresponding_Record_Type (Typ))
and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
- or else
- (not Is_Tagged_Type (Typ)
- and then Ekind (Typ) /= E_Anonymous_Access_Type
- and then Covers (Etype (N), Typ))
-
or else
(Nkind (N) = N_Integer_Literal
and then Present (Find_Aspect (Typ, Aspect_Integer_Literal)))
@@ -2486,7 +2478,10 @@ package body Sem_Type is
or else
(Nkind (N) = N_String_Literal
- and then Present (Find_Aspect (Typ, Aspect_String_Literal)));
+ and then Present (Find_Aspect (Typ, Aspect_String_Literal)))
+ then
+ return True;
+ end if;
-- Overloaded case
@@ -2501,24 +2496,22 @@ package body Sem_Type is
-- Ada 2005 (AI-345)
or else
- (Is_Concurrent_Type (It.Typ)
+ (Is_Record_Type (Typ)
+ and then Is_Concurrent_Type (It.Typ)
and then Present (Corresponding_Record_Type
(Etype (It.Typ)))
and then Covers (Typ, Corresponding_Record_Type
(Etype (It.Typ))))
- or else (not Is_Tagged_Type (Typ)
- and then Ekind (Typ) /= E_Anonymous_Access_Type
- and then Covers (It.Typ, Typ))
then
return True;
end if;
Get_Next_Interp (I, It);
end loop;
-
- return False;
end if;
+
+ return False;
end Has_Compatible_Type;
---------------------
