diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c709a1f56fd..9fed73d92a4 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4846,23 +4846,29 @@ package Einfo is -- E_Access_Type, -- E_General_Access_Type, +-- E_Anonymous_Access_Type + -- E_Access_Subprogram_Type, -- E_Anonymous_Access_Subprogram_Type, + -- E_Access_Protected_Subprogram_Type, -- E_Anonymous_Access_Protected_Subprogram_Type --- E_Anonymous_Access_Type. --- E_Access_Subtype is for an access subtype created by a subtype --- declaration. +-- E_Access_Subtype is for an access subtype created by a subtype declaration -- In addition, we define the kind E_Allocator_Type to label allocators. -- This is because special resolution rules apply to this construct. -- Eventually the constructs are labeled with the access type imposed by -- the context. The backend should never see types with this Ekind. --- Similarly, the type E_Access_Attribute_Type is used as the initial kind --- associated with an access attribute. After resolution a specific access --- type will be established as determined by the context. +-- Similarly, we define the kind E_Access_Attribute_Type as the initial +-- kind associated with an access attribute whose prefix is an object. +-- After resolution, a specific access type will be established instead +-- as determined by the context. Note that, for the case of an access +-- attribute whose prefix is a subprogram, we build a corresponding type +-- with E_Access_Subprogram_Type or E_Access_Protected_Subprogram_Type kind +-- but whose designated type is the subprogram itself, instead of a regular +-- E_Subprogram_Type entity. -------------------------------------------------------- -- Description of Defined Attributes for Entity_Kinds -- diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index c88826abf73..ea6469007c2 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -380,22 +380,22 @@ package body Sem is Analyze_Arithmetic_Op (N); when N_Op_Eq => - Analyze_Equality_Op (N); + Analyze_Comparison_Equality_Op (N); when N_Op_Expon => Analyze_Arithmetic_Op (N); when N_Op_Ge => - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); when N_Op_Gt => - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); when N_Op_Le => - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); when N_Op_Lt => - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); when N_Op_Minus => Analyze_Unary_Op (N); @@ -407,7 +407,7 @@ package body Sem is Analyze_Arithmetic_Op (N); when N_Op_Ne => - Analyze_Equality_Op (N); + Analyze_Comparison_Equality_Op (N); when N_Op_Not => Analyze_Negation (N); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 918f3b84dcc..68839b31345 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -148,10 +148,6 @@ package body Sem_Ch4 is -- like a function, but instead of a list of actuals, it is presented with -- the operand of the operator node. - procedure Ambiguous_Operands (N : Node_Id); - -- For equality, membership, and comparison operators with overloaded - -- arguments, list possible interpretations. - procedure Analyze_One_Call (N : Node_Id; Nam : Entity_Id; @@ -184,12 +180,6 @@ package body Sem_Ch4 is -- Analyze_Selected_Component after producing an invalid selector error -- message. - function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean; - -- Verify that type T is declared in scope S. Used to find interpretations - -- for operators given by expanded names. This is abstracted as a separate - -- function to handle extensions to System, where S is System, but T is - -- declared in the extension. - procedure Find_Arithmetic_Types (L, R : Node_Id; Op_Id : Entity_Id; @@ -198,12 +188,12 @@ package body Sem_Ch4 is -- pairs of interpretations for L and R that have a numeric type consistent -- with the semantics of the operator. - procedure Find_Comparison_Types + procedure Find_Comparison_Equality_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); - -- L and R are operands of a comparison operator. Find consistent pairs of - -- interpretations for L and R. + -- L and R are operands of a comparison or equality operator. Find valid + -- pairs of interpretations for L and R. procedure Find_Concatenation_Types (L, R : Node_Id; @@ -211,12 +201,6 @@ package body Sem_Ch4 is N : Node_Id); -- For the four varieties of concatenation - procedure Find_Equality_Types - (L, R : Node_Id; - Op_Id : Entity_Id; - N : Node_Id); - -- Ditto for equality operators - procedure Find_Boolean_Types (L, R : Node_Id; Op_Id : Entity_Id; @@ -229,18 +213,6 @@ package body Sem_Ch4 is N : Node_Id); -- Find consistent interpretation for operand of negation operator - procedure Find_Non_Universal_Interpretations - (N : Node_Id; - R : Node_Id; - Op_Id : Entity_Id; - T1 : Entity_Id); - -- For equality and comparison operators, the result is always boolean, and - -- the legality of the operation is determined from the visibility of the - -- operand types. If one of the operands has a universal interpretation, - -- the legality check uses some compatible non-universal interpretation of - -- the other operand. N can be an operator node, or a function call whose - -- name is an operator designator. - function Find_Primitive_Operation (N : Node_Id) return Boolean; -- Find candidate interpretations for the name Obj.Proc when it appears in -- a subprogram renaming declaration. @@ -911,12 +883,15 @@ package body Sem_Ch4 is --------------------------- procedure Analyze_Arithmetic_Op (N : Node_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id; begin + Set_Etype (N, Any_Type); Candidate_Type := Empty; + Analyze_Expression (L); Analyze_Expression (R); @@ -926,22 +901,18 @@ package body Sem_Ch4 is -- and we do not need to collect interpretations, instead we just get -- the single possible interpretation. - Op_Id := Entity (N); + if Present (Entity (N)) then + Op_Id := Entity (N); - if Present (Op_Id) then if Ekind (Op_Id) = E_Operator then - Set_Etype (N, Any_Type); Find_Arithmetic_Types (L, R, Op_Id, N); else - Set_Etype (N, Any_Type); Add_One_Interp (N, Op_Id, Etype (Op_Id)); end if; -- Entity is not already set, so we do need to collect interpretations else - Set_Etype (N, Any_Type); - Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator @@ -1761,50 +1732,6 @@ package body Sem_Ch4 is end if; end Analyze_Case_Expression; - --------------------------- - -- Analyze_Comparison_Op -- - --------------------------- - - procedure Analyze_Comparison_Op (N : Node_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - Op_Id : Entity_Id := Entity (N); - - begin - Set_Etype (N, Any_Type); - Candidate_Type := Empty; - - Analyze_Expression (L); - Analyze_Expression (R); - - if Present (Op_Id) then - if Ekind (Op_Id) = E_Operator then - Find_Comparison_Types (L, R, Op_Id, N); - else - Add_One_Interp (N, Op_Id, Etype (Op_Id)); - end if; - - if Is_Overloaded (L) then - Set_Etype (L, Intersect_Types (L, R)); - end if; - - else - Op_Id := Get_Name_Entity_Id (Chars (N)); - while Present (Op_Id) loop - if Ekind (Op_Id) = E_Operator then - Find_Comparison_Types (L, R, Op_Id, N); - else - Analyze_User_Defined_Binary_Op (N, Op_Id); - end if; - - Op_Id := Homonym (Op_Id); - end loop; - end if; - - Operator_Check (N); - Check_Function_Writable_Actuals (N); - end Analyze_Comparison_Op; - --------------------------- -- Analyze_Concatenation -- --------------------------- @@ -1956,14 +1883,15 @@ package body Sem_Ch4 is Operator_Check (N); end Analyze_Concatenation_Rest; - ------------------------- - -- Analyze_Equality_Op -- - ------------------------- + ------------------------------------ + -- Analyze_Comparison_Equality_Op -- + ------------------------------------ + + procedure Analyze_Comparison_Equality_Op (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); - procedure Analyze_Equality_Op (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; begin @@ -1980,9 +1908,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 left argument with - -- the common type that must be present, or with the type of the formal - -- of the user-defined function. + -- 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. if Present (Entity (N)) then Op_Id := Entity (N); @@ -2001,11 +1929,20 @@ package body Sem_Ch4 is end if; end if; + if Is_Overloaded (R) then + if Ekind (Op_Id) = E_Operator then + Set_Etype (R, Intersect_Types (L, R)); + else + Set_Etype (R, Etype (Next_Formal (First_Formal (Op_Id)))); + end if; + end if; + else Op_Id := Get_Name_Entity_Id (Chars (N)); + while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then - Find_Equality_Types (L, R, Op_Id, N); + Find_Comparison_Equality_Types (L, R, Op_Id, N); else Analyze_User_Defined_Binary_Op (N, Op_Id); end if; @@ -2026,7 +1963,7 @@ package body Sem_Ch4 is Op_Id := Get_Name_Entity_Id (Name_Op_Eq); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then - Find_Equality_Types (L, R, Op_Id, N); + Find_Comparison_Equality_Types (L, R, Op_Id, N); else Analyze_User_Defined_Binary_Op (N, Op_Id); end if; @@ -2051,7 +1988,7 @@ package body Sem_Ch4 is Operator_Check (N); Check_Function_Writable_Actuals (N); - end Analyze_Equality_Op; + end Analyze_Comparison_Equality_Op; ---------------------------------- -- Analyze_Explicit_Dereference -- @@ -2259,7 +2196,6 @@ package body Sem_Ch4 is procedure Analyze_Expression (N : Node_Id) is begin - -- If the expression is an indexed component that will be rewritten -- as a container indexing, it has already been analyzed. @@ -2909,9 +2845,10 @@ package body Sem_Ch4 is ------------------------ procedure Analyze_Logical_Op (N : Node_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - Op_Id : Entity_Id := Entity (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + + Op_Id : Entity_Id; begin Set_Etype (N, Any_Type); @@ -2920,7 +2857,14 @@ package body Sem_Ch4 is Analyze_Expression (L); Analyze_Expression (R); - if Present (Op_Id) then + -- If the entity is already set, the node is the instantiation of a + -- generic node with a non-local reference, or was manufactured by a + -- call to Make_Op_xxx. In either case the entity is known to be valid, + -- and we do not need to collect interpretations, instead we just get + -- the single possible interpretation. + + if Present (Entity (N)) then + Op_Id := Entity (N); if Ekind (Op_Id) = E_Operator then Find_Boolean_Types (L, R, Op_Id, N); @@ -2928,6 +2872,8 @@ package body Sem_Ch4 is Add_One_Interp (N, Op_Id, Etype (Op_Id)); end if; + -- Entity is not already set, so we do need to collect interpretations + else Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop @@ -2954,25 +2900,24 @@ package body Sem_Ch4 is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); - Index : Interp_Index; - It : Interp; - Found : Boolean := False; - I_F : Interp_Index; - T_F : Entity_Id; - procedure Analyze_Set_Membership; -- If a set of alternatives is present, analyze each and find the -- common type to which they must all resolve. - procedure Find_Interpretation; - function Find_Interpretation return Boolean; - -- Routine and wrapper to find a matching interpretation + function Find_Interp return Boolean; + -- Find a valid interpretation of the test. Note that the context of the + -- operation plays no role in resolving the operands, so that if there + -- is more than one interpretation of the operands that is compatible + -- with the test, the operation is ambiguous. - procedure Try_One_Interp (T1 : Entity_Id); - -- Routine to try one proposed interpretation. Note that the context - -- of the operation plays no role in resolving the arguments, so that - -- if there is more than one interpretation of the operands that is - -- compatible with a membership test, the operation is ambiguous. + function Try_Left_Interp (T : Entity_Id) return Boolean; + -- Try an interpretation of the left operand with type T. Return true if + -- one interpretation (at least) of the right operand making up a valid + -- operand pair exists, otherwise false if no such pair exists. + + function Is_Valid_Pair (T1, T2 : Entity_Id) return Boolean; + -- Return true if T1 and T2 constitute a valid pair of operand types for + -- L and R respectively. ---------------------------- -- Analyze_Set_Membership -- @@ -3055,8 +3000,6 @@ package body Sem_Ch4 is end loop; end if; - Set_Etype (N, Standard_Boolean); - if Present (Common_Type) then Set_Etype (L, Common_Type); @@ -3068,63 +3011,134 @@ package body Sem_Ch4 is end if; end Analyze_Set_Membership; - ------------------------- - -- Find_Interpretation -- - ------------------------- + ----------------- + -- Find_Interp -- + ----------------- + + function Find_Interp return Boolean is + Found : Boolean; + I : Interp_Index; + It : Interp; + L_Typ : Entity_Id; + Valid_I : Interp_Index; - procedure Find_Interpretation is begin + -- Loop through the interpretations of the left operand + if not Is_Overloaded (L) then - Try_One_Interp (Etype (L)); + Found := Try_Left_Interp (Etype (L)); else - Get_First_Interp (L, Index, It); + Found := False; + L_Typ := Empty; + Valid_I := 0; + + Get_First_Interp (L, I, It); while Present (It.Typ) loop - Try_One_Interp (It.Typ); - Get_Next_Interp (Index, It); - end loop; - end if; - end Find_Interpretation; + if Try_Left_Interp (It.Typ) then + -- If several interpretations are possible, disambiguate - function Find_Interpretation return Boolean is - begin - Find_Interpretation; + if Present (L_Typ) + and then Base_Type (It.Typ) /= Base_Type (L_Typ) + then + It := Disambiguate (L, Valid_I, I, Any_Type); - return Found; - end Find_Interpretation; + if It = No_Interp then + Ambiguous_Operands (N); + Set_Etype (L, Any_Type); + return True; + end if; - -------------------- - -- Try_One_Interp -- - -------------------- + else + Valid_I := I; + end if; - procedure Try_One_Interp (T1 : Entity_Id) is - begin - if Has_Compatible_Type (R, T1, For_Comparison => True) then - if Found - and then Base_Type (T1) /= Base_Type (T_F) - then - It := Disambiguate (L, I_F, Index, Any_Type); - - if It = No_Interp then - Ambiguous_Operands (N); - Set_Etype (L, Any_Type); - return; - - else - T_F := It.Typ; + L_Typ := It.Typ; + Set_Etype (L, L_Typ); + Found := True; end if; - else - Found := True; - T_F := T1; - I_F := Index; - end if; - - Set_Etype (L, T_F); + Get_Next_Interp (I, It); + end loop; end if; - end Try_One_Interp; - Op : Node_Id; + return Found; + end Find_Interp; + + --------------------- + -- Try_Left_Interp -- + --------------------- + + function Try_Left_Interp (T : Entity_Id) return Boolean is + Found : Boolean; + I : Interp_Index; + It : Interp; + R_Typ : Entity_Id; + Valid_I : Interp_Index; + + begin + -- Defend against previous error + + if Nkind (R) = N_Error then + Found := False; + + -- Loop through the interpretations of the right operand + + elsif not Is_Overloaded (R) then + Found := Is_Valid_Pair (T, Etype (R)); + + else + Found := False; + R_Typ := Empty; + Valid_I := 0; + + Get_First_Interp (R, I, It); + while Present (It.Typ) loop + if Is_Valid_Pair (T, It.Typ) then + -- If several interpretations are possible, disambiguate + + if Present (R_Typ) + and then Base_Type (It.Typ) /= Base_Type (R_Typ) + then + It := Disambiguate (R, Valid_I, I, Any_Type); + + if It = No_Interp then + Ambiguous_Operands (N); + Set_Etype (R, Any_Type); + return True; + end if; + + else + Valid_I := I; + end if; + + R_Typ := It.Typ; + Found := True; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + return Found; + end Try_Left_Interp; + + ------------------- + -- Is_Valid_Pair -- + ------------------- + + function Is_Valid_Pair (T1, T2 : Entity_Id) return Boolean is + begin + return Covers (T1 => T1, T2 => T2) + or else Covers (T1 => T2, T2 => T1) + or else Is_User_Defined_Literal (L, T2) + or else Is_User_Defined_Literal (R, T1); + end Is_Valid_Pair; + + -- Local variables + + Dummy : Boolean; + Op : Node_Id; -- Start of processing for Analyze_Membership_Op @@ -3133,31 +3147,29 @@ package body Sem_Ch4 is if No (R) then pragma Assert (Ada_Version >= Ada_2012); - Analyze_Set_Membership; - Check_Function_Writable_Actuals (N); - return; - end if; - if Nkind (R) = N_Range + Analyze_Set_Membership; + + elsif Nkind (R) = N_Range or else (Nkind (R) = N_Attribute_Reference and then Attribute_Name (R) = Name_Range) then - Analyze (R); + Analyze_Expression (R); - Find_Interpretation; + Dummy := Find_Interp; -- 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, -- if the types are compatible. else - Analyze (R); + Analyze_Expression (R); 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 Find_Interpretation then + elsif Ada_Version >= Ada_2012 and then Find_Interp then if Nkind (N) = N_In then Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); else @@ -3616,8 +3628,8 @@ package body Sem_Ch4 is return; end if; - -- This can occur when the prefix of the call is an operator - -- name or an expanded name whose selector is an operator name. + -- This occurs when the prefix of the call is an operator name + -- or an expanded name whose selector is an operator name. Analyze_Operator_Call (N, Nam); @@ -3933,17 +3945,14 @@ package body Sem_Ch4 is => Find_Boolean_Types (Act1, Act2, Op_Id, N); - when Name_Op_Ge + when Name_Op_Eq + | Name_Op_Ge | Name_Op_Gt | Name_Op_Le | Name_Op_Lt - => - Find_Comparison_Types (Act1, Act2, Op_Id, N); - - when Name_Op_Eq | Name_Op_Ne => - Find_Equality_Types (Act1, Act2, Op_Id, N); + Find_Comparison_Equality_Types (Act1, Act2, Op_Id, N); when Name_Op_Concat => Find_Concatenation_Types (Act1, Act2, Op_Id, N); @@ -5927,7 +5936,7 @@ package body Sem_Ch4 is then Add_One_Interp (N, Op_Id, Etype (Op_Id)); - -- If the left operand is overloaded, indicate that the current + -- If the operands are overloaded, indicate that the current -- type is a viable candidate. This is redundant in most cases, -- but for equality and comparison operators where the context -- does not impose a type on the operands, setting the proper @@ -5939,6 +5948,10 @@ package body Sem_Ch4 is Set_Etype (Left_Opnd (N), Etype (F1)); end if; + if Is_Overloaded (Right_Opnd (N)) then + Set_Etype (Right_Opnd (N), Etype (F2)); + end if; + if Debug_Flag_E then Write_Str ("user defined operator "); Write_Name (Chars (Op_Id)); @@ -6005,9 +6018,6 @@ package body Sem_Ch4 is -- Standard, the predefined universal fixed operator is available, -- as specified by AI-420 (RM 4.5.5 (19.1/2)). - function Specific_Type (T1, T2 : Entity_Id) return Entity_Id; - -- Get specific type (i.e. non-universal type if there is one) - ------------------ -- Has_Fixed_Op -- ------------------ @@ -6064,19 +6074,6 @@ package body Sem_Ch4 is return False; end Has_Fixed_Op; - ------------------- - -- Specific_Type -- - ------------------- - - function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is - begin - if Is_Universal_Numeric_Type (T1) then - return Base_Type (T2); - else - return Base_Type (T1); - end if; - end Specific_Type; - -- Start of processing for Check_Arithmetic_Pair begin @@ -6246,18 +6243,6 @@ package body Sem_Ch4 is end if; end Check_Misspelled_Selector; - ---------------------- - -- Defined_In_Scope -- - ---------------------- - - function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean - is - S1 : constant Entity_Id := Scope (Base_Type (T)); - begin - return S1 = S - or else (S1 = System_Aux_Id and then S = Scope (S1)); - end Defined_In_Scope; - ------------------- -- Diagnose_Call -- ------------------- @@ -6268,32 +6253,35 @@ package body Sem_Ch4 is It : Interp; Err_Mode : Boolean; New_Nam : Node_Id; + Num_Actuals : Natural; + Num_Interps : Natural; Void_Interp_Seen : Boolean := False; Success : Boolean; pragma Warnings (Off, Boolean); begin - if Ada_Version >= Ada_2005 then - Actual := First_Actual (N); - while Present (Actual) loop + Num_Actuals := 0; + Actual := First_Actual (N); - -- Ada 2005 (AI-50217): Post an error in case of premature - -- usage of an entity from the limited view. + while Present (Actual) loop + -- Ada 2005 (AI-50217): Post an error in case of premature + -- usage of an entity from the limited view. - if not Analyzed (Etype (Actual)) - and then From_Limited_With (Etype (Actual)) - then - Error_Msg_Qual_Level := 1; - Error_Msg_NE - ("missing with_clause for scope of imported type&", - Actual, Etype (Actual)); - Error_Msg_Qual_Level := 0; - end if; + if not Analyzed (Etype (Actual)) + and then From_Limited_With (Etype (Actual)) + and then Ada_Version >= Ada_2005 + then + Error_Msg_Qual_Level := 1; + Error_Msg_NE + ("missing with_clause for scope of imported type&", + Actual, Etype (Actual)); + Error_Msg_Qual_Level := 0; + end if; - Next_Actual (Actual); - end loop; - end if; + Num_Actuals := Num_Actuals + 1; + Next_Actual (Actual); + end loop; -- Before listing the possible candidates, check whether this is -- a prefix of a selected component that has been rewritten as a @@ -6328,17 +6316,9 @@ package body Sem_Ch4 is end; end if; - -- Analyze each candidate call again, with full error reporting for - -- each. - - Error_Msg_N - ("no candidate interpretations match the actuals:!", Nam); - Err_Mode := All_Errors_Mode; - All_Errors_Mode := True; - - -- If this is a call to an operation of a concurrent type, - -- the failed interpretations have been removed from the - -- name. Recover them to provide full diagnostics. + -- If this is a call to an operation of a concurrent type, the failed + -- interpretations have been removed from the name. Recover them now + -- in order to provide full diagnostics. if Nkind (Parent (Nam)) = N_Selected_Component then Set_Entity (Nam, Empty); @@ -6352,6 +6332,48 @@ package body Sem_Ch4 is Get_First_Interp (Nam, X, It); end if; + -- If the number of actuals is 2, then remove interpretations involving + -- a unary "+" operator as they might yield confusing errors downstream. + + if Num_Actuals = 2 + and then Nkind (Parent (Nam)) /= N_Selected_Component + then + Num_Interps := 0; + + while Present (It.Nam) loop + if Ekind (It.Nam) = E_Operator + and then Chars (It.Nam) = Name_Op_Add + and then (No (First_Formal (It.Nam)) + or else No (Next_Formal (First_Formal (It.Nam)))) + then + Remove_Interp (X); + else + Num_Interps := Num_Interps + 1; + end if; + + Get_Next_Interp (X, It); + end loop; + + if Num_Interps = 0 then + Error_Msg_N ("!too many arguments in call to&", Nam); + return; + end if; + + Get_First_Interp (Nam, X, It); + + else + Num_Interps := 2; -- at least + end if; + + -- Analyze each candidate call again with full error reporting for each + + if Num_Interps > 1 then + Error_Msg_N ("!no candidate interpretations match the actuals:", Nam); + end if; + + Err_Mode := All_Errors_Mode; + All_Errors_Mode := True; + while Present (It.Nam) loop if Etype (It.Nam) = Standard_Void_Type then Void_Interp_Seen := True; @@ -6443,7 +6465,8 @@ package body Sem_Ch4 is procedure Check_Right_Argument (T : Entity_Id) is begin if not Is_Overloaded (R) then - Check_Arithmetic_Pair (T, Etype (R), Op_Id, N); + Check_Arithmetic_Pair (T, Etype (R), Op_Id, N); + else Get_First_Interp (R, Index2, It2); while Present (It2.Typ) loop @@ -6466,7 +6489,6 @@ package body Sem_Ch4 is Get_Next_Interp (Index1, It1); end loop; end if; - end Find_Arithmetic_Types; ------------------------ @@ -6562,160 +6584,293 @@ package body Sem_Ch4 is end if; end Find_Boolean_Types; - --------------------------- - -- Find_Comparison_Types -- - --------------------------- + ------------------------------------ + -- Find_Comparison_Equality_Types -- + ------------------------------------ - procedure Find_Comparison_Types + -- The context of the operator plays no role in resolving the operands, + -- so that if there is more than one interpretation of the operands that + -- is compatible with the comparison or equality, then the operation is + -- ambiguous, but this cannot be reported at this point because there is + -- no guarantee that the operation will be resolved to this operator yet. + + procedure Find_Comparison_Equality_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is - Index : Interp_Index; - It : Interp; - Found : Boolean := False; - I_F : Interp_Index; - T_F : Entity_Id; - Scop : Entity_Id := Empty; + Op_Name : constant Name_Id := Chars (Op_Id); + Op_Typ : Entity_Id renames Standard_Boolean; - procedure Try_One_Interp (T1 : Entity_Id); - -- Routine to try one proposed interpretation. Note that the context - -- of the operator plays no role in resolving the arguments, so that - -- if there is more than one interpretation of the operands that is - -- compatible with comparison, the operation is ambiguous. + function Try_Left_Interp (T : Entity_Id) return Entity_Id; + -- Try an interpretation of the left operand with type T. Return the + -- type of the interpretation of the right operand making up a valid + -- operand pair, or else Any_Type if the right operand is ambiguous, + -- otherwise Empty if no such pair exists. - -------------------- - -- Try_One_Interp -- - -------------------- + function Is_Valid_Comparison_Type (T : Entity_Id) return Boolean; + -- Return true if T is a valid comparison type + + function Is_Valid_Equality_Type + (T : Entity_Id; + Anon_Access : Boolean) return Boolean; + -- Return true if T is a valid equality type + + function Is_Valid_Pair (T1, T2 : Entity_Id) return Boolean; + -- Return true if T1 and T2 constitute a valid pair of operand types for + -- L and R respectively. + + --------------------- + -- Try_Left_Interp -- + --------------------- + + function Try_Left_Interp (T : Entity_Id) return Entity_Id is + I : Interp_Index; + It : Interp; + R_Typ : Entity_Id; + Valid_I : Interp_Index; - procedure Try_One_Interp (T1 : Entity_Id) is begin - -- If the operator is an expanded name, then the type of the operand - -- must be defined in the corresponding scope. If the type is - -- universal, the context will impose the correct type. Note that we - -- also avoid returning if we are currently within a generic instance - -- due to the fact that the generic package declaration has already - -- been successfully analyzed and Defined_In_Scope expects the base - -- type to be defined within the instance which will never be the - -- case. + -- Defend against previous error - if Present (Scop) - and then not Defined_In_Scope (T1, Scop) - and then not In_Instance - and then T1 /= Universal_Integer - and then T1 /= Universal_Real - and then T1 /= Any_String - and then T1 /= Any_Composite - then - return; - end if; + if Nkind (R) = N_Error then + null; - if Valid_Comparison_Arg (T1) - and then Has_Compatible_Type (R, T1, For_Comparison => True) - then - if Found and then Base_Type (T1) /= Base_Type (T_F) then - It := Disambiguate (L, I_F, Index, Any_Type); + -- Loop through the interpretations of the right operand - if It = No_Interp then - Ambiguous_Operands (N); - Set_Etype (L, Any_Type); - return; - - else - T_F := It.Typ; - end if; - else - Found := True; - T_F := T1; - I_F := Index; + elsif not Is_Overloaded (R) then + if Is_Valid_Pair (T, Etype (R)) then + return Etype (R); end if; - Set_Etype (L, T_F); - Find_Non_Universal_Interpretations (N, R, Op_Id, T1); - end if; - end Try_One_Interp; - - -- Start of processing for Find_Comparison_Types - - begin - -- 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 - Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N); - return; - end if; - - if Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Expanded_Name - then - Scop := Entity (Prefix (Name (N))); - - -- The prefix may be a package renaming, and the subsequent test - -- requires the original package. - - if Ekind (Scop) = E_Package - and then Present (Renamed_Entity (Scop)) - then - Scop := Renamed_Entity (Scop); - Set_Entity (Prefix (Name (N)), Scop); - end if; - end if; - - 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_Comparison_Types; - - ---------------------------------------- - -- Find_Non_Universal_Interpretations -- - ---------------------------------------- - - procedure Find_Non_Universal_Interpretations - (N : Node_Id; - R : Node_Id; - Op_Id : Entity_Id; - T1 : Entity_Id) - is - Index : Interp_Index; - It : Interp; - - begin - -- Defend against previous error - - if Nkind (R) = N_Error then - return; - end if; - - if T1 = Universal_Integer - or else T1 = Universal_Real - or else T1 = Universal_Access - then - if not Is_Overloaded (R) then - Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (Etype (R))); else - Get_First_Interp (R, Index, It); + R_Typ := Empty; + Valid_I := 0; + + Get_First_Interp (R, I, It); while Present (It.Typ) loop - if Covers (It.Typ, T1) then - Add_One_Interp - (N, Op_Id, Standard_Boolean, Base_Type (It.Typ)); + if Is_Valid_Pair (T, It.Typ) then + -- If several interpretations are possible, disambiguate + + if Present (R_Typ) + and then Base_Type (It.Typ) /= Base_Type (R_Typ) + then + It := Disambiguate (R, Valid_I, I, Any_Type); + + if It = No_Interp then + R_Typ := Any_Type; + exit; + end if; + + else + Valid_I := I; + end if; + + R_Typ := It.Typ; end if; - Get_Next_Interp (Index, It); + Get_Next_Interp (I, It); end loop; + + if Present (R_Typ) then + return R_Typ; + end if; 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)); + return Empty; + end Try_Left_Interp; + + ------------------------------ + -- Is_Valid_Comparison_Type -- + ------------------------------ + + function Is_Valid_Comparison_Type (T : Entity_Id) return Boolean is + begin + -- The operation must be performed in a context where the operators + -- of the base type are visible. + + if Is_Visible_Operator (N, Base_Type (T)) then + null; + + -- Save candidate type for subsequent error message, if any + + else + if Valid_Comparison_Arg (T) then + Candidate_Type := T; + end if; + + return False; + end if; + + -- Defer to the common implementation for the rest + + return Valid_Comparison_Arg (T); + end Is_Valid_Comparison_Type; + + ---------------------------- + -- Is_Valid_Equality_Type -- + ---------------------------- + + function Is_Valid_Equality_Type + (T : Entity_Id; + Anon_Access : Boolean) return Boolean + is + begin + -- The operation must be performed in a context where the operators + -- of the base type are visible. Deal with special types used with + -- access types before type resolution is done. + + if Ekind (T) = E_Access_Attribute_Type + or else (Ekind (T) in E_Access_Subprogram_Type + | E_Access_Protected_Subprogram_Type + and then + Ekind (Designated_Type (T)) /= E_Subprogram_Type) + or else Is_Visible_Operator (N, Base_Type (T)) + then + null; + + -- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow + -- anonymous access types in universal_access equality operators. + + elsif Anon_Access then + if Ada_Version < Ada_2005 then + return False; + end if; + + -- Save candidate type for subsequent error message, if any + + else + if Valid_Equality_Arg (T) then + Candidate_Type := T; + end if; + + return False; + end if; + + -- For the use of a "/=" operator on a tagged type, several possible + -- interpretations of equality need to be considered, we don't want + -- the default inequality declared in Standard to be chosen, and the + -- "/=" operator will be rewritten as a negation of "=" (see the end + -- of Analyze_Comparison_Equality_Op). This ensures the rewriting + -- occurs during analysis rather than being delayed until expansion. + -- Note that, if the node is N_Op_Ne but Op_Id is Name_Op_Eq, then we + -- still proceed with the interpretation, because this indicates + -- the aforementioned rewriting case where the interpretation to be + -- considered is actually that of the "=" operator. + + if Nkind (N) = N_Op_Ne + and then Op_Name /= Name_Op_Eq + and then Is_Tagged_Type (T) + then + return False; + + -- Defer to the common implementation for the rest + + else + return Valid_Equality_Arg (T); + end if; + end Is_Valid_Equality_Type; + + ------------------- + -- Is_Valid_Pair -- + ------------------- + + function Is_Valid_Pair (T1, T2 : Entity_Id) return Boolean is + begin + if Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then + declare + Anon_Access : constant Boolean := + Is_Anonymous_Access_Type (T1) + or else Is_Anonymous_Access_Type (T2); + -- RM 4.5.2(9.1/2): At least one of the operands of an equality + -- operator for universal_access shall be of specific anonymous + -- access type. + + begin + if not Is_Valid_Equality_Type (T1, Anon_Access) + or else not Is_Valid_Equality_Type (T2, Anon_Access) + then + return False; + end if; + end; + + else + if not Is_Valid_Comparison_Type (T1) + or else not Is_Valid_Comparison_Type (T2) + then + return False; + end if; + end if; + + return Covers (T1 => T1, T2 => T2) + or else Covers (T1 => T2, T2 => T1) + or else Is_User_Defined_Literal (L, T2) + or else Is_User_Defined_Literal (R, T1); + end Is_Valid_Pair; + + -- Local variables + + I : Interp_Index; + It : Interp; + L_Typ : Entity_Id; + R_Typ : Entity_Id; + T : Entity_Id; + Valid_I : Interp_Index; + + -- Start of processing for Find_Comparison_Equality_Types + + begin + -- Loop through the interpretations of the left operand + + if not Is_Overloaded (L) then + T := Try_Left_Interp (Etype (L)); + + if Present (T) then + Set_Etype (R, T); + Add_One_Interp (N, Op_Id, Op_Typ, Find_Unique_Type (L, R)); + end if; + + else + L_Typ := Empty; + R_Typ := Empty; + Valid_I := 0; + + Get_First_Interp (L, I, It); + while Present (It.Typ) loop + T := Try_Left_Interp (It.Typ); + + if Present (T) then + -- If several interpretations are possible, disambiguate + + if Present (L_Typ) + and then Base_Type (It.Typ) /= Base_Type (L_Typ) + then + It := Disambiguate (L, Valid_I, I, Any_Type); + + if It = No_Interp then + L_Typ := Any_Type; + R_Typ := T; + exit; + end if; + + else + Valid_I := I; + end if; + + L_Typ := It.Typ; + R_Typ := T; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Present (L_Typ) then + Set_Etype (L, L_Typ); + Set_Etype (R, R_Typ); + Add_One_Interp (N, Op_Id, Op_Typ, Find_Unique_Type (L, R)); + end if; end if; - end Find_Non_Universal_Interpretations; + end Find_Comparison_Equality_Types; ------------------------------ -- Find_Concatenation_Types -- @@ -6758,457 +6913,6 @@ package body Sem_Ch4 is end if; end Find_Concatenation_Types; - ------------------------- - -- Find_Equality_Types -- - ------------------------- - - procedure Find_Equality_Types - (L, R : Node_Id; - Op_Id : Entity_Id; - N : Node_Id) - is - Index : Interp_Index := 0; - It : Interp; - Found : Boolean := False; - Is_Universal_Access : Boolean := False; - I_F : Interp_Index; - T_F : Entity_Id; - Scop : Entity_Id := Empty; - - procedure Check_Access_Attribute (N : Node_Id); - -- For any object, '[Unchecked_]Access of such object can never be - -- passed as a parameter of a call to the Universal_Access equality - -- operator. - -- This is because the expected type for Obj'Access in a call to - -- the Standard."=" operator whose formals are of type - -- Universal_Access is Universal_Access, and Universal_Access - -- doesn't have a designated type. For more detail see RM 6.4.1(3) - -- and 3.10.2. - -- This procedure assumes that the context is a universal_access. - - function Check_Access_Object_Types - (N : Node_Id; Typ : Entity_Id) return Boolean; - -- Check for RM 4.5.2 (9.6/2): When both are of access-to-object types, - -- the designated types shall be the same or one shall cover the other, - -- and if the designated types are elementary or array types, then the - -- designated subtypes shall statically match. - -- If N is not overloaded, then its unique type must be compatible as - -- per above. Otherwise iterate through the interpretations of N looking - -- for a compatible one. - - procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id); - -- Check for RM 4.5.2(9.7/2): When both are of access-to-subprogram - -- types, the designated profiles shall be subtype conformant. - - function References_Anonymous_Access_Type - (N : Node_Id; Typ : Entity_Id) return Boolean; - -- Return True either if N is not overloaded and its Etype is an - -- anonymous access type or if one of the interpretations of N refers - -- to an anonymous access type compatible with Typ. - - procedure Try_One_Interp (T1 : Entity_Id); - -- The context of the equality operator plays no role in resolving the - -- arguments, so that if there is more than one interpretation of the - -- operands that is compatible with equality, the construct is ambiguous - -- and an error can be emitted now, after trying to disambiguate, i.e. - -- applying preference rules. - - ---------------------------- - -- Check_Access_Attribute -- - ---------------------------- - - procedure Check_Access_Attribute (N : Node_Id) is - begin - if Nkind (N) = N_Attribute_Reference - and then Attribute_Name (N) in Name_Access | Name_Unchecked_Access - then - Error_Msg_N - ("access attribute cannot be used as actual for " - & "universal_access equality", N); - end if; - end Check_Access_Attribute; - - ------------------------------- - -- Check_Access_Object_Types -- - ------------------------------- - - function Check_Access_Object_Types - (N : Node_Id; Typ : Entity_Id) return Boolean - is - function Check_Designated_Types (DT1, DT2 : Entity_Id) return Boolean; - -- Check RM 4.5.2 (9.6/2) on the given designated types. - - ---------------------------- - -- Check_Designated_Types -- - ---------------------------- - - function Check_Designated_Types - (DT1, DT2 : Entity_Id) return Boolean is - begin - -- If the designated types are elementary or array types, then - -- the designated subtypes shall statically match. - - if Is_Elementary_Type (DT1) or else Is_Array_Type (DT1) then - if Base_Type (DT1) /= Base_Type (DT2) then - return False; - else - return Subtypes_Statically_Match (DT1, DT2); - end if; - - -- Otherwise, the designated types shall be the same or one - -- shall cover the other. - - else - return DT1 = DT2 - or else Covers (DT1, DT2) - or else Covers (DT2, DT1); - end if; - end Check_Designated_Types; - - -- Start of processing for Check_Access_Object_Types - - begin - -- Return immediately with no checks if Typ is not an - -- access-to-object type. - - if not Is_Access_Object_Type (Typ) then - return True; - - -- Any_Type is compatible with all types in this context, and is used - -- in particular for the designated type of a 'null' value. - - elsif Directly_Designated_Type (Typ) = Any_Type - or else Nkind (N) = N_Null - then - return True; - end if; - - if not Is_Overloaded (N) then - if Is_Access_Object_Type (Etype (N)) then - return Check_Designated_Types - (Designated_Type (Typ), Designated_Type (Etype (N))); - end if; - else - declare - Typ_Is_Anonymous : constant Boolean := - Is_Anonymous_Access_Type (Typ); - - I : Interp_Index; - It : Interp; - - begin - Get_First_Interp (N, I, It); - while Present (It.Typ) loop - - -- The check on designated types if only relevant when one - -- of the types is anonymous, ignore other (non relevant) - -- types. - - if (Typ_Is_Anonymous - or else Is_Anonymous_Access_Type (It.Typ)) - and then Is_Access_Object_Type (It.Typ) - then - if Check_Designated_Types - (Designated_Type (Typ), Designated_Type (It.Typ)) - then - return True; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - return False; - end Check_Access_Object_Types; - - ------------------------------- - -- Check_Compatible_Profiles -- - ------------------------------- - - procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id) is - I : Interp_Index; - It : Interp; - I1 : Interp_Index := 0; - Found : Boolean := False; - Tmp : Entity_Id := Empty; - - begin - if not Is_Overloaded (N) then - Check_Subtype_Conformant - (Designated_Type (Etype (N)), Designated_Type (Typ), N); - else - Get_First_Interp (N, I, It); - while Present (It.Typ) loop - if Is_Access_Subprogram_Type (It.Typ) then - if not Found then - Found := True; - Tmp := It.Typ; - I1 := I; - - else - It := Disambiguate (N, I1, I, Any_Type); - - if It /= No_Interp then - Tmp := It.Typ; - I1 := I; - else - Found := False; - exit; - end if; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - - if Found then - Check_Subtype_Conformant - (Designated_Type (Tmp), Designated_Type (Typ), N); - end if; - end if; - end Check_Compatible_Profiles; - - -------------------------------------- - -- References_Anonymous_Access_Type -- - -------------------------------------- - - function References_Anonymous_Access_Type - (N : Node_Id; Typ : Entity_Id) return Boolean - is - I : Interp_Index; - It : Interp; - begin - if not Is_Overloaded (N) then - return Is_Anonymous_Access_Type (Etype (N)); - else - Get_First_Interp (N, I, It); - while Present (It.Typ) loop - if Is_Anonymous_Access_Type (It.Typ) - and then (Covers (It.Typ, Typ) or else Covers (Typ, It.Typ)) - then - return True; - end if; - - Get_Next_Interp (I, It); - end loop; - - return False; - end if; - end References_Anonymous_Access_Type; - - -------------------- - -- Try_One_Interp -- - -------------------- - - procedure Try_One_Interp (T1 : Entity_Id) is - Anonymous_Access : Boolean; - Bas : Entity_Id; - - begin - -- Perform a sanity check in case of previous errors - - if No (T1) then - return; - end if; - - Bas := Base_Type (T1); - - -- If the operator is an expanded name, then the type of the operand - -- must be defined in the corresponding scope. If the type is - -- universal, the context will impose the correct type. An anonymous - -- type for a 'Access reference is also universal in this sense, as - -- the actual type is obtained from context. - - -- In Ada 2005, the equality operator for anonymous access types - -- is declared in Standard, and preference rules apply to it. - - Anonymous_Access := Is_Anonymous_Access_Type (T1) - or else References_Anonymous_Access_Type (R, T1); - - if Present (Scop) then - - -- Note that we avoid returning if we are currently within a - -- generic instance due to the fact that the generic package - -- declaration has already been successfully analyzed and - -- Defined_In_Scope expects the base type to be defined within - -- the instance which will never be the case. - - if Defined_In_Scope (T1, Scop) - or else In_Instance - or else T1 = Universal_Integer - or else T1 = Universal_Real - or else T1 = Universal_Access - or else T1 = Any_String - or else T1 = Any_Composite - or else (Ekind (T1) = E_Access_Subprogram_Type - and then not Comes_From_Source (T1)) - then - null; - - elsif Scop /= Standard_Standard or else not Anonymous_Access then - - -- The scope does not contain an operator for the type - - return; - end if; - - -- If we have infix notation, the operator must be usable. Within - -- an instance, the type may have been immediately visible if the - -- types are compatible. - - elsif In_Open_Scopes (Scope (Bas)) - or else Is_Potentially_Use_Visible (Bas) - or else In_Use (Bas) - or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas)) - or else - ((In_Instance or else In_Inlined_Body) - and then Has_Compatible_Type (R, T1)) - then - null; - - elsif not Anonymous_Access then - -- Save candidate type for subsequent error message, if any - - if not Is_Limited_Type (T1) then - Candidate_Type := T1; - end if; - - return; - end if; - - -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: - -- Do not allow anonymous access types in equality operators. - - if Ada_Version < Ada_2005 and then Anonymous_Access then - return; - end if; - - -- If the right operand has a type compatible with T1, check for an - -- acceptable interpretation, unless T1 is limited (no predefined - -- equality available), or this is use of a "/=" for a tagged type. - -- In the latter case, possible interpretations of equality need - -- to be considered, we don't want the default inequality declared - -- in Standard to be chosen, and the "/=" will be rewritten as a - -- negation of "=" (see the end of Analyze_Equality_Op). This ensures - -- that rewriting happens during analysis rather than being - -- delayed until expansion (is this still needed now that ASIS mode - -- is gone???). Note that if the node is N_Op_Ne, but Op_Id - -- is Name_Op_Eq then we still proceed with the interpretation, - -- because that indicates the potential rewriting case where the - -- interpretation to consider is actually "=" and the node may be - -- about to be rewritten by Analyze_Equality_Op. - -- Finally, also check for RM 4.5.2 (9.6/2). - - if T1 /= Standard_Void_Type - and then (Anonymous_Access - or else - Has_Compatible_Type (R, T1, For_Comparison => True)) - - and then - ((not Is_Limited_Type (T1) - and then not Is_Limited_Composite (T1)) - - or else - (Is_Array_Type (T1) - and then not Is_Limited_Type (Component_Type (T1)) - and then Available_Full_View_Of_Component (T1))) - - and then - (Nkind (N) /= N_Op_Ne - or else not Is_Tagged_Type (T1) - or else Chars (Op_Id) = Name_Op_Eq) - - and then (not Anonymous_Access - or else Check_Access_Object_Types (R, T1)) - then - if Found - and then Base_Type (T1) /= Base_Type (T_F) - then - It := Disambiguate (L, I_F, Index, Any_Type); - - if It = No_Interp then - Ambiguous_Operands (N); - Set_Etype (L, Any_Type); - return; - - else - T_F := It.Typ; - Is_Universal_Access := Anonymous_Access; - end if; - - else - Found := True; - T_F := T1; - I_F := Index; - Is_Universal_Access := Anonymous_Access; - end if; - - if not Analyzed (L) then - Set_Etype (L, T_F); - end if; - - Find_Non_Universal_Interpretations (N, R, Op_Id, T1); - - -- Case of operator was not visible, Etype still set to Any_Type - - if Etype (N) = Any_Type then - Found := False; - end if; - end if; - end Try_One_Interp; - - -- Start of processing for Find_Equality_Types - - begin - -- 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 - Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N); - return; - end if; - - if Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Expanded_Name - then - Scop := Entity (Prefix (Name (N))); - - -- The prefix may be a package renaming, and the subsequent test - -- requires the original package. - - if Ekind (Scop) = E_Package - and then Present (Renamed_Entity (Scop)) - then - Scop := Renamed_Entity (Scop); - Set_Entity (Prefix (Name (N)), Scop); - end if; - end if; - - 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; - - if Is_Universal_Access then - if Is_Access_Subprogram_Type (Etype (L)) - and then Nkind (L) /= N_Null - and then Nkind (R) /= N_Null - then - Check_Compatible_Profiles (R, Etype (L)); - end if; - - Check_Access_Attribute (R); - Check_Access_Attribute (L); - end if; - end Find_Equality_Types; - ------------------------- -- Find_Negation_Types -- ------------------------- @@ -7605,7 +7309,7 @@ package body Sem_Ch4 is Standard_Address, Relocate_Node (R))); if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); else Analyze_Arithmetic_Op (N); end if; @@ -7627,7 +7331,7 @@ package body Sem_Ch4 is Standard_Address, Relocate_Node (R))); if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); else Analyze_Arithmetic_Op (N); end if; @@ -7657,7 +7361,7 @@ package body Sem_Ch4 is Standard_Address, Relocate_Node (R))); if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); else Analyze_Arithmetic_Op (N); end if; @@ -7681,7 +7385,7 @@ package body Sem_Ch4 is Replace_Null_By_Null_Address (N); if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then - Analyze_Comparison_Op (N); + Analyze_Comparison_Equality_Op (N); else Analyze_Arithmetic_Op (N); end if; @@ -7758,7 +7462,7 @@ package body Sem_Ch4 is Rewrite (R, Unchecked_Convert_To ( Standard_Address, Relocate_Node (R))); - Analyze_Equality_Op (N); + Analyze_Comparison_Equality_Op (N); return; -- Under relaxed RM semantics silently replace occurrences of @@ -7766,7 +7470,7 @@ package body Sem_Ch4 is elsif Null_To_Null_Address_Convert_OK (N) then Replace_Null_By_Null_Address (N); - Analyze_Equality_Op (N); + Analyze_Comparison_Equality_Op (N); return; end if; end if; diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index 92531807841..870edea0b64 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -31,9 +31,8 @@ package Sem_Ch4 is procedure Analyze_Arithmetic_Op (N : Node_Id); procedure Analyze_Call (N : Node_Id); procedure Analyze_Case_Expression (N : Node_Id); - procedure Analyze_Comparison_Op (N : Node_Id); + procedure Analyze_Comparison_Equality_Op (N : Node_Id); procedure Analyze_Concatenation (N : Node_Id); - procedure Analyze_Equality_Op (N : Node_Id); procedure Analyze_Explicit_Dereference (N : Node_Id); procedure Analyze_Expression_With_Actions (N : Node_Id); procedure Analyze_If_Expression (N : Node_Id); @@ -54,6 +53,10 @@ package Sem_Ch4 is procedure Analyze_Unchecked_Expression (N : Node_Id); procedure Analyze_Unchecked_Type_Conversion (N : Node_Id); + procedure Ambiguous_Operands (N : Node_Id); + -- Give an error for comparison, equality and membership operators with + -- ambiguous operands, and list possible interpretations. + procedure Analyze_Indexed_Component_Form (N : Node_Id); -- Prior to semantic analysis, an indexed component node can denote any -- of the following syntactic constructs: diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index c40e1243a20..77f8817fe24 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -509,6 +509,7 @@ package body Sem_Ch8 is function Has_Implicit_Operator (N : Node_Id) return Boolean; -- N is an expanded name whose selector is an operator name (e.g. P."+"). + -- Determine if N denotes an operator implicitly declared in prefix P: P's -- declarative part contains an implicit declaration of an operator if it -- has a declaration of a type to which one of the predefined operators -- apply. The existence of this routine is an implementation artifact. A @@ -8650,7 +8651,10 @@ package body Sem_Ch8 is | Name_Op_Xor => while Id /= Priv_Id loop - if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then + if Is_Type (Id) + and then Valid_Boolean_Arg (Id) + and then Is_Base_Type (Id) + then Add_Implicit_Operator (Id); return True; end if; @@ -8665,7 +8669,7 @@ package body Sem_Ch8 is => while Id /= Priv_Id loop if Is_Type (Id) - and then not Is_Limited_Type (Id) + and then Valid_Equality_Arg (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); @@ -8683,9 +8687,8 @@ package body Sem_Ch8 is | Name_Op_Lt => while Id /= Priv_Id loop - if (Is_Scalar_Type (Id) - or else (Is_Array_Type (Id) - and then Is_Scalar_Type (Component_Type (Id)))) + if Is_Type (Id) + and then Valid_Comparison_Arg (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4f66b715778..b918615904e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -141,7 +141,7 @@ package body Sem_Res is function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean; -- N is either an indexed component or a selected component. This function - -- returns true if the prefix refers to an object that has an address + -- returns true if the prefix denotes an atomic object that has an address -- clause (the case in which we may want to issue a warning). function Is_Definite_Access_Type (E : Entity_Id) return Boolean; @@ -823,7 +823,10 @@ package body Sem_Res is procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is begin - if Is_Invisible_Operator (N, T) then + if Comes_From_Source (N) + and then not Is_Visible_Operator (Original_Node (N), T) + and then not Error_Posted (N) + then Error_Msg_NE -- CODEFIX ("operator for} is not directly visible!", N, First_Subtype (T)); Error_Msg_N -- CODEFIX @@ -1662,6 +1665,14 @@ package body Sem_Res is begin Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); + -- Preserve the Comes_From_Source flag on the result if the original + -- call came from source. Although it is not strictly the case that the + -- operator as such comes from the source, logically it corresponds + -- exactly to the function call in the source, so it should be marked + -- this way (e.g. to make sure that validity checks work fine). + + Preserve_Comes_From_Source (Op_Node, N); + -- Ensure that the corresponding operator has the same parent as the -- original call. This guarantees that parent traversals performed by -- the ABE mechanism succeed. @@ -1900,18 +1911,7 @@ package body Sem_Res is Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); - -- Do rewrite setting Comes_From_Source on the result if the original - -- call came from source. Although it is not strictly the case that the - -- operator as such comes from the source, logically it corresponds - -- exactly to the function call in the source, so it should be marked - -- this way (e.g. to make sure that validity checks work fine). - - declare - CS : constant Boolean := Comes_From_Source (N); - begin - Rewrite (N, Op_Node); - Set_Comes_From_Source (N, CS); - end; + Rewrite (N, Op_Node); -- If this is an arithmetic operator and the result type is private, -- the operands and the result must be wrapped in conversion to @@ -4148,15 +4148,38 @@ package body Sem_Res is if No (A) and then Needs_No_Actuals (Nam) then null; - -- If we have an error in any actual or formal, indicated by a type + -- If we have an error in any formal or actual, indicated by a type -- of Any_Type, then abandon resolution attempt, and set result type - -- to Any_Type. Skip this if the actual is a Raise_Expression, whose - -- type is imposed from context. + -- to Any_Type. - elsif (Present (A) and then Etype (A) = Any_Type) - or else Etype (F) = Any_Type - then - if Nkind (A) /= N_Raise_Expression then + elsif Etype (F) = Any_Type then + Set_Etype (N, Any_Type); + return; + + elsif Present (A) and then Etype (A) = Any_Type then + -- For the peculiar case of a user-defined comparison or equality + -- operator that does not return a boolean type, the operands may + -- have been ambiguous for the predefined operator and, therefore, + -- marked with Any_Type. Since the operation has been resolved to + -- the user-defined operator, that is irrelevant, so reset Etype. + + if Nkind (Original_Node (N)) in N_Op_Eq + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Ne + and then not Is_Boolean_Type (Etype (N)) + then + Set_Etype (A, Etype (F)); + + -- Also skip this if the actual is a Raise_Expression, whose type + -- is imposed from context. + + elsif Nkind (A) = N_Raise_Expression then + null; + + else Set_Etype (N, Any_Type); return; end if; @@ -6856,13 +6879,11 @@ package body Sem_Res is -- functional notation. Replace call node with operator node, so -- that actuals can be resolved appropriately. - if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then - Make_Call_Into_Operator (N, Typ, Entity (Name (N))); + if Ekind (Nam) = E_Operator or else Is_Predefined_Op (Nam) then + Make_Call_Into_Operator (N, Typ, Nam); return; - elsif Present (Alias (Nam)) - and then Is_Predefined_Op (Alias (Nam)) - then + elsif Present (Alias (Nam)) and then Is_Predefined_Op (Alias (Nam)) then Resolve_Actuals (N, Nam); Make_Call_Into_Operator (N, Typ, Alias (Nam)); return; @@ -7489,39 +7510,35 @@ package body Sem_Res is -- Resolve_Comparison_Op -- --------------------------- - -- Context requires a boolean type, and plays no role in resolution. - -- Processing identical to that for equality operators. The result type is - -- the base type, which matters when pathological subtypes of booleans with - -- limited ranges are used. + -- The operands must have compatible types and the boolean context does not + -- participate in the resolution. The first pass verifies that the operands + -- are not ambiguous and sets their type correctly, or to Any_Type in case + -- of ambiguity. If both operands are strings or aggregates, then they are + -- ambiguous even if they carry a single (universal) type. procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); - T : Entity_Id; + + T : Entity_Id := Find_Unique_Type (L, R); begin - -- If this is an intrinsic operation which is not predefined, use the - -- types of its declared arguments to resolve the possibly overloaded - -- operands. Otherwise the operands are unambiguous and specify the - -- expected type. - - if Scope (Entity (N)) /= Standard_Standard then - T := Etype (First_Entity (Entity (N))); - - else - T := Find_Unique_Type (L, R); - - if T = Any_Fixed then - T := Unique_Fixed_Point_Type (L); - end if; + if T = Any_Fixed then + T := Unique_Fixed_Point_Type (L); end if; Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); - -- Skip remaining processing if already set to Any_Type - if T = Any_Type then + -- Deal with explicit ambiguity of operands + + if Ekind (Entity (N)) = E_Operator + and then (Is_Overloaded (L) or else Is_Overloaded (R)) + then + Ambiguous_Operands (N); + end if; + return; end if; @@ -8510,25 +8527,38 @@ package body Sem_Res is -- overlapping actuals, just like for a subprogram call. Warn_On_Overlapping_Actuals (Nam, N); - end Resolve_Entry_Call; ------------------------- -- Resolve_Equality_Op -- ------------------------- - -- Both arguments must have the same type, and the boolean context does - -- not participate in the resolution. The first pass verifies that the - -- interpretation is not ambiguous, and the type of the left argument is - -- correctly set, or is Any_Type in case of ambiguity. If both arguments - -- are strings or aggregates, allocators, or Null, they are ambiguous even - -- though they carry a single (universal) type. Diagnose this case here. + -- The operands must have compatible types and the boolean context does not + -- participate in the resolution. The first pass verifies that the operands + -- are not ambiguous and sets their type correctly, or to Any_Type in case + -- of ambiguity. If both operands are strings, aggregates, allocators, or + -- null, they are ambiguous even if they carry a single (universal) type. procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + T : Entity_Id := Find_Unique_Type (L, R); + procedure Check_Access_Attribute (N : Node_Id); + -- For any object, '[Unchecked_]Access of such object can never be + -- passed as an operand to the Universal_Access equality operators. + -- This is so because the expected type for Obj'Access in a call to + -- these operators, whose formals are of type Universal_Access, is + -- Universal_Access, and Universal_Access does not have a designated + -- type. For more details, see RM 3.10.2(2/2) and 6.4.1(3). + + procedure Check_Designated_Object_Types (T1, T2 : Entity_Id); + -- Check RM 4.5.2(9.6/2) on the given designated object types + + procedure Check_Designated_Subprogram_Types (T1, T2 : Entity_Id); + -- Check RM 4.5.2(9.7/2) on the given designated subprogram types + procedure Check_If_Expression (Cond : Node_Id); -- The resolution rule for if expressions requires that each such must -- have a unique type. This means that if several dependent expressions @@ -8554,6 +8584,54 @@ package body Sem_Res is -- could be the cause of confused priorities. Note that if the not is -- in parens, then False is returned. + ---------------------------- + -- Check_Access_Attribute -- + ---------------------------- + + procedure Check_Access_Attribute (N : Node_Id) is + begin + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) in Name_Access | Name_Unchecked_Access + then + Error_Msg_N + ("access attribute cannot be used as actual for " + & "universal_access equality", N); + end if; + end Check_Access_Attribute; + + ----------------------------------- + -- Check_Designated_Object_Types -- + ----------------------------------- + + procedure Check_Designated_Object_Types (T1, T2 : Entity_Id) is + begin + if (Is_Elementary_Type (T1) or else Is_Array_Type (T1)) + and then (Base_Type (T1) /= Base_Type (T2) + or else not Subtypes_Statically_Match (T1, T2)) + then + Error_Msg_N + ("designated subtypes for universal_access equality " + & "do not statically match (RM 4.5.2(9.6/2)", N); + Error_Msg_NE ("\left operand has}!", N, Etype (L)); + Error_Msg_NE ("\right operand has}!", N, Etype (R)); + end if; + end Check_Designated_Object_Types; + + --------------------------------------- + -- Check_Designated_Subprogram_Types -- + --------------------------------------- + + procedure Check_Designated_Subprogram_Types (T1, T2 : Entity_Id) is + begin + if not Subtype_Conformant (T1, T2) then + Error_Msg_N + ("designated subtypes for universal_access equality " + & "not subtype conformant (RM 4.5.2(9.7/2)", N); + Error_Msg_NE ("\left operand has}!", N, Etype (L)); + Error_Msg_NE ("\right operand has}!", N, Etype (R)); + end if; + end Check_Designated_Subprogram_Types; + ------------------------- -- Check_If_Expression -- ------------------------- @@ -8727,14 +8805,25 @@ package body Sem_Res is -- Start of processing for Resolve_Equality_Op begin - Set_Etype (N, Base_Type (Typ)); - Generate_Reference (T, N, ' '); - if T = Any_Fixed then T := Unique_Fixed_Point_Type (L); end if; - if T /= Any_Type then + Set_Etype (N, Base_Type (Typ)); + Generate_Reference (T, N, ' '); + + if T = Any_Type then + -- Deal with explicit ambiguity of operands + + if Ekind (Entity (N)) = E_Operator + and then (Is_Overloaded (L) or else Is_Overloaded (R)) + then + Ambiguous_Operands (N); + end if; + + else + -- Deal with other error cases + if T = Any_String or else T = Any_Composite or else T = Any_Character @@ -8773,6 +8862,44 @@ package body Sem_Res is Check_If_Expression (R); end if; + -- RM 4.5.2(9.5/2): At least one of the operands of the equality + -- operators for universal_access shall be of type universal_access, + -- or both shall be of access-to-object types, or both shall be of + -- access-to-subprogram types (RM 4.5.2(9.5/2)). + + if Is_Anonymous_Access_Type (T) + and then Etype (L) /= Universal_Access + and then Etype (R) /= Universal_Access + then + -- RM 4.5.2(9.6/2): When both are of access-to-object types, the + -- designated types shall be the same or one shall cover the other + -- and if the designated types are elementary or array types, then + -- the designated subtypes shall statically match. + + if Is_Access_Object_Type (Etype (L)) + and then Is_Access_Object_Type (Etype (R)) + then + Check_Designated_Object_Types + (Designated_Type (Etype (L)), Designated_Type (Etype (R))); + + -- RM 4.5.2(9.7/2): When both are of access-to-subprogram types, + -- the designated profiles shall be subtype conformant. + + elsif Is_Access_Subprogram_Type (Etype (L)) + and then Is_Access_Subprogram_Type (Etype (R)) + then + Check_Designated_Subprogram_Types + (Designated_Type (Etype (L)), Designated_Type (Etype (R))); + end if; + end if; + + -- Check another case of equality operators for universal_access + + if Is_Anonymous_Access_Type (T) and then Comes_From_Source (N) then + Check_Access_Attribute (L); + Check_Access_Attribute (R); + end if; + Resolve (L, T); Resolve (R, T); @@ -8895,33 +9022,6 @@ package body Sem_Res is then Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); end if; - - -- Ada 2005: If one operand is an anonymous access type, convert the - -- other operand to it, to ensure that the underlying types match in - -- the back-end. Same for access_to_subprogram, and the conversion - -- verifies that the types are subtype conformant. - - -- We apply the same conversion in the case one of the operands is a - -- private subtype of the type of the other. - - -- Why the Expander_Active test here ??? - - if Expander_Active - and then - (Ekind (T) in E_Anonymous_Access_Type - | E_Anonymous_Access_Subprogram_Type - or else Is_Private_Type (T)) - then - if Etype (L) /= T then - Rewrite (L, Unchecked_Convert_To (T, L)); - Analyze_And_Resolve (L, T); - end if; - - if (Etype (R)) /= T then - Rewrite (R, Unchecked_Convert_To (Etype (L), R)); - Analyze_And_Resolve (R, T); - end if; - end if; end if; end Resolve_Equality_Op; @@ -12592,63 +12692,49 @@ package body Sem_Res is end; end if; - -- Rewrite the operator node using the real operator, not its renaming. - -- Exclude user-defined intrinsic operations of the same name, which are - -- treated separately and rewritten as calls. + Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); + Set_Chars (Op_Node, Nam); + Set_Etype (Op_Node, Etype (N)); + Set_Entity (Op_Node, Op); + Set_Right_Opnd (Op_Node, Right_Opnd (N)); - if Ekind (Op) /= E_Function or else Chars (N) /= Nam then - Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); - Set_Chars (Op_Node, Nam); - Set_Etype (Op_Node, Etype (N)); - Set_Entity (Op_Node, Op); - Set_Right_Opnd (Op_Node, Right_Opnd (N)); + if Is_Binary then + Set_Left_Opnd (Op_Node, Left_Opnd (N)); + end if; - -- Indicate that both the original entity and its renaming are - -- referenced at this point. + -- Indicate that both the original entity and its renaming are + -- referenced at this point. - Generate_Reference (Entity (N), N); - Generate_Reference (Op, N); + Generate_Reference (Entity (N), N); + Generate_Reference (Op, N); - if Is_Binary then - Set_Left_Opnd (Op_Node, Left_Opnd (N)); - end if; + Rewrite (N, Op_Node); - Rewrite (N, Op_Node); + -- If the context type is private, add the appropriate conversions so + -- that the operator is applied to the full view. This is done in the + -- routines that resolve intrinsic operators. - -- If the context type is private, add the appropriate conversions so - -- that the operator is applied to the full view. This is done in the - -- routines that resolve intrinsic operators. + if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then + case Nkind (N) is + when N_Op_Add + | N_Op_Divide + | N_Op_Expon + | N_Op_Mod + | N_Op_Multiply + | N_Op_Rem + | N_Op_Subtract + => + Resolve_Intrinsic_Operator (N, Typ); - if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then - case Nkind (N) is - when N_Op_Add - | N_Op_Divide - | N_Op_Expon - | N_Op_Mod - | N_Op_Multiply - | N_Op_Rem - | N_Op_Subtract - => - Resolve_Intrinsic_Operator (N, Typ); + when N_Op_Abs + | N_Op_Minus + | N_Op_Plus + => + Resolve_Intrinsic_Unary_Operator (N, Typ); - when N_Op_Abs - | N_Op_Minus - | N_Op_Plus - => - Resolve_Intrinsic_Unary_Operator (N, Typ); - - when others => - Resolve (N, Typ); - end case; - end if; - - elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then - - -- Operator renames a user-defined operator of the same name. Use the - -- original operator in the node, which is the one Gigi knows about. - - Set_Entity (N, Op); - Set_Is_Overloaded (N, False); + when others => + Resolve (N, Typ); + end case; end if; end Rewrite_Renamed_Operator; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 8a00e973e26..4cb0d8d9e9f 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -192,10 +192,6 @@ package body Sem_Type is -- multiple interpretations. Interpretations can be added to only one -- node at a time. - function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id; - -- If Typ_1 and Typ_2 are compatible, return the one that is not universal - -- or is not a "class" type (any_character, etc). - -------------------- -- Add_One_Interp -- -------------------- @@ -365,14 +361,12 @@ package body Sem_Type is -- Start of processing for Add_One_Interp begin - -- If the interpretation is a predefined operator, verify that the - -- result type is visible, or that the entity has already been - -- resolved (case of an instantiation node that refers to a predefined - -- operation, or an internally generated operator node, or an operator - -- given as an expanded name). If the operator is a comparison or - -- equality, it is the type of the operand that matters to determine - -- whether the operator is visible. In an instance, the check is not - -- performed, given that the operator was visible in the generic. + -- If the interpretation is a predefined operator, verify that it is + -- visible, or that the entity has already been resolved (case of an + -- instantiation node that refers to a predefined operation, or an + -- internally generated operator node, or an operator given as an + -- expanded name). If the operator is a comparison or equality, then + -- it is the type of the operand that is relevant here. if Ekind (E) = E_Operator then if Present (Opnd_Type) then @@ -381,29 +375,9 @@ package body Sem_Type is Vis_Type := Base_Type (T); end if; - if In_Open_Scopes (Scope (Vis_Type)) - or else Is_Potentially_Use_Visible (Vis_Type) - or else In_Use (Vis_Type) - or else (In_Use (Scope (Vis_Type)) - and then not Is_Hidden (Vis_Type)) - or else Nkind (N) = N_Expanded_Name + if Nkind (N) = N_Expanded_Name or else (Nkind (N) in N_Op and then E = Entity (N)) - or else (In_Instance or else In_Inlined_Body) - or else Is_Anonymous_Access_Type (Vis_Type) - then - null; - - -- If the node is given in functional notation and the prefix - -- is an expanded name, then the operator is visible if the - -- prefix is the scope of the result type as well. If the - -- operator is (implicitly) defined in an extension of system, - -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb). - - elsif Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Expanded_Name - and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T)) - or else Entity (Prefix (Name (N))) = Scope (Vis_Type) - or else Scope (Vis_Type) = System_Aux_Id) + or else Is_Visible_Operator (N, Vis_Type) then null; @@ -1334,7 +1308,7 @@ package body Sem_Type is -- It may given by an operator name, or by an expanded name whose prefix -- is Standard. - function Remove_Conversions return Interp; + function Remove_Conversions_And_Abstract_Operations return Interp; -- Last chance for pathological cases involving comparisons on literals, -- and user overloadings of the same operator. Such pathologies have -- been removed from the ACVC, but still appear in two DEC tests, with @@ -1522,11 +1496,11 @@ package body Sem_Type is return Etype (Opnd); end Operand_Type; - ------------------------ - -- Remove_Conversions -- - ------------------------ + ------------------------------------------------ + -- Remove_Conversions_And_Abstract_Operations -- + ------------------------------------------------ - function Remove_Conversions return Interp is + function Remove_Conversions_And_Abstract_Operations return Interp is I : Interp_Index; It : Interp; It1 : Interp; @@ -1535,13 +1509,16 @@ package body Sem_Type is Act2 : Node_Id; function Has_Abstract_Interpretation (N : Node_Id) return Boolean; - -- If an operation has universal operands the universal operation + -- If an operation has universal operands, the universal operation -- is present among its interpretations. If there is an abstract -- interpretation for the operator, with a numeric result, this -- interpretation was already removed in sem_ch4, but the universal -- one is still visible. We must rescan the list of operators and -- remove the universal interpretation to resolve the ambiguity. + function Is_Numeric_Only_Type (T : Entity_Id) return Boolean; + -- Return True if T is a numeric type and not Any_Type + --------------------------------- -- Has_Abstract_Interpretation -- --------------------------------- @@ -1562,7 +1539,7 @@ package body Sem_Type is while Present (E) loop if Is_Overloadable (E) and then Is_Abstract_Subprogram (E) - and then Is_Numeric_Type (Etype (E)) + and then Is_Numeric_Only_Type (Etype (E)) then return True; else @@ -1587,7 +1564,16 @@ package body Sem_Type is end if; end Has_Abstract_Interpretation; - -- Start of processing for Remove_Conversions + -------------------------- + -- Is_Numeric_Only_Type -- + -------------------------- + + function Is_Numeric_Only_Type (T : Entity_Id) return Boolean is + begin + return Is_Numeric_Type (T) and then T /= Any_Type; + end Is_Numeric_Only_Type; + + -- Start of processing for Remove_Conversions_And_Abstract_Operations begin It1 := No_Interp; @@ -1676,11 +1662,11 @@ package body Sem_Type is It1 := It; end if; - elsif Is_Numeric_Type (Etype (F1)) + elsif Is_Numeric_Only_Type (Etype (F1)) and then Has_Abstract_Interpretation (Act1) then -- Current interpretation is not the right one because it - -- expects a numeric operand. Examine all the other ones. + -- expects a numeric operand. Examine all the others. declare I : Interp_Index; @@ -1689,14 +1675,45 @@ package body Sem_Type is begin Get_First_Interp (N, I, It); while Present (It.Typ) loop - if - not Is_Numeric_Type (Etype (First_Formal (It.Nam))) + if not Is_Numeric_Only_Type + (Etype (First_Formal (It.Nam))) then if No (Act2) - or else not Has_Abstract_Interpretation (Act2) or else not - Is_Numeric_Type + Is_Numeric_Only_Type (Etype (Next_Formal (First_Formal (It.Nam)))) + or else not Has_Abstract_Interpretation (Act2) + then + return It; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + return No_Interp; + end; + + elsif Is_Numeric_Only_Type (Etype (F1)) + and then Present (Act2) + and then Has_Abstract_Interpretation (Act2) + then + -- Current interpretation is not the right one because it + -- expects a numeric operand. Examine all the others. + + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if not Is_Numeric_Only_Type + (Etype (Next_Formal (First_Formal (It.Nam)))) + then + if not Is_Numeric_Only_Type + (Etype (First_Formal (It.Nam))) + or else not Has_Abstract_Interpretation (Act1) then return It; end if; @@ -1714,37 +1731,8 @@ package body Sem_Type is Get_Next_Interp (I, It); end loop; - -- After some error, a formal may have Any_Type and yield a spurious - -- match. To avoid cascaded errors if possible, check for such a - -- formal in either candidate. - - if Serious_Errors_Detected > 0 then - declare - Formal : Entity_Id; - - begin - Formal := First_Formal (Nam1); - while Present (Formal) loop - if Etype (Formal) = Any_Type then - return Disambiguate.It2; - end if; - - Next_Formal (Formal); - end loop; - - Formal := First_Formal (Nam2); - while Present (Formal) loop - if Etype (Formal) = Any_Type then - return Disambiguate.It1; - end if; - - Next_Formal (Formal); - end loop; - end; - end if; - return It1; - end Remove_Conversions; + end Remove_Conversions_And_Abstract_Operations; ----------------------- -- Standard_Operator -- @@ -2145,10 +2133,10 @@ package body Sem_Type is end if; else - return Remove_Conversions; + return Remove_Conversions_And_Abstract_Operations; end if; else - return Remove_Conversions; + return Remove_Conversions_And_Abstract_Operations; end if; end if; @@ -2162,18 +2150,19 @@ package body Sem_Type is then return No_Interp; - -- If the user-defined operator is in an open scope, or in the scope - -- of the resulting type, or given by an expanded name that names its - -- scope, it hides the predefined operator for the type. Exponentiation - -- has to be special-cased because the implicit operator does not have - -- a symmetric signature, and may not be hidden by the explicit one. + -- If the user-defined operator matches the signature of the operator, + -- and is declared in an open scope, or in the scope of the resulting + -- type, or given by an expanded name that names its scope, it hides + -- the predefined operator for the type. But exponentiation has to be + -- special-cased because the latter operator does not have a symmetric + -- signature, and may not be hidden by the explicit one. - elsif (Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Expanded_Name - and then (Chars (Predef_Subp) /= Name_Op_Expon - or else Hides_Op (User_Subp, Predef_Subp)) - and then Scope (User_Subp) = Entity (Prefix (Name (N)))) - or else Hides_Op (User_Subp, Predef_Subp) + elsif Hides_Op (User_Subp, Predef_Subp) + or else (Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + and then (Chars (Predef_Subp) /= Name_Op_Expon + or else Hides_Op (User_Subp, Predef_Subp)) + and then Scope (User_Subp) = Entity (Prefix (Name (N)))) then if It1.Nam = User_Subp then return It1; @@ -2246,7 +2235,7 @@ package body Sem_Type is end if; else - return No_Interp; + return Remove_Conversions_And_Abstract_Operations; end if; elsif It1.Nam = Predef_Subp then @@ -2264,8 +2253,8 @@ package body Sem_Type is function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is begin - -- Simple case: same entity kinds, type conformance is required. A - -- parameterless function can also rename a literal. + -- For the simple case of same kinds, type conformance is required, but + -- a parameterless function can also rename a literal. if Ekind (Old_S) = Ekind (New_S) or else (Ekind (New_S) = E_Function @@ -2273,12 +2262,16 @@ package body Sem_Type is then return Type_Conformant (New_S, Old_S); - elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then - return Operator_Matches_Spec (Old_S, New_S); + -- Likewise for a procedure and an entry elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then return Type_Conformant (New_S, Old_S); + -- For a user-defined operator, use the dedicated predicate + + elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then + return Operator_Matches_Spec (Old_S, New_S); + else return False; end if; @@ -2289,60 +2282,18 @@ package body Sem_Type is ---------------------- function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is - T : constant Entity_Id := Etype (L); - I : Interp_Index; - It : Interp; - TR : Entity_Id := Any_Type; + T : constant Entity_Id := Specific_Type (Etype (L), Etype (R)); begin - if Is_Overloaded (R) then - Get_First_Interp (R, I, It); - while Present (It.Typ) loop - if Covers (T, It.Typ) or else Covers (It.Typ, T) then - - -- If several interpretations are possible and L is universal, - -- apply preference rule. - - if TR /= Any_Type then - if Is_Universal_Numeric_Type (T) - and then It.Typ = T - then - TR := It.Typ; - end if; - - else - TR := It.Typ; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - - Set_Etype (R, TR); - - -- In the non-overloaded case, the Etype of R is already set correctly - - else - null; + if T = Any_Type then + if Is_User_Defined_Literal (L, Etype (R)) then + return Etype (R); + elsif Is_User_Defined_Literal (R, Etype (L)) then + return Etype (L); + end if; end if; - -- If one of the operands is Universal_Fixed, the type of the other - -- operand provides the context. - - if Etype (R) = Universal_Fixed then - return T; - - elsif T = Universal_Fixed then - return Etype (R); - - -- If one operand is a raise_expression, use type of other operand - - elsif Nkind (L) = N_Raise_Expression then - return Etype (R); - - else - return Specific_Type (T, Etype (R)); - end if; + return T; end Find_Unique_Type; ------------------------------------- @@ -2446,10 +2397,7 @@ package body Sem_Type is -- Has_Compatible_Type -- ------------------------- - function Has_Compatible_Type - (N : Node_Id; - Typ : Entity_Id; - For_Comparison : Boolean := False) return Boolean + function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean is I : Interp_Index; It : Interp; @@ -2463,8 +2411,8 @@ package body Sem_Type is 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 - -- to check whether it is a proper descendant. + -- If the type is already frozen, use the corresponding_record to + -- check whether it is a proper descendant. or else (Is_Record_Type (Typ) @@ -2478,23 +2426,8 @@ package body Sem_Type is and then Present (Corresponding_Record_Type (Typ)) and then Covers (Corresponding_Record_Type (Typ), Etype (N))) - or else - (Nkind (N) = N_Integer_Literal - and then Present (Find_Aspect (Typ, Aspect_Integer_Literal))) + or else Is_User_Defined_Literal (N, Typ) - or else - (Nkind (N) = N_Real_Literal - and then Present (Find_Aspect (Typ, Aspect_Real_Literal))) - - or else - (Nkind (N) = N_String_Literal - and then Present (Find_Aspect (Typ, Aspect_String_Literal))) - - or else - (For_Comparison - and then not Is_Tagged_Type (Typ) - and then Ekind (Typ) /= E_Anonymous_Access_Type - and then Covers (Etype (N), Typ)) then return True; end if; @@ -2504,26 +2437,24 @@ package body Sem_Type is else Get_First_Interp (N, I, It); while Present (It.Typ) loop - if (Covers (Typ, It.Typ) - and then - (Scope (It.Nam) /= Standard_Standard - or else not Is_Invisible_Operator (N, Base_Type (Typ)))) + if Covers (Typ, It.Typ) -- Ada 2005 (AI-345) or else (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)))) + and then Present (Corresponding_Record_Type (Etype (It.Typ))) + and then + Covers (Typ, Corresponding_Record_Type (Etype (It.Typ)))) + + or else + (Is_Concurrent_Type (Typ) + and then Is_Record_Type (It.Typ) + and then Present (Corresponding_Record_Type (Typ)) + and then + Covers (Corresponding_Record_Type (Typ), Etype (It.Typ))) - or else - (For_Comparison - and then not Is_Tagged_Type (Typ) - and then Ekind (Typ) /= E_Anonymous_Access_Type - and then Covers (It.Typ, Typ)) then return True; end if; @@ -3010,45 +2941,6 @@ package body Sem_Type is end if; end Is_Ancestor; - --------------------------- - -- Is_Invisible_Operator -- - --------------------------- - - function Is_Invisible_Operator - (N : Node_Id; - T : Entity_Id) return Boolean - is - Orig_Node : constant Node_Id := Original_Node (N); - - begin - if Nkind (N) not in N_Op then - return False; - - elsif not Comes_From_Source (N) then - return False; - - elsif No (Universal_Interpretation (Right_Opnd (N))) then - return False; - - elsif Nkind (N) in N_Binary_Op - and then No (Universal_Interpretation (Left_Opnd (N))) - then - return False; - - else - return Is_Numeric_Type (T) - and then not In_Open_Scopes (Scope (T)) - and then not Is_Potentially_Use_Visible (T) - and then not In_Use (T) - and then not In_Use (Scope (T)) - and then - (Nkind (Orig_Node) /= N_Function_Call - or else Nkind (Name (Orig_Node)) /= N_Expanded_Name - or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) - and then not In_Instance; - end if; - end Is_Invisible_Operator; - -------------------- -- Is_Progenitor -- -------------------- @@ -3081,6 +2973,65 @@ package body Sem_Type is return False; end Is_Subtype_Of; + ------------------------- + -- Is_Visible_Operator -- + ------------------------- + + function Is_Visible_Operator (N : Node_Id; Typ : Entity_Id) return Boolean + is + begin + -- The predefined operators of the universal types are always visible + + if Typ in Universal_Integer | Universal_Real | Universal_Access then + return True; + + -- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow + -- anonymous access types in universal_access equality operators. + + elsif Is_Anonymous_Access_Type (Typ) then + return Ada_Version >= Ada_2005; + + -- Similar reasoning for special types used for composite types before + -- type resolution is done. + + elsif Typ = Any_Composite or else Typ = Any_String then + return True; + + -- Within an instance, the predefined operators of the formal types are + -- visible and, for the other types, the generic package declaration has + -- already been successfully analyzed. Likewise for an inlined body. + + elsif In_Instance or else In_Inlined_Body then + return True; + + -- If the operation is given in functional notation and the prefix is an + -- expanded name, then the operator is visible if the prefix is the scope + -- of the type, or System if the type is declared in an extension of it. + + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Expanded_Name + then + declare + Pref : constant Entity_Id := Entity (Prefix (Name (N))); + Scop : constant Entity_Id := Scope (Typ); + + begin + return Pref = Scop + or else (Present (System_Aux_Id) + and then Scop = System_Aux_Id + and then Pref = Scope (Scop)); + end; + + -- Otherwise the operator is visible when the type is visible + + else + return Is_Potentially_Use_Visible (Typ) + or else In_Use (Typ) + or else (In_Use (Scope (Typ)) and then not Is_Hidden (Typ)) + or else In_Open_Scopes (Scope (Typ)); + end if; + end Is_Visible_Operator; + ------------------ -- List_Interps -- ------------------ @@ -3184,7 +3135,7 @@ package body Sem_Type is elsif Op_Name in Name_Op_Eq | Name_Op_Ne then return Base_Type (T1) = Base_Type (T2) - and then not Is_Limited_Type (T1) + and then Valid_Equality_Arg (T1) and then Is_Boolean_Type (T); elsif Op_Name in Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge @@ -3366,60 +3317,41 @@ package body Sem_Type is or else (T1 = Universal_Real and then Is_Real_Type (T2)) or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2)) or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2)) + or else (T1 = Any_Modular and then Is_Modular_Integer_Type (T2)) + or else (T1 = Any_Character and then Is_Character_Type (T2)) + or else (T1 = Any_String and then Is_String_Type (T2)) + or else (T1 = Any_Composite and then Is_Aggregate_Type (T2)) then return B2; + elsif (T1 = Universal_Access + or else Ekind (T1) in E_Allocator_Type | E_Access_Attribute_Type) + and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)) + then + return B2; + + elsif T1 = Raise_Type then + return B2; + elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) or else (T2 = Universal_Real and then Is_Real_Type (T1)) or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) + or else (T2 = Any_Modular and then Is_Modular_Integer_Type (T1)) + or else (T2 = Any_Character and then Is_Character_Type (T1)) + or else (T2 = Any_String and then Is_String_Type (T1)) + or else (T2 = Any_Composite and then Is_Aggregate_Type (T1)) then return B1; - elsif T2 = Any_String and then Is_String_Type (T1) then - return B1; - - elsif T1 = Any_String and then Is_String_Type (T2) then - return B2; - - elsif T2 = Any_Character and then Is_Character_Type (T1) then - return B1; - - elsif T1 = Any_Character and then Is_Character_Type (T2) then - return B2; - - elsif T1 = Universal_Access - and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)) - then - return T2; - - elsif T2 = Universal_Access + elsif (T2 = Universal_Access + or else Ekind (T2) in E_Allocator_Type | E_Access_Attribute_Type) and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)) then - return T1; + return B1; - -- In an instance, the specific type may have a private view. Use full - -- view to check legality. - - elsif T2 = Universal_Access - and then Is_Private_Type (T1) - and then Present (Full_View (T1)) - and then Is_Access_Type (Full_View (T1)) - and then In_Instance - then - return T1; - - elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then - return T1; - - elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then - return T2; - - elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then - return T2; - - elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then - return T1; + elsif T2 = Raise_Type then + return B1; -- ---------------------------------------------------------- -- Special cases for equality operators (all other predefined @@ -3488,16 +3420,6 @@ package body Sem_Type is then return T1; - elsif Ekind (T1) in E_Allocator_Type | E_Access_Attribute_Type - and then Is_Access_Type (T2) - then - return T2; - - elsif Ekind (T2) in E_Allocator_Type | E_Access_Attribute_Type - and then Is_Access_Type (T1) - then - return T1; - -- Ada 2005 (AI-230): Support the following operators: -- function "=" (L, R : universal_access) return Boolean; @@ -3513,16 +3435,34 @@ package body Sem_Type is -- Note that this does not preclude one operand to be a pool-specific -- access type, as a previous version of this code enforced. - elsif Ada_Version >= Ada_2005 then - if Is_Anonymous_Access_Type (T1) - and then Is_Access_Type (T2) - then - return T1; + elsif Is_Anonymous_Access_Type (T1) + and then Is_Access_Type (T2) + and then Ada_Version >= Ada_2005 + then + return T1; - elsif Is_Anonymous_Access_Type (T2) - and then Is_Access_Type (T1) - then - return T2; + elsif Is_Anonymous_Access_Type (T2) + and then Is_Access_Type (T1) + and then Ada_Version >= Ada_2005 + then + return T2; + + -- In instances, also check private views the same way as Covers + + elsif Is_Private_Type (T1) and then In_Instance then + if Present (Full_View (T1)) then + return Specific_Type (Full_View (T1), T2); + + elsif Present (Underlying_Full_View (T1)) then + return Specific_Type (Underlying_Full_View (T1), T2); + end if; + + elsif Is_Private_Type (T2) and then In_Instance then + if Present (Full_View (T2)) then + return Specific_Type (T1, Full_View (T2)); + + elsif Present (Underlying_Full_View (T2)) then + return Specific_Type (T1, Underlying_Full_View (T2)); end if; end if; @@ -3580,15 +3520,14 @@ package body Sem_Type is -- Valid_Comparison_Arg -- -------------------------- + -- See above for the reason why aggregates and strings are included + function Valid_Comparison_Arg (T : Entity_Id) return Boolean is begin + if Is_Discrete_Type (T) or else Is_Real_Type (T) then + return True; - if T = Any_Composite then - return False; - - elsif Is_Discrete_Type (T) - or else Is_Real_Type (T) - then + elsif T = Any_Composite or else T = Any_String then return True; elsif Is_Array_Type (T) @@ -3608,11 +3547,40 @@ package body Sem_Type is elsif Is_String_Type (T) then return True; + else return False; end if; end Valid_Comparison_Arg; + ------------------------ + -- Valid_Equality_Arg -- + ------------------------ + + -- Same reasoning as above but implicit because of the nonlimited test + + function Valid_Equality_Arg (T : Entity_Id) return Boolean is + begin + -- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow + -- anonymous access types in universal_access equality operators. + + if Is_Anonymous_Access_Type (T) then + return Ada_Version >= Ada_2005; + + elsif not Is_Limited_Type (T) then + return True; + + elsif Is_Array_Type (T) + and then not Is_Limited_Type (Component_Type (T)) + and then Available_Full_View_Of_Component (T) + then + return True; + + else + return False; + end if; + end Valid_Equality_Arg; + ------------------ -- Write_Interp -- ------------------ diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index bdb44d6c149..a6111b1d0e2 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -103,9 +103,12 @@ package Sem_Type is -- in N. If the name is an expanded name, the homonyms are only those that -- belong to the same scope. - function Is_Invisible_Operator (N : Node_Id; T : Entity_Id) return Boolean; - -- Check whether a predefined operation with universal operands appears in - -- a context in which the operators of the expected type are not visible. + function Is_Visible_Operator (N : Node_Id; Typ : Entity_Id) return Boolean; + -- Determine whether a predefined operation is performed in a context where + -- the predefined operators of base type Typ are visible. The existence of + -- this routine is an implementation artifact. A more straightforward but + -- more space-consuming choice would be to make all inherited operators + -- explicit in the symbol table. See also Sem_ch8.Has_Implicit_Operator. procedure List_Interps (Nam : Node_Id; Err : Node_Id); -- List candidate interpretations of an overloaded name. Used for various @@ -181,22 +184,15 @@ package Sem_Type is -- opposed to an operator, type and mode conformance are required. function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id; - -- Used in second pass of resolution, for equality and comparison nodes. L - -- is the left operand, whose type is known to be correct, and R is the - -- right operand, which has one interpretation compatible with that of L. - -- Return the type intersection of the two. + -- Used in type resolution for equality and comparison nodes. L and R are + -- the operands, whose type is known to be correct or Any_Type in case of + -- ambiguity. Return the type intersection of the two. - function Has_Compatible_Type - (N : Node_Id; - Typ : Entity_Id; - For_Comparison : Boolean := False) return Boolean; + function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean; -- Verify that some interpretation of the node N has a type compatible with -- Typ. If N is not overloaded, then its unique type must be compatible -- with Typ. Otherwise iterate through the interpretations of N looking for - -- a compatible one. If For_Comparison is true, the function is invoked for - -- a comparison (or equality) operator and also needs to verify the reverse - -- compatibility, because the implementation of type resolution for these - -- operators is not fully symmetrical. + -- a compatible one. function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean; -- A user-defined function hides a predefined operator if it matches the @@ -259,13 +255,22 @@ package Sem_Type is procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id); -- Set the abstract operation field of an interpretation - function Valid_Comparison_Arg (T : Entity_Id) return Boolean; - -- A valid argument to an ordering operator must be a discrete type, a - -- real type, or a one dimensional array with a discrete component type. + function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id; + -- If Typ_1 and Typ_2 are compatible, return the one that is not universal + -- or is not a "class" type (any_character, etc). function Valid_Boolean_Arg (T : Entity_Id) return Boolean; - -- A valid argument of a boolean operator is either some boolean type, or a - -- one-dimensional array of boolean type. + -- A valid argument of a predefined boolean operator must be a boolean type + -- or a 1-dimensional array of boolean type. + + function Valid_Comparison_Arg (T : Entity_Id) return Boolean; + -- A valid argument of a predefined comparison operator must be a discrete + -- type, real type or a 1-dimensional array with a discrete component type. + + function Valid_Equality_Arg (T : Entity_Id) return Boolean; + -- A valid argument of a predefined equality operator must be a nonlimited + -- type or an array with a limited private component whose full view is not + -- limited. procedure Write_Interp (It : Interp); -- Debugging procedure to display an Interp diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a4199679700..7f56ab496ed 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -21478,6 +21478,25 @@ package body Sem_Util is and then Nkind (Parent (Id)) = N_Function_Specification; end Is_User_Defined_Equality; + ----------------------------- + -- Is_User_Defined_Literal -- + ----------------------------- + + function Is_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean + is + Literal_Aspect_Map : + constant array (N_Numeric_Or_String_Literal) of Aspect_Id := + (N_Integer_Literal => Aspect_Integer_Literal, + N_Real_Literal => Aspect_Real_Literal, + N_String_Literal => Aspect_String_Literal); + + begin + return Nkind (N) in N_Numeric_Or_String_Literal + and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))); + end Is_User_Defined_Literal; + -------------------------------------- -- Is_Validation_Variable_Reference -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 695158a34f3..e5dee96b7f4 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2468,6 +2468,12 @@ package Sem_Util is function Is_User_Defined_Equality (Id : Entity_Id) return Boolean; -- Determine whether an entity denotes a user-defined equality + function Is_User_Defined_Literal + (N : Node_Id; + Typ : Entity_Id) return Boolean; + pragma Inline (Is_User_Defined_Literal); + -- Determine whether N is a user-defined literal for Typ + function Is_Validation_Variable_Reference (N : Node_Id) return Boolean; -- Determine whether N denotes a reference to a variable which captures the -- value of an object for validation purposes.