From: Eric Botcazou <ebotca...@adacore.com>
The code is legal and, therefore, must be accepted by the compiler, but it
must raise Program_Error at run time due to operands not having inferable
discriminants and a warning be given at compile time (RM B.3.3(22-23)).
gcc/ada/
* exp_ch4.adb (Expand_Array_Equality.Component_Equality): Copy the
Comes_From_Source flag from the original test to the new one, and
remove obsolete code dealing with unchecked unions.
* sem_util.adb (Has_Inferable_Discriminants): Return False for an
incomplete or private nominal subtype.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch4.adb | 27 +++++++++------------------
gcc/ada/sem_util.adb | 7 +++++--
2 files changed, 14 insertions(+), 20 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 7349dfc306f..983f66231a2 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1570,26 +1570,17 @@ package body Exp_Ch4 is
(Outer_Type => Typ, Nod => Nod, Comp_Type => Component_Type (Typ),
Lhs => L, Rhs => R);
- -- If some (sub)component is an unchecked_union, the whole operation
- -- will raise program error.
+ -- This is necessary to give the warning about Program_Error being
+ -- raised when some (sub)component is an unchecked_union.
- if Nkind (Test) = N_Raise_Program_Error then
+ Preserve_Comes_From_Source (Test, Nod);
- -- This node is going to be inserted at a location where a
- -- statement is expected: clear its Etype so analysis will set
- -- it to the expected Standard_Void_Type.
-
- Set_Etype (Test, Empty);
- return Test;
-
- else
- return
- Make_Implicit_If_Statement (Nod,
- Condition => Make_Op_Not (Loc, Right_Opnd => Test),
- Then_Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_False, Loc))));
- end if;
+ return
+ Make_Implicit_If_Statement (Nod,
+ Condition => Make_Op_Not (Loc, Right_Opnd => Test),
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc))));
end Component_Equality;
------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8425359e052..4cdac9443e6 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12119,11 +12119,14 @@ package body Sem_Util is
and then Is_Constrained (Etype (Subtype_Mark (N)));
-- For all other names, it is sufficient to have a constrained
- -- Unchecked_Union nominal subtype.
+ -- Unchecked_Union nominal subtype, unless it is incomplete or
+ -- private because it cannot have a known discriminant part in
+ -- this case (RM B.3.3 (11/2)).
else
return Is_Unchecked_Union (Etype (N))
- and then Is_Constrained (Etype (N));
+ and then Is_Constrained (Etype (N))
+ and then not Is_Incomplete_Or_Private_Type (Etype (N));
end if;
end Has_Inferable_Discriminants;
--
2.45.1
