The XOR operation applied to a boolean array whose component type has
the range True .. True raises constraint error. Previous to this patch,
the expansion of the operation could lead to uplevel references that
were not handled properly when unnesting is in effect.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-11-14 Ed Schonberg <schonb...@adacore.com>
gcc/ada/
* exp_util.ads, exp_util.adb: Change the profile of
Silly_Boolean_Array_Xor_Test, adding a formal that can be a copy
of the right opersnd. This prevents unnesting anomalies when
that operand contains uplevel references.
* exp_ch4.adb (Expand_Boolean_Operation): Use this new profile.
* exp_pakd.adb (Expand_Packed_Boolean_Operator): Ditto.--- gcc/ada/exp_ch4.adb
+++ gcc/ada/exp_ch4.adb
@@ -2031,7 +2031,7 @@ package body Exp_Ch4 is
declare
Loc : constant Source_Ptr := Sloc (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
- R : constant Node_Id := Relocate_Node (Right_Opnd (N));
+ R : Node_Id := Relocate_Node (Right_Opnd (N));
Func_Body : Node_Id;
Func_Name : Entity_Id;
@@ -2043,7 +2043,8 @@ package body Exp_Ch4 is
Apply_Length_Check (R, Etype (L));
if Nkind (N) = N_Op_Xor then
- Silly_Boolean_Array_Xor_Test (N, Etype (L));
+ R := Duplicate_Subexpr (R);
+ Silly_Boolean_Array_Xor_Test (N, R, Etype (L));
end if;
if Nkind (Parent (N)) = N_Assignment_Statement
--- gcc/ada/exp_pakd.adb
+++ gcc/ada/exp_pakd.adb
@@ -1506,7 +1506,7 @@ package body Exp_Pakd is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
- R : constant Node_Id := Relocate_Node (Right_Opnd (N));
+ R : Node_Id := Relocate_Node (Right_Opnd (N));
Ltyp : Entity_Id;
Rtyp : Entity_Id;
@@ -1528,7 +1528,8 @@ package body Exp_Pakd is
-- True .. True where an exception must be raised.
if Nkind (N) = N_Op_Xor then
- Silly_Boolean_Array_Xor_Test (N, Rtyp);
+ R := Duplicate_Subexpr (R);
+ Silly_Boolean_Array_Xor_Test (N, R, Rtyp);
end if;
-- Now that that silliness is taken care of, get packed array type
--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -7062,7 +7062,6 @@ package body Exp_Util is
| N_Procedure_Instantiation
| N_Protected_Body
| N_Protected_Body_Stub
- | N_Protected_Type_Declaration
| N_Single_Task_Declaration
| N_Subprogram_Body
| N_Subprogram_Body_Stub
@@ -7071,7 +7070,6 @@ package body Exp_Util is
| N_Subtype_Declaration
| N_Task_Body
| N_Task_Body_Stub
- | N_Task_Type_Declaration
-- Use clauses can appear in lists of declarations
@@ -7135,6 +7133,21 @@ package body Exp_Util is
return;
end if;
+ -- the expansion of Task and protected type declarations can
+ -- create declarations for temporaries which, like other actions
+ -- are inserted and analyzed before the current declaraation.
+ -- However, the current scope is the synchronized type, and
+ -- for unnesting it is critical that the proper scope for these
+ -- generated entities be the enclosing one.
+
+ when N_Task_Type_Declaration
+ | N_Protected_Type_Declaration =>
+
+ Push_Scope (Scope (Current_Scope));
+ Insert_List_Before_And_Analyze (P, Ins_Actions);
+ Pop_Scope;
+ return;
+
-- A special case, N_Raise_xxx_Error can act either as a statement
-- or a subexpression. We tell the difference by looking at the
-- Etype. It is set to Standard_Void_Type in the statement case.
@@ -13400,7 +13413,8 @@ package body Exp_Util is
-- required for the case of False .. False, since False xor False = False.
-- See also Silly_Boolean_Array_Not_Test
- procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
+ procedure Silly_Boolean_Array_Xor_Test
+ (N : Node_Id; R : Node_Id; T : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
CT : constant Entity_Id := Component_Type (T);
@@ -13435,7 +13449,7 @@ package body Exp_Util is
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_Last))),
- Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
+ Right_Opnd => Make_Non_Empty_Check (Loc, R)),
Reason => CE_Range_Check_Failed));
end Silly_Boolean_Array_Xor_Test;
--- gcc/ada/exp_util.ads
+++ gcc/ada/exp_util.ads
@@ -1140,11 +1140,14 @@ package Exp_Util is
-- the boolean array is False..False or True..True, where it is required
-- that a Constraint_Error exception be raised (RM 4.5.6(6)).
- procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id);
- -- N is the node for a boolean array XOR operation, and T is the type of
- -- the array. This routine deals with the silly case where the subtype of
- -- the boolean array is True..True, where a raise of a Constraint_Error
- -- exception is required (RM 4.5.6(6)).
+ procedure Silly_Boolean_Array_Xor_Test
+ (N : Node_Id; R : Node_Id; T : Entity_Id);
+ -- N is the node for a boolean array XOR operation, T is the type of the
+ -- array, and R is a copy of the right operand of N, required to prevent
+ -- scope anomalies when unnesting is in effect. This routine deals with
+ -- the admitedly silly case where the subtype of the boolean array is
+ -- True..True, where a raise of a Constraint_Error exception is required
+ -- (RM 4.5.6(6)) and ACATS-tested.
function Target_Has_Fixed_Ops
(Left_Typ : Entity_Id;
