procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Revamp type resolution for comparison and equality operators

Browse source 
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.
This commit is contained in:
Eric Botcazou 2022-01-03 11:32:48 +01:00 • committed by Pierre-Marie de Rodat
parent 320eb42df0
commit eb05097d55
10 changed files with 1087 additions and 1287 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/ada/einfo.ads
View file

@ -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 --

12
gcc/ada/sem.adb
View file

@ -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);

1354
gcc/ada/sem_ch4.adb
View file

File diff suppressed because it is too large Load diff

7
gcc/ada/sem_ch4.ads
View file

@ -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:

13
gcc/ada/sem_ch8.adb
View file

@ -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);

358
gcc/ada/sem_res.adb
View file

@ -141,7 +141,7 @@ package body Sem_Res is
function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean;
-- N is either an indexed component or a selected component. This function
-- returns true if the prefix refers to an object that has an address
-- returns true if the prefix denotes an atomic object that has an address
-- clause (the case in which we may want to issue a warning).
function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
@ -823,7 +823,10 @@ package body Sem_Res is
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
begin
if Is_Invisible_Operator (N, T) then
if Comes_From_Source (N)
and then not Is_Visible_Operator (Original_Node (N), T)
and then not Error_Posted (N)
then
Error_Msg_NE -- CODEFIX
("operator for} is not directly visible!", N, First_Subtype (T));
Error_Msg_N -- CODEFIX
@ -1662,6 +1665,14 @@ package body Sem_Res is
begin
Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
-- Preserve the Comes_From_Source flag on the result if the original
-- call came from source. Although it is not strictly the case that the
-- operator as such comes from the source, logically it corresponds
-- exactly to the function call in the source, so it should be marked
-- this way (e.g. to make sure that validity checks work fine).
Preserve_Comes_From_Source (Op_Node, N);
-- Ensure that the corresponding operator has the same parent as the
-- original call. This guarantees that parent traversals performed by
-- the ABE mechanism succeed.
@ -1900,18 +1911,7 @@ package body Sem_Res is
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
-- Do rewrite setting Comes_From_Source on the result if the original
-- call came from source. Although it is not strictly the case that the
-- operator as such comes from the source, logically it corresponds
-- exactly to the function call in the source, so it should be marked
-- this way (e.g. to make sure that validity checks work fine).
declare
CS : constant Boolean := Comes_From_Source (N);
begin
Rewrite (N, Op_Node);
Set_Comes_From_Source (N, CS);
end;
Rewrite (N, Op_Node);
-- If this is an arithmetic operator and the result type is private,
-- the operands and the result must be wrapped in conversion to
@ -4148,15 +4148,38 @@ package body Sem_Res is
if No (A) and then Needs_No_Actuals (Nam) then
null;
-- If we have an error in any actual or formal, indicated by a type
-- If we have an error in any formal or actual, indicated by a type
-- of Any_Type, then abandon resolution attempt, and set result type
-- to Any_Type. Skip this if the actual is a Raise_Expression, whose
-- type is imposed from context.
-- to Any_Type.
elsif (Present (A) and then Etype (A) = Any_Type)
or else Etype (F) = Any_Type
then
if Nkind (A) /= N_Raise_Expression then
elsif Etype (F) = Any_Type then
Set_Etype (N, Any_Type);
return;
elsif Present (A) and then Etype (A) = Any_Type then
-- For the peculiar case of a user-defined comparison or equality
-- operator that does not return a boolean type, the operands may
-- have been ambiguous for the predefined operator and, therefore,
-- marked with Any_Type. Since the operation has been resolved to
-- the user-defined operator, that is irrelevant, so reset Etype.
if Nkind (Original_Node (N)) in N_Op_Eq
| N_Op_Ge
| N_Op_Gt
| N_Op_Le
| N_Op_Lt
| N_Op_Ne
and then not Is_Boolean_Type (Etype (N))
then
Set_Etype (A, Etype (F));
-- Also skip this if the actual is a Raise_Expression, whose type
-- is imposed from context.
elsif Nkind (A) = N_Raise_Expression then
null;
else
Set_Etype (N, Any_Type);
return;
end if;
@ -6856,13 +6879,11 @@ package body Sem_Res is
-- functional notation. Replace call node with operator node, so
-- that actuals can be resolved appropriately.
if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
if Ekind (Nam) = E_Operator or else Is_Predefined_Op (Nam) then
Make_Call_Into_Operator (N, Typ, Nam);
return;
elsif Present (Alias (Nam))
and then Is_Predefined_Op (Alias (Nam))
then
elsif Present (Alias (Nam)) and then Is_Predefined_Op (Alias (Nam)) then
Resolve_Actuals (N, Nam);
Make_Call_Into_Operator (N, Typ, Alias (Nam));
return;
@ -7489,39 +7510,35 @@ package body Sem_Res is
-- Resolve_Comparison_Op --
---------------------------
-- Context requires a boolean type, and plays no role in resolution.
-- Processing identical to that for equality operators. The result type is
-- the base type, which matters when pathological subtypes of booleans with
-- limited ranges are used.
-- The operands must have compatible types and the boolean context does not
-- participate in the resolution. The first pass verifies that the operands
-- are not ambiguous and sets their type correctly, or to Any_Type in case
-- of ambiguity. If both operands are strings or aggregates, then they are
-- ambiguous even if they carry a single (universal) type.
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
T : Entity_Id := Find_Unique_Type (L, R);
begin
-- If this is an intrinsic operation which is not predefined, use the
-- types of its declared arguments to resolve the possibly overloaded
-- operands. Otherwise the operands are unambiguous and specify the
-- expected type.
if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N)));
else
T := Find_Unique_Type (L, R);
if T = Any_Fixed then
T := Unique_Fixed_Point_Type (L);
end if;
if T = Any_Fixed then
T := Unique_Fixed_Point_Type (L);
end if;
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
-- Skip remaining processing if already set to Any_Type
if T = Any_Type then
-- Deal with explicit ambiguity of operands
if Ekind (Entity (N)) = E_Operator
and then (Is_Overloaded (L) or else Is_Overloaded (R))
then
Ambiguous_Operands (N);
end if;
return;
end if;
@ -8510,25 +8527,38 @@ package body Sem_Res is
-- overlapping actuals, just like for a subprogram call.
Warn_On_Overlapping_Actuals (Nam, N);
end Resolve_Entry_Call;
-------------------------
-- Resolve_Equality_Op --
-------------------------
-- Both arguments must have the same type, and the boolean context does
-- not participate in the resolution. The first pass verifies that the
-- interpretation is not ambiguous, and the type of the left argument is
-- correctly set, or is Any_Type in case of ambiguity. If both arguments
-- are strings or aggregates, allocators, or Null, they are ambiguous even
-- though they carry a single (universal) type. Diagnose this case here.
-- The operands must have compatible types and the boolean context does not
-- participate in the resolution. The first pass verifies that the operands
-- are not ambiguous and sets their type correctly, or to Any_Type in case
-- of ambiguity. If both operands are strings, aggregates, allocators, or
-- null, they are ambiguous even if they carry a single (universal) type.
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id := Find_Unique_Type (L, R);
procedure Check_Access_Attribute (N : Node_Id);
-- For any object, '[Unchecked_]Access of such object can never be
-- passed as an operand to the Universal_Access equality operators.
-- This is so because the expected type for Obj'Access in a call to
-- these operators, whose formals are of type Universal_Access, is
-- Universal_Access, and Universal_Access does not have a designated
-- type. For more details, see RM 3.10.2(2/2) and 6.4.1(3).
procedure Check_Designated_Object_Types (T1, T2 : Entity_Id);
-- Check RM 4.5.2(9.6/2) on the given designated object types
procedure Check_Designated_Subprogram_Types (T1, T2 : Entity_Id);
-- Check RM 4.5.2(9.7/2) on the given designated subprogram types
procedure Check_If_Expression (Cond : Node_Id);
-- The resolution rule for if expressions requires that each such must
-- have a unique type. This means that if several dependent expressions
@ -8554,6 +8584,54 @@ package body Sem_Res is
-- could be the cause of confused priorities. Note that if the not is
-- in parens, then False is returned.
----------------------------
-- Check_Access_Attribute --
----------------------------
procedure Check_Access_Attribute (N : Node_Id) is
begin
if Nkind (N) = N_Attribute_Reference
and then Attribute_Name (N) in Name_Access | Name_Unchecked_Access
then
Error_Msg_N
("access attribute cannot be used as actual for "
& "universal_access equality", N);
end if;
end Check_Access_Attribute;
-----------------------------------
-- Check_Designated_Object_Types --
-----------------------------------
procedure Check_Designated_Object_Types (T1, T2 : Entity_Id) is
begin
if (Is_Elementary_Type (T1) or else Is_Array_Type (T1))
and then (Base_Type (T1) /= Base_Type (T2)
or else not Subtypes_Statically_Match (T1, T2))
then
Error_Msg_N
("designated subtypes for universal_access equality "
& "do not statically match (RM 4.5.2(9.6/2)", N);
Error_Msg_NE ("\left operand has}!", N, Etype (L));
Error_Msg_NE ("\right operand has}!", N, Etype (R));
end if;
end Check_Designated_Object_Types;
---------------------------------------
-- Check_Designated_Subprogram_Types --
---------------------------------------
procedure Check_Designated_Subprogram_Types (T1, T2 : Entity_Id) is
begin
if not Subtype_Conformant (T1, T2) then
Error_Msg_N
("designated subtypes for universal_access equality "
& "not subtype conformant (RM 4.5.2(9.7/2)", N);
Error_Msg_NE ("\left operand has}!", N, Etype (L));
Error_Msg_NE ("\right operand has}!", N, Etype (R));
end if;
end Check_Designated_Subprogram_Types;
-------------------------
-- Check_If_Expression --
-------------------------
@ -8727,14 +8805,25 @@ package body Sem_Res is
-- Start of processing for Resolve_Equality_Op
begin
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
if T = Any_Fixed then
T := Unique_Fixed_Point_Type (L);
end if;
if T /= Any_Type then
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
if T = Any_Type then
-- Deal with explicit ambiguity of operands
if Ekind (Entity (N)) = E_Operator
and then (Is_Overloaded (L) or else Is_Overloaded (R))
then
Ambiguous_Operands (N);
end if;
else
-- Deal with other error cases
if T = Any_String or else
T = Any_Composite or else
T = Any_Character
@ -8773,6 +8862,44 @@ package body Sem_Res is
Check_If_Expression (R);
end if;
-- RM 4.5.2(9.5/2): At least one of the operands of the equality
-- operators for universal_access shall be of type universal_access,
-- or both shall be of access-to-object types, or both shall be of
-- access-to-subprogram types (RM 4.5.2(9.5/2)).
if Is_Anonymous_Access_Type (T)
and then Etype (L) /= Universal_Access
and then Etype (R) /= Universal_Access
then
-- RM 4.5.2(9.6/2): When both are of access-to-object types, the
-- designated types shall be the same or one shall cover the other
-- and if the designated types are elementary or array types, then
-- the designated subtypes shall statically match.
if Is_Access_Object_Type (Etype (L))
and then Is_Access_Object_Type (Etype (R))
then
Check_Designated_Object_Types
(Designated_Type (Etype (L)), Designated_Type (Etype (R)));
-- RM 4.5.2(9.7/2): When both are of access-to-subprogram types,
-- the designated profiles shall be subtype conformant.
elsif Is_Access_Subprogram_Type (Etype (L))
and then Is_Access_Subprogram_Type (Etype (R))
then
Check_Designated_Subprogram_Types
(Designated_Type (Etype (L)), Designated_Type (Etype (R)));
end if;
end if;
-- Check another case of equality operators for universal_access
if Is_Anonymous_Access_Type (T) and then Comes_From_Source (N) then
Check_Access_Attribute (L);
Check_Access_Attribute (R);
end if;
Resolve (L, T);
Resolve (R, T);
@ -8895,33 +9022,6 @@ package body Sem_Res is
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
-- Ada 2005: If one operand is an anonymous access type, convert the
-- other operand to it, to ensure that the underlying types match in
-- the back-end. Same for access_to_subprogram, and the conversion
-- verifies that the types are subtype conformant.
-- We apply the same conversion in the case one of the operands is a
-- private subtype of the type of the other.
-- Why the Expander_Active test here ???
if Expander_Active
and then
(Ekind (T) in E_Anonymous_Access_Type
| E_Anonymous_Access_Subprogram_Type
or else Is_Private_Type (T))
then
if Etype (L) /= T then
Rewrite (L, Unchecked_Convert_To (T, L));
Analyze_And_Resolve (L, T);
end if;
if (Etype (R)) /= T then
Rewrite (R, Unchecked_Convert_To (Etype (L), R));
Analyze_And_Resolve (R, T);
end if;
end if;
end if;
end Resolve_Equality_Op;
@ -12592,63 +12692,49 @@ package body Sem_Res is
end;
end if;
-- Rewrite the operator node using the real operator, not its renaming.
-- Exclude user-defined intrinsic operations of the same name, which are
-- treated separately and rewritten as calls.
Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
Set_Chars (Op_Node, Nam);
Set_Etype (Op_Node, Etype (N));
Set_Entity (Op_Node, Op);
Set_Right_Opnd (Op_Node, Right_Opnd (N));
if Ekind (Op) /= E_Function or else Chars (N) /= Nam then
Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
Set_Chars (Op_Node, Nam);
Set_Etype (Op_Node, Etype (N));
Set_Entity (Op_Node, Op);
Set_Right_Opnd (Op_Node, Right_Opnd (N));
if Is_Binary then
Set_Left_Opnd (Op_Node, Left_Opnd (N));
end if;
-- Indicate that both the original entity and its renaming are
-- referenced at this point.
-- Indicate that both the original entity and its renaming are
-- referenced at this point.
Generate_Reference (Entity (N), N);
Generate_Reference (Op, N);
Generate_Reference (Entity (N), N);
Generate_Reference (Op, N);
if Is_Binary then
Set_Left_Opnd (Op_Node, Left_Opnd (N));
end if;
Rewrite (N, Op_Node);
Rewrite (N, Op_Node);
-- If the context type is private, add the appropriate conversions so
-- that the operator is applied to the full view. This is done in the
-- routines that resolve intrinsic operators.
-- If the context type is private, add the appropriate conversions so
-- that the operator is applied to the full view. This is done in the
-- routines that resolve intrinsic operators.
if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then
case Nkind (N) is
when N_Op_Add
| N_Op_Divide
| N_Op_Expon
| N_Op_Mod
| N_Op_Multiply
| N_Op_Rem
| N_Op_Subtract
=>
Resolve_Intrinsic_Operator (N, Typ);
if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then
case Nkind (N) is
when N_Op_Add
| N_Op_Divide
| N_Op_Expon
| N_Op_Mod
| N_Op_Multiply
| N_Op_Rem
| N_Op_Subtract
=>
Resolve_Intrinsic_Operator (N, Typ);
when N_Op_Abs
| N_Op_Minus
| N_Op_Plus
=>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when N_Op_Abs
| N_Op_Minus
| N_Op_Plus
=>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
Resolve (N, Typ);
end case;
end if;
elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then
-- Operator renames a user-defined operator of the same name. Use the
-- original operator in the node, which is the one Gigi knows about.
Set_Entity (N, Op);
Set_Is_Overloaded (N, False);
when others =>
Resolve (N, Typ);
end case;
end if;
end Rewrite_Renamed_Operator;

