From 7df3ac2e9ed53f9320a63f38081561166b140cf2 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Wed, 27 Oct 2021 23:51:07 +0200 Subject: [PATCH] [Ada] Tidy up implementation of Has_Compatible_Type gcc/ada/ * sem_ch4.adb (Analyze_Membership_Op) : Handle both overloaded and non-overloaded cases. : 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) : Do a reversed call to Covers if the outcome of the call to Has_Compatible_Type is false. (Find_Equality_Types) : Likewise. * sem_type.adb (Has_Compatible_Type): Remove the reversed calls to Covers. Add explicit return on all paths. --- gcc/ada/sem_ch4.adb | 60 +++++++++++++++++++++++++--------------------------- gcc/ada/sem_type.adb | 27 +++++++++-------------- 2 files changed, 39 insertions(+), 48 deletions(-) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 22039f5..9b1d908 100644 --- 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 index 8e5b067..923c8f9 100644 --- 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 @@ -2472,11 +2469,6 @@ package body Sem_Type is 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; --------------------- -- 2.7.4