-- 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;
-- 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;
-- 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;
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;
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.
---------------------------
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);
-- 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
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 --
---------------------------
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
-- 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);
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;
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;
Operator_Check (N);
Check_Function_Writable_Actuals (N);
- end Analyze_Equality_Op;
+ end Analyze_Comparison_Equality_Op;
----------------------------------
-- Analyze_Explicit_Dereference --
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.
------------------------
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);
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);
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
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.
+
+ 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.
- 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 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 --
end loop;
end if;
- Set_Etype (N, Standard_Boolean);
-
if Present (Common_Type) then
Set_Etype (L, Common_Type);
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);
+ if Try_Left_Interp (It.Typ) 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
+ Ambiguous_Operands (N);
+ Set_Etype (L, Any_Type);
+ return True;
+ end if;
+
+ else
+ Valid_I := I;
+ end if;
+
+ L_Typ := It.Typ;
+ Set_Etype (L, L_Typ);
+ Found := True;
+ end if;
+
+ Get_Next_Interp (I, It);
end loop;
end if;
- end Find_Interpretation;
-
- function Find_Interpretation return Boolean is
- begin
- Find_Interpretation;
return Found;
- end Find_Interpretation;
+ end Find_Interp;
- --------------------
- -- Try_One_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;
- 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);
+ -- Defend against previous error
- if It = No_Interp then
- Ambiguous_Operands (N);
- Set_Etype (L, Any_Type);
- return;
+ if Nkind (R) = N_Error then
+ Found := False;
- else
- T_F := It.Typ;
- end if;
+ -- Loop through the interpretations of the right operand
- else
- Found := True;
- T_F := T1;
- I_F := Index;
- end if;
+ 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;
- Set_Etype (L, T_F);
+ else
+ Valid_I := I;
+ end if;
+
+ R_Typ := It.Typ;
+ Found := True;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
end if;
- end Try_One_Interp;
- Op : Node_Id;
+ 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
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
+ 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
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);
=>
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);
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
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));
-- 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 --
------------------
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
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 --
-------------------
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
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);
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;
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
Get_Next_Interp (Index1, It1);
end loop;
end if;
-
end Find_Arithmetic_Types;
------------------------
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
- 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.
-
- 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;
+ function Is_Valid_Equality_Type
+ (T : Entity_Id;
+ Anon_Access : Boolean) return Boolean;
+ -- Return true if T is a valid equality type
- 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);
+ 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.
- if It = No_Interp then
- Ambiguous_Operands (N);
- Set_Etype (L, Any_Type);
- return;
+ ---------------------
+ -- Try_Left_Interp --
+ ---------------------
- else
- T_F := It.Typ;
- end if;
- else
- Found := True;
- T_F := T1;
- I_F := Index;
- end if;
+ function Try_Left_Interp (T : Entity_Id) return Entity_Id is
+ I : Interp_Index;
+ It : Interp;
+ R_Typ : Entity_Id;
+ Valid_I : Interp_Index;
- Set_Etype (L, T_F);
- Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
- end if;
- end Try_One_Interp;
+ begin
+ -- Defend against previous error
- -- Start of processing for Find_Comparison_Types
+ if Nkind (R) = N_Error then
+ null;
- begin
- -- If left operand is aggregate, the right operand has to
- -- provide a usable type for it.
+ -- Loop through the interpretations of the right operand
- 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;
+ elsif not Is_Overloaded (R) then
+ if Is_Valid_Pair (T, Etype (R)) then
+ return Etype (R);
+ end if;
- if Nkind (N) = N_Function_Call
- and then Nkind (Name (N)) = N_Expanded_Name
- then
- Scop := Entity (Prefix (Name (N)));
+ else
+ R_Typ := Empty;
+ Valid_I := 0;
- -- The prefix may be a package renaming, and the subsequent test
- -- requires the original package.
+ 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 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;
+ if Present (R_Typ)
+ and then Base_Type (It.Typ) /= Base_Type (R_Typ)
+ then
+ It := Disambiguate (R, Valid_I, I, Any_Type);
- begin
- -- Defend against previous error
+ if It = No_Interp then
+ R_Typ := Any_Type;
+ exit;
+ end if;
- if Nkind (R) = N_Error then
- return;
- end if;
+ else
+ Valid_I := I;
+ 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);
- while Present (It.Typ) loop
- if Covers (It.Typ, T1) then
- Add_One_Interp
- (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
+ R_Typ := It.Typ;
end if;
- Get_Next_Interp (Index, It);
+ Get_Next_Interp (I, It);
end loop;
- end if;
- elsif Has_Compatible_Type (R, T1) or else Covers (Etype (R), T1) then
- Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
- end if;
- end Find_Non_Universal_Interpretations;
-
- ------------------------------
- -- Find_Concatenation_Types --
- ------------------------------
-
- procedure Find_Concatenation_Types
- (L, R : Node_Id;
- Op_Id : Entity_Id;
- N : Node_Id)
- is
- Is_String : constant Boolean := Nkind (L) = N_String_Literal
- or else
- Nkind (R) = N_String_Literal;
- Op_Type : constant Entity_Id := Etype (Op_Id);
-
- begin
- if Is_Array_Type (Op_Type)
-
- -- Small but very effective optimization: if at least one operand is a
- -- string literal, then the type of the operator must be either array
- -- of characters or array of strings.
-
- and then (not Is_String
- or else
- Is_Character_Type (Component_Type (Op_Type))
- or else
- Is_String_Type (Component_Type (Op_Type)))
-
- and then not Is_Limited_Type (Op_Type)
-
- and then (Has_Compatible_Type (L, Op_Type)
- or else
- Has_Compatible_Type (L, Component_Type (Op_Type)))
-
- and then (Has_Compatible_Type (R, Op_Type)
- or else
- Has_Compatible_Type (R, Component_Type (Op_Type)))
- then
- Add_One_Interp (N, Op_Id, Op_Type);
- 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);
+ if Present (R_Typ) then
+ return R_Typ;
+ end if;
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.
+ return Empty;
+ end Try_Left_Interp;
- 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
+ ------------------------------
+ -- Is_Valid_Comparison_Type --
+ ------------------------------
+ function Is_Valid_Comparison_Type (T : Entity_Id) return Boolean is
begin
- -- Return immediately with no checks if Typ is not an
- -- access-to-object type.
+ -- The operation must be performed in a context where the operators
+ -- of the base type are visible.
- if not Is_Access_Object_Type (Typ) then
- return True;
+ if Is_Visible_Operator (N, Base_Type (T)) then
+ null;
- -- Any_Type is compatible with all types in this context, and is used
- -- in particular for the designated type of a 'null' value.
+ -- Save candidate type for subsequent error message, if any
- 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;
+ if Valid_Comparison_Arg (T) then
+ Candidate_Type := T;
+ end if;
- Get_Next_Interp (I, It);
- end loop;
- end;
+ return False;
end if;
- return False;
- end Check_Access_Object_Types;
+ -- Defer to the common implementation for the rest
- -------------------------------
- -- Check_Compatible_Profiles --
- -------------------------------
+ return Valid_Comparison_Arg (T);
+ end Is_Valid_Comparison_Type;
- 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;
+ ----------------------------
+ -- Is_Valid_Equality_Type --
+ ----------------------------
+ function Is_Valid_Equality_Type
+ (T : Entity_Id;
+ Anon_Access : Boolean) return Boolean
+ is
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;
+ -- 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.
- 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;
+ 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;
- Get_Next_Interp (I, It);
- end loop;
+ -- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow
+ -- anonymous access types in universal_access equality operators.
- if Found then
- Check_Subtype_Conformant
- (Designated_Type (Tmp), Designated_Type (Typ), N);
+ elsif Anon_Access then
+ if Ada_Version < Ada_2005 then
+ return False;
end if;
- end if;
- end Check_Compatible_Profiles;
- --------------------------------------
- -- References_Anonymous_Access_Type --
- --------------------------------------
+ -- Save candidate type for subsequent error message, if any
- 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;
+ if Valid_Equality_Arg (T) then
+ Candidate_Type := T;
+ end if;
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;
+ -- 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;
- begin
- -- Perform a sanity check in case of previous errors
+ -- Defer to the common implementation for the rest
- if No (T1) then
- return;
+ else
+ return Valid_Equality_Arg (T);
end if;
+ end Is_Valid_Equality_Type;
- 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);
+ -------------------
+ -- Is_Valid_Pair --
+ -------------------
- if Present (Scop) then
+ 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.
- -- 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.
+ 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;
- 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))
+ else
+ if not Is_Valid_Comparison_Type (T1)
+ or else not Is_Valid_Comparison_Type (T2)
then
- null;
-
- elsif Scop /= Standard_Standard or else not Anonymous_Access then
-
- -- The scope does not contain an operator for the type
-
- return;
+ return False;
end if;
+ 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.
+ 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;
- 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;
+ -- Local variables
- elsif not Anonymous_Access then
- -- Save candidate type for subsequent error message, if any
+ I : Interp_Index;
+ It : Interp;
+ L_Typ : Entity_Id;
+ R_Typ : Entity_Id;
+ T : Entity_Id;
+ Valid_I : Interp_Index;
- if not Is_Limited_Type (T1) then
- Candidate_Type := T1;
- end if;
+ -- Start of processing for Find_Comparison_Equality_Types
- return;
- end if;
+ begin
+ -- Loop through the interpretations of the left operand
- -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
- -- Do not allow anonymous access types in equality operators.
+ if not Is_Overloaded (L) then
+ T := Try_Left_Interp (Etype (L));
- if Ada_Version < Ada_2005 and then Anonymous_Access then
- return;
+ if Present (T) then
+ Set_Etype (R, T);
+ Add_One_Interp (N, Op_Id, Op_Typ, Find_Unique_Type (L, R));
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))
+ else
+ L_Typ := Empty;
+ R_Typ := Empty;
+ Valid_I := 0;
- and then
- ((not Is_Limited_Type (T1)
- and then not Is_Limited_Composite (T1))
+ Get_First_Interp (L, I, It);
+ while Present (It.Typ) loop
+ T := Try_Left_Interp (It.Typ);
- or else
- (Is_Array_Type (T1)
- and then not Is_Limited_Type (Component_Type (T1))
- and then Available_Full_View_Of_Component (T1)))
+ if Present (T) then
+ -- If several interpretations are possible, disambiguate
- 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 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
- Ambiguous_Operands (N);
- Set_Etype (L, Any_Type);
- return;
+ if It = No_Interp then
+ L_Typ := Any_Type;
+ R_Typ := T;
+ exit;
+ end if;
else
- T_F := It.Typ;
- Is_Universal_Access := Anonymous_Access;
+ Valid_I := I;
end if;
- else
- Found := True;
- T_F := T1;
- I_F := Index;
- Is_Universal_Access := Anonymous_Access;
+ L_Typ := It.Typ;
+ R_Typ := T;
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
+ Get_Next_Interp (I, It);
+ end loop;
- if Etype (N) = Any_Type then
- Found := False;
- end if;
+ 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 Try_One_Interp;
-
- -- Start of processing for Find_Equality_Types
+ end if;
+ end Find_Comparison_Equality_Types;
- begin
- -- If left operand is aggregate, the right operand has to
- -- provide a usable type for it.
+ ------------------------------
+ -- Find_Concatenation_Types --
+ ------------------------------
- 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;
+ procedure Find_Concatenation_Types
+ (L, R : Node_Id;
+ Op_Id : Entity_Id;
+ N : Node_Id)
+ is
+ Is_String : constant Boolean := Nkind (L) = N_String_Literal
+ or else
+ Nkind (R) = N_String_Literal;
+ Op_Type : constant Entity_Id := Etype (Op_Id);
- if Nkind (N) = N_Function_Call
- and then Nkind (Name (N)) = N_Expanded_Name
- then
- Scop := Entity (Prefix (Name (N)));
+ begin
+ if Is_Array_Type (Op_Type)
- -- The prefix may be a package renaming, and the subsequent test
- -- requires the original package.
+ -- Small but very effective optimization: if at least one operand is a
+ -- string literal, then the type of the operator must be either array
+ -- of characters or array of strings.
- 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;
+ and then (not Is_String
+ or else
+ Is_Character_Type (Component_Type (Op_Type))
+ or else
+ Is_String_Type (Component_Type (Op_Type)))
- 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;
+ and then not Is_Limited_Type (Op_Type)
- 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;
+ and then (Has_Compatible_Type (L, Op_Type)
+ or else
+ Has_Compatible_Type (L, Component_Type (Op_Type)))
- Check_Access_Attribute (R);
- Check_Access_Attribute (L);
+ and then (Has_Compatible_Type (R, Op_Type)
+ or else
+ Has_Compatible_Type (R, Component_Type (Op_Type)))
+ then
+ Add_One_Interp (N, Op_Id, Op_Type);
end if;
- end Find_Equality_Types;
+ end Find_Concatenation_Types;
-------------------------
-- Find_Negation_Types --
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;
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;
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;
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;
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
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;
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;
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
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.
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
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;
-- 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;
-- 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;
-
- 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);
+ T : Entity_Id := Find_Unique_Type (L, R);
- if T = Any_Fixed then
- T := Unique_Fixed_Point_Type (L);
- end if;
+ begin
+ 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;
-- 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
-- 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 --
-------------------------
-- 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
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);
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;
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.
-
- 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));
+ 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));
- -- Indicate that both the original entity and its renaming are
- -- referenced at this point.
-
- Generate_Reference (Entity (N), N);
- Generate_Reference (Op, N);
-
- if Is_Binary then
- Set_Left_Opnd (Op_Node, Left_Opnd (N));
- end if;
+ if Is_Binary then
+ Set_Left_Opnd (Op_Node, Left_Opnd (N));
+ end if;
- Rewrite (N, Op_Node);
+ -- Indicate that both the original entity and its renaming are
+ -- referenced at this point.
- -- 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.
+ Generate_Reference (Entity (N), N);
+ Generate_Reference (Op, N);
- 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);
+ Rewrite (N, Op_Node);
- when others =>
- Resolve (N, Typ);
- end case;
- end if;
+ -- 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.
- elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then
+ 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);
- -- Operator renames a user-defined operator of the same name. Use the
- -- original operator in the node, which is the one Gigi knows about.
+ when N_Op_Abs
+ | N_Op_Minus
+ | N_Op_Plus
+ =>
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
- Set_Entity (N, Op);
- Set_Is_Overloaded (N, False);
+ when others =>
+ Resolve (N, Typ);
+ end case;
end if;
end Rewrite_Renamed_Operator;
-- 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 --
--------------------
-- 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
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;
-- 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
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;
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 --
---------------------------------
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
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;
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;
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;
return No_Interp;
end;
- end if;
- end if;
-
- <<Next_Interp>>
- 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.
+ 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.
- if Serious_Errors_Detected > 0 then
- declare
- Formal : Entity_Id;
+ declare
+ I : Interp_Index;
+ It : Interp;
- begin
- Formal := First_Formal (Nam1);
- while Present (Formal) loop
- if Etype (Formal) = Any_Type then
- return Disambiguate.It2;
- end if;
+ 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;
+ end if;
- Next_Formal (Formal);
- end loop;
+ Get_Next_Interp (I, It);
+ end loop;
- Formal := First_Formal (Nam2);
- while Present (Formal) loop
- if Etype (Formal) = Any_Type then
- return Disambiguate.It1;
- end if;
+ return No_Interp;
+ end;
+ end if;
+ end if;
- Next_Formal (Formal);
- end loop;
- end;
- end if;
+ <<Next_Interp>>
+ Get_Next_Interp (I, It);
+ end loop;
return It1;
- end Remove_Conversions;
+ end Remove_Conversions_And_Abstract_Operations;
-----------------------
-- Standard_Operator --
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;
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.
-
- 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)
+ -- 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 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;
end if;
else
- return No_Interp;
+ return Remove_Conversions_And_Abstract_Operations;
end if;
elsif It1.Nam = Predef_Subp then
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
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;
----------------------
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;
-------------------------------------
-- 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;
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)
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;
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))))
-
- 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))
+ 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)))
+
then
return True;
end if;
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 --
--------------------
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 --
------------------
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
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 (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))
+ 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 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
+ elsif T1 = Raise_Type then
return B2;
- elsif T1 = Universal_Access
- and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
+ 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 T2;
+ return B1;
- 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;
-
- -- 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;
+ return B1;
- 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
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;
-- 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;
-- 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)
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 --
------------------
git://gcc.gnu.org / gcc.git / commitdiff