542
gcc/ada/sem_type.adb
View file

@ -192,10 +192,6 @@ package body Sem_Type is
-- multiple interpretations. Interpretations can be added to only one
-- node at a time.
function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
-- If Typ_1 and Typ_2 are compatible, return the one that is not universal
-- or is not a "class" type (any_character, etc).
--------------------
-- Add_One_Interp --
--------------------
@ -365,14 +361,12 @@ package body Sem_Type is
-- Start of processing for Add_One_Interp
begin
-- If the interpretation is a predefined operator, verify that the
-- result type is visible, or that the entity has already been
-- resolved (case of an instantiation node that refers to a predefined
-- operation, or an internally generated operator node, or an operator
-- given as an expanded name). If the operator is a comparison or
-- equality, it is the type of the operand that matters to determine
-- whether the operator is visible. In an instance, the check is not
-- performed, given that the operator was visible in the generic.
-- If the interpretation is a predefined operator, verify that it is
-- visible, or that the entity has already been resolved (case of an
-- instantiation node that refers to a predefined operation, or an
-- internally generated operator node, or an operator given as an
-- expanded name). If the operator is a comparison or equality, then
-- it is the type of the operand that is relevant here.
if Ekind (E) = E_Operator then
if Present (Opnd_Type) then
@ -381,29 +375,9 @@ package body Sem_Type is
Vis_Type := Base_Type (T);
end if;
if In_Open_Scopes (Scope (Vis_Type))
or else Is_Potentially_Use_Visible (Vis_Type)
or else In_Use (Vis_Type)
or else (In_Use (Scope (Vis_Type))
and then not Is_Hidden (Vis_Type))
or else Nkind (N) = N_Expanded_Name
if Nkind (N) = N_Expanded_Name
or else (Nkind (N) in N_Op and then E = Entity (N))
or else (In_Instance or else In_Inlined_Body)
or else Is_Anonymous_Access_Type (Vis_Type)
then
null;
-- If the node is given in functional notation and the prefix
-- is an expanded name, then the operator is visible if the
-- prefix is the scope of the result type as well. If the
-- operator is (implicitly) defined in an extension of system,
-- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
or else Scope (Vis_Type) = System_Aux_Id)
or else Is_Visible_Operator (N, Vis_Type)
then
null;
@ -1334,7 +1308,7 @@ package body Sem_Type is
-- It may given by an operator name, or by an expanded name whose prefix
-- is Standard.
function Remove_Conversions return Interp;
function Remove_Conversions_And_Abstract_Operations return Interp;
-- Last chance for pathological cases involving comparisons on literals,
-- and user overloadings of the same operator. Such pathologies have
-- been removed from the ACVC, but still appear in two DEC tests, with
@ -1522,11 +1496,11 @@ package body Sem_Type is
return Etype (Opnd);
end Operand_Type;
------------------------
-- Remove_Conversions --
------------------------
------------------------------------------------
-- Remove_Conversions_And_Abstract_Operations --
------------------------------------------------
function Remove_Conversions return Interp is
function Remove_Conversions_And_Abstract_Operations return Interp is
I : Interp_Index;
It : Interp;
It1 : Interp;
@ -1535,13 +1509,16 @@ package body Sem_Type is
Act2 : Node_Id;
function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
-- If an operation has universal operands the universal operation
-- If an operation has universal operands, the universal operation
-- is present among its interpretations. If there is an abstract
-- interpretation for the operator, with a numeric result, this
-- interpretation was already removed in sem_ch4, but the universal
-- one is still visible. We must rescan the list of operators and
-- remove the universal interpretation to resolve the ambiguity.
function Is_Numeric_Only_Type (T : Entity_Id) return Boolean;
-- Return True if T is a numeric type and not Any_Type
---------------------------------
-- Has_Abstract_Interpretation --
---------------------------------
@ -1562,7 +1539,7 @@ package body Sem_Type is
while Present (E) loop
if Is_Overloadable (E)
and then Is_Abstract_Subprogram (E)
and then Is_Numeric_Type (Etype (E))
and then Is_Numeric_Only_Type (Etype (E))
then
return True;
else
@ -1587,7 +1564,16 @@ package body Sem_Type is
end if;
end Has_Abstract_Interpretation;
-- Start of processing for Remove_Conversions
--------------------------
-- Is_Numeric_Only_Type --
--------------------------
function Is_Numeric_Only_Type (T : Entity_Id) return Boolean is
begin
return Is_Numeric_Type (T) and then T /= Any_Type;
end Is_Numeric_Only_Type;
-- Start of processing for Remove_Conversions_And_Abstract_Operations
begin
It1 := No_Interp;
@ -1676,11 +1662,11 @@ package body Sem_Type is
It1 := It;
end if;
elsif Is_Numeric_Type (Etype (F1))
elsif Is_Numeric_Only_Type (Etype (F1))
and then Has_Abstract_Interpretation (Act1)
then
-- Current interpretation is not the right one because it
-- expects a numeric operand. Examine all the other ones.
-- expects a numeric operand. Examine all the others.
declare
I : Interp_Index;
@ -1689,14 +1675,45 @@ package body Sem_Type is
begin
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if
not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
if not Is_Numeric_Only_Type
(Etype (First_Formal (It.Nam)))
then
if No (Act2)
or else not Has_Abstract_Interpretation (Act2)
or else not
Is_Numeric_Type
Is_Numeric_Only_Type
(Etype (Next_Formal (First_Formal (It.Nam))))
or else not Has_Abstract_Interpretation (Act2)
then
return It;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
return No_Interp;
end;
elsif Is_Numeric_Only_Type (Etype (F1))
and then Present (Act2)
and then Has_Abstract_Interpretation (Act2)
then
-- Current interpretation is not the right one because it
-- expects a numeric operand. Examine all the others.
declare
I : Interp_Index;
It : Interp;
begin
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if not Is_Numeric_Only_Type
(Etype (Next_Formal (First_Formal (It.Nam))))
then
if not Is_Numeric_Only_Type
(Etype (First_Formal (It.Nam)))
or else not Has_Abstract_Interpretation (Act1)
then
return It;
end if;
@ -1714,37 +1731,8 @@ package body Sem_Type is
Get_Next_Interp (I, It);
end loop;
-- After some error, a formal may have Any_Type and yield a spurious
-- match. To avoid cascaded errors if possible, check for such a
-- formal in either candidate.
if Serious_Errors_Detected > 0 then
declare
Formal : Entity_Id;
begin
Formal := First_Formal (Nam1);
while Present (Formal) loop
if Etype (Formal) = Any_Type then
return Disambiguate.It2;
end if;
Next_Formal (Formal);
end loop;
Formal := First_Formal (Nam2);
while Present (Formal) loop
if Etype (Formal) = Any_Type then
return Disambiguate.It1;
end if;
Next_Formal (Formal);
end loop;
end;
end if;
return It1;
end Remove_Conversions;
end Remove_Conversions_And_Abstract_Operations;
-----------------------
-- Standard_Operator --
@ -2145,10 +2133,10 @@ package body Sem_Type is
end if;
else
return Remove_Conversions;
return Remove_Conversions_And_Abstract_Operations;
end if;
else
return Remove_Conversions;
return Remove_Conversions_And_Abstract_Operations;
end if;
end if;
@ -2162,18 +2150,19 @@ package body Sem_Type is
then
return No_Interp;
-- If the user-defined operator is in an open scope, or in the scope
-- of the resulting type, or given by an expanded name that names its
-- scope, it hides the predefined operator for the type. Exponentiation
-- has to be special-cased because the implicit operator does not have
-- a symmetric signature, and may not be hidden by the explicit one.
-- If the user-defined operator matches the signature of the operator,
-- and is declared in an open scope, or in the scope of the resulting
-- type, or given by an expanded name that names its scope, it hides
-- the predefined operator for the type. But exponentiation has to be
-- special-cased because the latter operator does not have a symmetric
-- signature, and may not be hidden by the explicit one.
elsif (Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Chars (Predef_Subp) /= Name_Op_Expon
or else Hides_Op (User_Subp, Predef_Subp))
and then Scope (User_Subp) = Entity (Prefix (Name (N))))
or else Hides_Op (User_Subp, Predef_Subp)
elsif Hides_Op (User_Subp, Predef_Subp)
or else (Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
and then (Chars (Predef_Subp) /= Name_Op_Expon
or else Hides_Op (User_Subp, Predef_Subp))
and then Scope (User_Subp) = Entity (Prefix (Name (N))))
then
if It1.Nam = User_Subp then
return It1;
@ -2246,7 +2235,7 @@ package body Sem_Type is
end if;
else
return No_Interp;
return Remove_Conversions_And_Abstract_Operations;
end if;
elsif It1.Nam = Predef_Subp then
@ -2264,8 +2253,8 @@ package body Sem_Type is
function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
begin
-- Simple case: same entity kinds, type conformance is required. A
-- parameterless function can also rename a literal.
-- For the simple case of same kinds, type conformance is required, but
-- a parameterless function can also rename a literal.
if Ekind (Old_S) = Ekind (New_S)
or else (Ekind (New_S) = E_Function
@ -2273,12 +2262,16 @@ package body Sem_Type is
then
return Type_Conformant (New_S, Old_S);
elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then
return Operator_Matches_Spec (Old_S, New_S);
-- Likewise for a procedure and an entry
elsif Ekind (New_S) = E_Procedure and then Is_Entry (Old_S) then
return Type_Conformant (New_S, Old_S);
-- For a user-defined operator, use the dedicated predicate
elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then
return Operator_Matches_Spec (Old_S, New_S);
else
return False;
end if;
@ -2289,60 +2282,18 @@ package body Sem_Type is
----------------------
function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
T : constant Entity_Id := Etype (L);
I : Interp_Index;
It : Interp;
TR : Entity_Id := Any_Type;
T : constant Entity_Id := Specific_Type (Etype (L), Etype (R));
begin
if Is_Overloaded (R) then
Get_First_Interp (R, I, It);
while Present (It.Typ) loop
if Covers (T, It.Typ) or else Covers (It.Typ, T) then
-- If several interpretations are possible and L is universal,
-- apply preference rule.
if TR /= Any_Type then
if Is_Universal_Numeric_Type (T)
and then It.Typ = T
then
TR := It.Typ;
end if;
else
TR := It.Typ;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
Set_Etype (R, TR);
-- In the non-overloaded case, the Etype of R is already set correctly
else
null;
if T = Any_Type then
if Is_User_Defined_Literal (L, Etype (R)) then
return Etype (R);
elsif Is_User_Defined_Literal (R, Etype (L)) then
return Etype (L);
end if;
end if;
-- If one of the operands is Universal_Fixed, the type of the other
-- operand provides the context.
if Etype (R) = Universal_Fixed then
return T;
elsif T = Universal_Fixed then
return Etype (R);
-- If one operand is a raise_expression, use type of other operand
elsif Nkind (L) = N_Raise_Expression then
return Etype (R);
else
return Specific_Type (T, Etype (R));
end if;
return T;
end Find_Unique_Type;
-------------------------------------
@ -2446,10 +2397,7 @@ package body Sem_Type is
-- Has_Compatible_Type --
-------------------------
function Has_Compatible_Type
(N : Node_Id;
Typ : Entity_Id;
For_Comparison : Boolean := False) return Boolean
function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean
is
I : Interp_Index;
It : Interp;
@ -2463,8 +2411,8 @@ package body Sem_Type is
if Covers (Typ, Etype (N))
-- Ada 2005 (AI-345): The context may be a synchronized interface.
-- If the type is already frozen use the corresponding_record
-- to check whether it is a proper descendant.
-- If the type is already frozen, use the corresponding_record to
-- check whether it is a proper descendant.
or else
(Is_Record_Type (Typ)
@ -2478,23 +2426,8 @@ package body Sem_Type is
and then Present (Corresponding_Record_Type (Typ))
and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
or else
(Nkind (N) = N_Integer_Literal
and then Present (Find_Aspect (Typ, Aspect_Integer_Literal)))
or else Is_User_Defined_Literal (N, Typ)
or else
(Nkind (N) = N_Real_Literal
and then Present (Find_Aspect (Typ, Aspect_Real_Literal)))
or else
(Nkind (N) = N_String_Literal
and then Present (Find_Aspect (Typ, Aspect_String_Literal)))
or else
(For_Comparison
and then not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
and then Covers (Etype (N), Typ))
then
return True;
end if;
@ -2504,26 +2437,24 @@ package body Sem_Type is
else
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
if (Covers (Typ, It.Typ)
and then
(Scope (It.Nam) /= Standard_Standard
or else not Is_Invisible_Operator (N, Base_Type (Typ))))
if Covers (Typ, It.Typ)
-- Ada 2005 (AI-345)
or else
(Is_Record_Type (Typ)
and then Is_Concurrent_Type (It.Typ)
and then Present (Corresponding_Record_Type
(Etype (It.Typ)))
and then Covers (Typ, Corresponding_Record_Type
(Etype (It.Typ))))
and then Present (Corresponding_Record_Type (Etype (It.Typ)))
and then
Covers (Typ, Corresponding_Record_Type (Etype (It.Typ))))
or else
(Is_Concurrent_Type (Typ)
and then Is_Record_Type (It.Typ)
and then Present (Corresponding_Record_Type (Typ))
and then
Covers (Corresponding_Record_Type (Typ), Etype (It.Typ)))
or else
(For_Comparison
and then not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
and then Covers (It.Typ, Typ))
then
return True;
end if;
@ -3010,45 +2941,6 @@ package body Sem_Type is
end if;
end Is_Ancestor;
---------------------------
-- Is_Invisible_Operator --
---------------------------
function Is_Invisible_Operator
(N : Node_Id;
T : Entity_Id) return Boolean
is
Orig_Node : constant Node_Id := Original_Node (N);
begin
if Nkind (N) not in N_Op then
return False;
elsif not Comes_From_Source (N) then
return False;
elsif No (Universal_Interpretation (Right_Opnd (N))) then
return False;
elsif Nkind (N) in N_Binary_Op
and then No (Universal_Interpretation (Left_Opnd (N)))
then
return False;
else
return Is_Numeric_Type (T)
and then not In_Open_Scopes (Scope (T))
and then not Is_Potentially_Use_Visible (T)
and then not In_Use (T)
and then not In_Use (Scope (T))
and then
(Nkind (Orig_Node) /= N_Function_Call
or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
and then not In_Instance;
end if;
end Is_Invisible_Operator;
--------------------
-- Is_Progenitor --
--------------------
@ -3081,6 +2973,65 @@ package body Sem_Type is
return False;
end Is_Subtype_Of;
-------------------------
-- Is_Visible_Operator --
-------------------------
function Is_Visible_Operator (N : Node_Id; Typ : Entity_Id) return Boolean
is
begin
-- The predefined operators of the universal types are always visible
if Typ in Universal_Integer | Universal_Real | Universal_Access then
return True;
-- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow
-- anonymous access types in universal_access equality operators.
elsif Is_Anonymous_Access_Type (Typ) then
return Ada_Version >= Ada_2005;
-- Similar reasoning for special types used for composite types before
-- type resolution is done.
elsif Typ = Any_Composite or else Typ = Any_String then
return True;
-- Within an instance, the predefined operators of the formal types are
-- visible and, for the other types, the generic package declaration has
-- already been successfully analyzed. Likewise for an inlined body.
elsif In_Instance or else In_Inlined_Body then
return True;
-- If the operation is given in functional notation and the prefix is an
-- expanded name, then the operator is visible if the prefix is the scope
-- of the type, or System if the type is declared in an extension of it.
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
then
declare
Pref : constant Entity_Id := Entity (Prefix (Name (N)));
Scop : constant Entity_Id := Scope (Typ);
begin
return Pref = Scop
or else (Present (System_Aux_Id)
and then Scop = System_Aux_Id
and then Pref = Scope (Scop));
end;
-- Otherwise the operator is visible when the type is visible
else
return Is_Potentially_Use_Visible (Typ)
or else In_Use (Typ)
or else (In_Use (Scope (Typ)) and then not Is_Hidden (Typ))
or else In_Open_Scopes (Scope (Typ));
end if;
end Is_Visible_Operator;
------------------
-- List_Interps --
------------------
@ -3184,7 +3135,7 @@ package body Sem_Type is
elsif Op_Name in Name_Op_Eq | Name_Op_Ne then
return Base_Type (T1) = Base_Type (T2)
and then not Is_Limited_Type (T1)
and then Valid_Equality_Arg (T1)
and then Is_Boolean_Type (T);
elsif Op_Name in Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge
@ -3366,60 +3317,41 @@ package body Sem_Type is
or else (T1 = Universal_Real and then Is_Real_Type (T2))
or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
or else (T1 = Any_Modular and then Is_Modular_Integer_Type (T2))
or else (T1 = Any_Character and then Is_Character_Type (T2))
or else (T1 = Any_String and then Is_String_Type (T2))
or else (T1 = Any_Composite and then Is_Aggregate_Type (T2))
then
return B2;
elsif (T1 = Universal_Access
or else Ekind (T1) in E_Allocator_Type | E_Access_Attribute_Type)
and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
then
return B2;
elsif T1 = Raise_Type then
return B2;
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
or else (T2 = Universal_Real and then Is_Real_Type (T1))
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_Modular and then Is_Modular_Integer_Type (T1))
or else (T2 = Any_Character and then Is_Character_Type (T1))
or else (T2 = Any_String and then Is_String_Type (T1))
or else (T2 = Any_Composite and then Is_Aggregate_Type (T1))
then
return B1;
elsif T2 = Any_String and then Is_String_Type (T1) then
return B1;
elsif T1 = Any_String and then Is_String_Type (T2) then
return B2;
elsif T2 = Any_Character and then Is_Character_Type (T1) then
return B1;
elsif T1 = Any_Character and then Is_Character_Type (T2) then
return B2;
elsif T1 = Universal_Access
and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
then
return T2;
elsif T2 = Universal_Access
elsif (T2 = Universal_Access
or else Ekind (T2) in E_Allocator_Type | E_Access_Attribute_Type)
and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
then
return T1;
return B1;
-- In an instance, the specific type may have a private view. Use full
-- view to check legality.
elsif T2 = Universal_Access
and then Is_Private_Type (T1)
and then Present (Full_View (T1))
and then Is_Access_Type (Full_View (T1))
and then In_Instance
then
return T1;
elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
return T1;
elsif T1 = Any_Composite and then Is_Aggregate_Type (T2) then
return T2;
elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
return T2;
elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
return T1;
elsif T2 = Raise_Type then
return B1;
-- ----------------------------------------------------------
-- Special cases for equality operators (all other predefined
@ -3488,16 +3420,6 @@ package body Sem_Type is
then
return T1;
elsif Ekind (T1) in E_Allocator_Type | E_Access_Attribute_Type
and then Is_Access_Type (T2)
then
return T2;
elsif Ekind (T2) in E_Allocator_Type | E_Access_Attribute_Type
and then Is_Access_Type (T1)
then
return T1;
-- Ada 2005 (AI-230): Support the following operators:
-- function "=" (L, R : universal_access) return Boolean;
@ -3513,16 +3435,34 @@ package body Sem_Type is
-- Note that this does not preclude one operand to be a pool-specific
-- access type, as a previous version of this code enforced.
elsif Ada_Version >= Ada_2005 then
if Is_Anonymous_Access_Type (T1)
and then Is_Access_Type (T2)
then
return T1;
elsif Is_Anonymous_Access_Type (T1)
and then Is_Access_Type (T2)
and then Ada_Version >= Ada_2005
then
return T1;
elsif Is_Anonymous_Access_Type (T2)
and then Is_Access_Type (T1)
then
return T2;
elsif Is_Anonymous_Access_Type (T2)
and then Is_Access_Type (T1)
and then Ada_Version >= Ada_2005
then
return T2;
-- In instances, also check private views the same way as Covers
elsif Is_Private_Type (T1) and then In_Instance then
if Present (Full_View (T1)) then
return Specific_Type (Full_View (T1), T2);
elsif Present (Underlying_Full_View (T1)) then
return Specific_Type (Underlying_Full_View (T1), T2);
end if;
elsif Is_Private_Type (T2) and then In_Instance then
if Present (Full_View (T2)) then
return Specific_Type (T1, Full_View (T2));
elsif Present (Underlying_Full_View (T2)) then
return Specific_Type (T1, Underlying_Full_View (T2));
end if;
end if;
@ -3580,15 +3520,14 @@ package body Sem_Type is
-- Valid_Comparison_Arg --
--------------------------
-- See above for the reason why aggregates and strings are included
function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
begin
if Is_Discrete_Type (T) or else Is_Real_Type (T) then
return True;
if T = Any_Composite then
return False;
elsif Is_Discrete_Type (T)
or else Is_Real_Type (T)
then
elsif T = Any_Composite or else T = Any_String then
return True;
elsif Is_Array_Type (T)
@ -3608,11 +3547,40 @@ package body Sem_Type is
elsif Is_String_Type (T) then
return True;
else
return False;
end if;
end Valid_Comparison_Arg;
------------------------
-- Valid_Equality_Arg --
------------------------
-- Same reasoning as above but implicit because of the nonlimited test
function Valid_Equality_Arg (T : Entity_Id) return Boolean is
begin
-- AI95-0230: Keep restriction imposed by Ada 83 and 95, do not allow
-- anonymous access types in universal_access equality operators.
if Is_Anonymous_Access_Type (T) then
return Ada_Version >= Ada_2005;
elsif not Is_Limited_Type (T) then
return True;
elsif Is_Array_Type (T)
and then not Is_Limited_Type (Component_Type (T))
and then Available_Full_View_Of_Component (T)
then
return True;
else
return False;
end if;
end Valid_Equality_Arg;
------------------
-- Write_Interp --
------------------

45
gcc/ada/sem_type.ads
View file

@ -103,9 +103,12 @@ package Sem_Type is
-- in N. If the name is an expanded name, the homonyms are only those that
-- belong to the same scope.
function Is_Invisible_Operator (N : Node_Id; T : Entity_Id) return Boolean;
-- Check whether a predefined operation with universal operands appears in
-- a context in which the operators of the expected type are not visible.
function Is_Visible_Operator (N : Node_Id; Typ : Entity_Id) return Boolean;
-- Determine whether a predefined operation is performed in a context where
-- the predefined operators of base type Typ are visible. The existence of
-- this routine is an implementation artifact. A more straightforward but
-- more space-consuming choice would be to make all inherited operators
-- explicit in the symbol table. See also Sem_ch8.Has_Implicit_Operator.
procedure List_Interps (Nam : Node_Id; Err : Node_Id);
-- List candidate interpretations of an overloaded name. Used for various
@ -181,22 +184,15 @@ package Sem_Type is
-- opposed to an operator, type and mode conformance are required.
function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id;
-- Used in second pass of resolution, for equality and comparison nodes. L
-- is the left operand, whose type is known to be correct, and R is the
-- right operand, which has one interpretation compatible with that of L.
-- Return the type intersection of the two.
-- Used in type resolution for equality and comparison nodes. L and R are
-- the operands, whose type is known to be correct or Any_Type in case of
-- ambiguity. Return the type intersection of the two.
function Has_Compatible_Type
(N : Node_Id;
Typ : Entity_Id;
For_Comparison : Boolean := False) return Boolean;
function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean;
-- Verify that some interpretation of the node N has a type compatible with
-- Typ. If N is not overloaded, then its unique type must be compatible
-- with Typ. Otherwise iterate through the interpretations of N looking for
-- a compatible one. If For_Comparison is true, the function is invoked for
-- a comparison (or equality) operator and also needs to verify the reverse
-- compatibility, because the implementation of type resolution for these
-- operators is not fully symmetrical.
-- a compatible one.
function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean;
-- A user-defined function hides a predefined operator if it matches the
@ -259,13 +255,22 @@ package Sem_Type is
procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id);
-- Set the abstract operation field of an interpretation
function Valid_Comparison_Arg (T : Entity_Id) return Boolean;
-- A valid argument to an ordering operator must be a discrete type, a
-- real type, or a one dimensional array with a discrete component type.
function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
-- If Typ_1 and Typ_2 are compatible, return the one that is not universal
-- or is not a "class" type (any_character, etc).
function Valid_Boolean_Arg (T : Entity_Id) return Boolean;
-- A valid argument of a boolean operator is either some boolean type, or a
-- one-dimensional array of boolean type.
-- A valid argument of a predefined boolean operator must be a boolean type
-- or a 1-dimensional array of boolean type.
function Valid_Comparison_Arg (T : Entity_Id) return Boolean;
-- A valid argument of a predefined comparison operator must be a discrete
-- type, real type or a 1-dimensional array with a discrete component type.
function Valid_Equality_Arg (T : Entity_Id) return Boolean;
-- A valid argument of a predefined equality operator must be a nonlimited
-- type or an array with a limited private component whose full view is not
-- limited.
procedure Write_Interp (It : Interp);
-- Debugging procedure to display an Interp

19
gcc/ada/sem_util.adb
View file

@ -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 --
--------------------------------------

6
gcc/ada/sem_util.ads
View file

@ -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.