public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-181] [Ada] Revamp type resolution for comparison and equality operators
@ 2022-05-09 9:30 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-09 9:30 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:eb05097d5508618a70b279df6d10d409eb4c60ae
commit r13-181-geb05097d5508618a70b279df6d10d409eb4c60ae
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Mon Jan 3 11:32:48 2022 +0100
[Ada] Revamp type resolution for comparison and equality operators
The main goal was to make it symmetrical, but this also moves error handling
entirely to the second phase of type resolution.
gcc/ada/
* einfo.ads (Access Kinds): Reorder and beef up.
* sem.adb (Analyze): Call Analyze_Comparison_Equality_Op for all
comparison and equality operators.
* sem_ch4.ads (Analyze_Comparison_Op): Delete.
(Analyze_Equality_Op): Likewise.
(Analyze_Comparison_Equality_Op): Declare.
(Ambiguous_Operands): Likewise.
* sem_ch4.adb (Ambiguous_Operands): Remove declaration.
(Defined_In_Scope): Delete.
(Find_Comparison_Types): Merge into...
(Find_Equality_Types): Merge into...
(Find_Comparison_Equality_Types): ...this. Make fully symmetrical.
(Analyze_Arithmetic_Op): Minor consistency tweaks.
(Analyze_Comparison_Op): Merge into...
(Analyze_Equality_Op): Merge into...
(Analyze_Comparison_Equality_Op): ...this. Make fully symmetrical.
(Analyze_Logical_Op): Minor consistency tweaks.
(Analyze_Membership_Op): Make fully symmetrical.
(Analyze_One_Call): Minor comment tweak.
(Analyze_Operator_Call): Call Find_Comparison_Equality_Types.
(Analyze_User_Defined_Binary_Op): Make fully symmetrical.
(Check_Arithmetic_Pair.Specific_Type): Delete.
(Diagnose_Call): Add special handling for "+" operator.
(Operator_Check): Call Analyze_Comparison_Equality_Op.
* sem_ch8.adb (Has_Implicit_Operator): Add Is_Type guard for boolean
operators, use Valid_Comparison_Arg and Valid_Equality_Arg for resp.
comparison and equality operators.
* sem_res.adb (Check_For_Visible_Operator): Call Is_Visible_Operator
(Make_Call_Into_Operator): Use Preserve_Comes_From_Source.
(Resolve_Actuals): Deal specifically with Any_Type actuals for user-
defined comparison and equality operators.
(Resolve_Call): Minor tweaks.
(Resolve_Comparison_Op): Tidy up and give error for ambiguity.
(Resolve_Equality_Op): Likewise, as well as other errors.
(Rewrite_Renamed_Operator): Simplify.
* sem_type.ads (Is_Invisible_Operator): Delete.
(Is_Visible_Operator): Declare.
(Has_Compatible_Type): Remove For_Comparison parameter.
(Specific_Type): Declare.
(Valid_Equality_Arg): Likewise.
* sem_type.adb (Specific_Type): Remove declaration.
(Add_One_Interp): Call Is_Visible_Operator for the visibility test.
(Remove_Conversions): Rename into...
(Remove_Conversions_And_Abstract_Operations): ...this. Do not apply
numeric-type treatment to Any_Type. Expand the special handling for
abstract interpretations to second operand. Remove obsolete code.
(Disambiguate): Adjust to above renaming. Tweak to hidden case and
call Remove_Conversions_And_Abstract_Operations for operators too.
(Entity_Matches_Spec): Minor tweak.
(Find_Unique_Type): Simplify and deal with user-defined literals.
(Has_Compatible_Type): Remove For_Comparison parameter and adjust.
Call the Is_User_Defined_Literal predicate and remove call to
the Is_Invisible_Operator predicate.
(Is_Invisible_Operator): Delete.
(Is_Visible_Operator): New function.
(Operator_Matches_Spec): Use Valid_Equality_Arg predicate.
(Specific_Type): Tidy up, make fully symmetrical and deal with
private views the same way as Covers.
(Valid_Comparison_Arg): Return true for Any_Composite/Any_String.
(Valid_Equality_Arg): New function.
* sem_util.ads (Is_User_Defined_Literal): Declare.
* sem_util.adb (Is_User_Defined_Literal): New function.
Diff:
---
gcc/ada/einfo.ads | 18 +-
gcc/ada/sem.adb | 12 +-
gcc/ada/sem_ch4.adb | 1286 +++++++++++++++++++-------------------------------
gcc/ada/sem_ch4.ads | 7 +-
gcc/ada/sem_ch8.adb | 13 +-
gcc/ada/sem_res.adb | 358 ++++++++------
gcc/ada/sem_type.adb | 546 ++++++++++-----------
gcc/ada/sem_type.ads | 47 +-
gcc/ada/sem_util.adb | 19 +
gcc/ada/sem_util.ads | 6 +
10 files changed, 1056 insertions(+), 1256 deletions(-)
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.
+
+ 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 --
@@ -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);
+ 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
@@ -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
+ 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,652 +6584,334 @@ 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
- 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 --
@@ -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;
-
- 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;
@@ -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.
-
- 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;
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,14 @@ 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;
@@ -1707,44 +1693,46 @@ package body Sem_Type is
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 --
@@ -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.
-
- 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;
@@ -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))))
-
- 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;
@@ -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 (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
@@ -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.
-
- function Has_Compatible_Type
- (N : Node_Id;
- Typ : Entity_Id;
- For_Comparison : Boolean := False) return Boolean;
+ -- 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) 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.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-09 9:30 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-09 9:30 [gcc r13-181] [Ada] Revamp type resolution for comparison and equality operators Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).