diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 1b40cd9472ef42e7483c748e56b35cbf0f046637..a0bfb398ebb3163db26e303d6ce2ff52da048eaa 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -99,6 +99,7 @@ package Gen_IL.Fields is
Comes_From_Check_Or_Contract,
Comes_From_Extended_Return_Statement,
Comes_From_Iterator,
+ Compare_Type,
Compile_Time_Known_Aggregate,
Component_Associations,
Component_Clauses,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index fdf928d60a37800a82ed46fc4a2c1a912df1cc00..996d8d78aeae1798e95faa039a7ea517a10e8d59 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -267,32 +267,38 @@ begin -- Gen_IL.Gen.Gen_Nodes
Cc (N_Op_Eq, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Ge, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Gt, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Le, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Lt, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Ne, N_Op_Compare,
(Sm (Chars, Name_Id),
Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Sy (Right_Opnd, Node_Id),
+ Sm (Compare_Type, Node_Id)));
Cc (N_Op_Or, N_Op_Boolean,
(Sm (Chars, Name_Id),
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 582940da74bcbbd4a335003d56e0e0205182f420..f73e1b53b0e3df89dc354ad74f92686e1eae1690 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -7685,7 +7685,9 @@ package body Sem_Ch12 is
------------------------
procedure Check_Private_View (N : Node_Id) is
- Typ : constant Entity_Id := Etype (N);
+ Comparison : constant Boolean := Nkind (N) in N_Op_Compare;
+ Typ : constant Entity_Id :=
+ (if Comparison then Compare_Type (N) else Etype (N));
procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean);
-- Check that the available view of T matches Private_View and, if not,
@@ -7749,10 +7751,16 @@ package body Sem_Ch12 is
and then (not In_Open_Scopes (Scope (Typ))
or else Nkind (Parent (N)) = N_Subtype_Declaration)
then
- -- In the generic, only the private declaration was visible
+ declare
+ Assoc : constant Node_Id := Get_Associated_Node (N);
+
+ begin
+ -- In the generic, only the private declaration was visible
- Prepend_Elmt (Typ, Exchanged_Views);
- Exchange_Declarations (Etype (Get_Associated_Node (N)));
+ Prepend_Elmt (Typ, Exchanged_Views);
+ Exchange_Declarations
+ (if Comparison then Compare_Type (Assoc) else Etype (Assoc));
+ end;
-- Check that the available views of Typ match their respective flag.
-- Note that the type of a visible discriminant is never private.
@@ -8166,30 +8174,6 @@ package body Sem_Ch12 is
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
- -- For the comparison and equality operators, the Etype
- -- of the operator does not provide any information so,
- -- if one of the operands is of a universal type, we need
- -- to manually restore the full view of private types.
-
- if Nkind (N) in N_Op_Compare then
- if Yields_Universal_Type (Left_Opnd (Assoc)) then
- if Present (Etype (Right_Opnd (Assoc)))
- and then
- Is_Private_Type (Etype (Right_Opnd (Assoc)))
- then
- Switch_View (Etype (Right_Opnd (Assoc)));
- end if;
-
- elsif Yields_Universal_Type (Right_Opnd (Assoc)) then
- if Present (Etype (Left_Opnd (Assoc)))
- and then
- Is_Private_Type (Etype (Left_Opnd (Assoc)))
- then
- Switch_View (Etype (Left_Opnd (Assoc)));
- end if;
- end if;
- end if;
-
-- The node is a reference to a global type and acts as the
-- subtype mark of a qualified expression created in order
-- to aid resolution of accidental overloading in instances.
@@ -16883,6 +16867,11 @@ package body Sem_Ch12 is
end if;
end;
+ -- Do not walk the node pointed to by Label_Construct twice
+
+ elsif Nkind (N) = N_Implicit_Label_Declaration then
+ null;
+
else
Save_References_In_Descendants (N);
end if;
@@ -16894,10 +16883,27 @@ package body Sem_Ch12 is
---------------------
procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
- Typ : constant Entity_Id := Etype (N2);
+ Comparison : constant Boolean := Nkind (N2) in N_Op_Compare;
+ Typ : constant Entity_Id :=
+ (if Comparison then Compare_Type (N2) else Etype (N2));
begin
- Set_Etype (N, Typ);
+ -- For a comparison (or equality) operator, the Etype is Boolean, so
+ -- it is always global. But the type subject to the Has_Private_View
+ -- processing is the Compare_Type, so we must specifically check it.
+
+ if Comparison then
+ Set_Etype (N, Etype (N2));
+
+ if not Is_Global (Typ) then
+ return;
+ end if;
+
+ Set_Compare_Type (N, Typ);
+
+ else
+ Set_Etype (N, Typ);
+ end if;
-- If the entity of N is not the associated node, this is a
-- nested generic and it has an associated node as well, whose
@@ -16939,7 +16945,11 @@ package body Sem_Ch12 is
Set_Has_Private_View (N);
if Present (Full_View (Typ)) then
- Set_Etype (N2, Full_View (Typ));
+ if Comparison then
+ Set_Compare_Type (N2, Full_View (Typ));
+ else
+ Set_Etype (N2, Full_View (Typ));
+ end if;
end if;
end if;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 78249258f55c0a655524cfecdae850660142cae6..83705b9dae1b10296745dc7b29b2d692af1bfac6 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2057,8 +2057,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 operands with the
- -- common type that must be present, or with the type of the formal of
- -- the user-defined function.
+ -- compare type if it is present, typically because it is a global type
+ -- in a generic instance, or 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);
@@ -2071,7 +2072,10 @@ package body Sem_Ch4 is
if Is_Overloaded (L) then
if Ekind (Op_Id) = E_Operator then
- Set_Etype (L, Intersect_Types (L, R));
+ Set_Etype (L,
+ (if Present (Compare_Type (N))
+ then Compare_Type (N)
+ else Intersect_Types (L, R)));
else
Set_Etype (L, Etype (First_Formal (Op_Id)));
end if;
@@ -2079,7 +2083,10 @@ package body Sem_Ch4 is
if Is_Overloaded (R) then
if Ekind (Op_Id) = E_Operator then
- Set_Etype (R, Intersect_Types (L, R));
+ Set_Etype (R,
+ (if Present (Compare_Type (N))
+ then Compare_Type (N)
+ else Intersect_Types (L, R)));
else
Set_Etype (R, Etype (Next_Formal (First_Formal (Op_Id))));
end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index fa1365c26417c696cfc84cfd3ad7c97c60631a18..42f7c10c5c59bf92695b8eeff59c991aceef57ad 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7611,6 +7611,7 @@ package body Sem_Res is
Resolve (L, T);
Resolve (R, T);
+ Set_Compare_Type (N, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
@@ -9119,6 +9120,7 @@ package body Sem_Res is
Resolve (L, T);
Resolve (R, T);
+ Set_Compare_Type (N, T);
-- AI12-0413: user-defined primitive equality of an untagged record
-- type hides the predefined equality operator, including within a
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index fc9bcfbd44db74984507c7f64940aeb0c62dea78..8f9626019853e543d2d260f531c48263e0ed45b6 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -962,6 +962,20 @@ package Sinfo is
-- was constructed as part of the expansion of an iterator
-- specification.
+ -- Compare_Type
+ -- Present in N_Op_Compare nodes. Set during resolution to the type of
+ -- the operands. It is used to propagate the type of the operands from
+ -- a N_Op_Compare node in a generic construct to the nodes created from
+ -- it in the various instances, when this type is global to the generic
+ -- construct. Resolution for global types cannot be redone in instances
+ -- because the instantiation can be done out of context, e.g. for bodies,
+ -- and the visibility of global types is incorrect in this case; that is
+ -- why the result of the resolution done in the generic construct needs
+ -- to be available in the instances but, unlike for arithmetic operators,
+ -- the Etype cannot be used to that effect for comparison operators. It
+ -- is also used as the type subject to the Has_Private_View processing on
+ -- the nodes instead of the Etype.
+
-- Compile_Time_Known_Aggregate
-- Present in N_Aggregate nodes. Set for aggregates which can be fully
-- evaluated at compile time without raising constraint error. Such
@@ -4507,31 +4521,37 @@ package Sinfo is
-- N_Op_Eq
-- Sloc points to =
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Ne
-- Sloc points to /=
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Lt
-- Sloc points to <
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Le
-- Sloc points to <=
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Gt
-- Sloc points to >
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Ge
-- Sloc points to >=
+ -- Compare_Type
-- plus fields for binary operator
-- plus fields for expression